fork download
copy 
  1. (define (tally xs)
  2.   (define (aux acc xs)
  3.     (if (null? xs)
  4.         acc
  5.         (let* ((k (car xs))
  6.                (v (alist-ref k acc))
  7.                (a (alist-update k (+ 1 (or v 0)) acc)))
  8.           (aux a (cdr xs)))))
  9.   (aux '() xs))
  10. (define (factorial n)
  11.   (define (aux acc n)
  12.     (if (= n 0)
  13.         acc
  14.         (aux (* acc n) (- n 1))))
  15.   (aux 1 n))
  16. (define (n-permutations xs)
  17.   (/ (factorial (length xs)) (foldl (lambda (acc kv) (* acc (factorial (cdr kv)))) 1 (tally xs))))
  18. (define (count f xs)
  19.   (foldl (lambda (acc x) (+ acc (if (f x) 1 0))) 0 xs))
  20. (define (f xs)
  21.   (define (aux acc xs)
  22.     (if (null? xs)
  23.         acc
  24.         (let* ((c (count (lambda (x) (< x (car xs))) xs))
  25.                (p (n-permutations xs))
  26.                (w (length xs)))
  27.           (aux (+ acc (/ (* c p) w)) (cdr xs)))))
  28.   (aux 1 xs))
  29. (print (f '(1 2 3 4 5 6 7 8 9)))
  30. (print (f '(1 2 3 4 5 6 7 9 8)))
  31. (print (f '(1 2 3 4 5 6 8 7 9)))
  32. (print (f '(4 1 6 5 8 9 7 3 2)))
  33. (print (f '(6 8 4 7 5 3 2 1 9)))
  34. (print (f '(9 8 7 6 5 4 3 2 1)))
  35. (print (f '(1 1 1 2 2 2 3 3 3 4 4 4)))
  36. (print (f '(1 1 1 2 2 2 3 3 4 3 4 4)))
  37. (print (f '(1 1 1 2 2 2 3 3 4 4 3 4)))
  38. (print (f '(2 2 2 3 3 1 4 3 4 1 1 4)))
  39. (print (f '(3 2 4 4 2 4 3 3 1 1 1 2)))
  40. (print (f '(4 4 4 3 3 3 2 2 2 1 1 1)))
  41. (print (f '(3 1 4 1 5 9)))
  42.  
Success #stdin #stdout 0.02s 8064KB
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/fZufck
language:
Scheme (chicken 4.13)
created:
18 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!