fork download
copy 
  1. ;(import (chicken sort))
  2. (define (chunk xs)
  3.   (define (aux acc xs)
  4.     (cond
  5.      ((null? xs) (reverse acc))
  6.      ((or (null? acc) (not (= (caar acc) (car xs)))) (aux (cons (list (car xs)) acc) (cdr xs)))
  7.      (else (aux (cons (cons (car xs) (car acc)) (cdr acc)) (cdr xs)))))
  8.   (aux '() xs))
  9. (define (factorial n)
  10.   (define (aux acc n)
  11.     (if (= n 0)
  12.         acc
  13.         (aux (* acc n) (- n 1))))
  14.   (aux 1 n))
  15. (define (n-permutations xs)
  16.   (/ (factorial (length xs)) (foldl (lambda (acc ys) (* acc (factorial (length ys)))) 1 (chunk (sort xs <)))))
  17. (define (count f xs)
  18.   (foldl (lambda (acc x) (+ acc (if (f x) 1 0))) 0 xs))
  19. (define (f xs)
  20.   (define (aux acc xs)
  21.     (if (null? xs)
  22.         acc
  23.         (aux (+ acc (/ (* (count (lambda (x) (< x (car xs))) xs) (n-permutations xs)) (length xs))) (cdr xs))))
  24.   (aux 1 xs))
  25. (print (f '(1 2 3 4 5 6 7 8 9)))
  26. (print (f '(1 2 3 4 5 6 7 9 8)))
  27. (print (f '(1 2 3 4 5 6 8 7 9)))
  28. (print (f '(4 1 6 5 8 9 7 3 2)))
  29. (print (f '(6 8 4 7 5 3 2 1 9)))
  30. (print (f '(9 8 7 6 5 4 3 2 1)))
  31. (print (f '(1 1 1 2 2 2 3 3 3 4 4 4)))
  32. (print (f '(1 1 1 2 2 2 3 3 4 3 4 4)))
  33. (print (f '(1 1 1 2 2 2 3 3 4 4 3 4)))
  34. (print (f '(2 2 2 3 3 1 4 3 4 1 1 4)))
  35. (print (f '(3 2 4 4 2 4 3 3 1 1 1 2)))
  36. (print (f '(4 4 4 3 3 3 2 2 2 1 1 1)))
  37. (print (f '(3 1 4 1 5 9)))
  38.  
Success #stdin #stdout 0.02s 8008KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
1
2
3
123456
234567
362880
1
2
3
123456
234567
369600
127
https://ideone.com/jwWrRt
language:
Scheme (chicken 4.13)
created:
22 days ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!