fork download
copy 
  1. #lang racket
  2.  
  3. (require (only-in srfi/1 alist-cons alist-delete unfold))
  4. (provide compress)
  5.  
  6. (define (createValue2Code data)
  7.   ;; 各要素の発生回数を数える
  8.   (define (countDatum) ;; ローカル関数の場合、スコープが createValue2Code の data を捕捉する
  9.     (map (match-lambda
  10.            ((cons n c) `(,c ,n)))
  11.          (sort
  12.           (foldl (lambda (elt lst)
  13.                    (cond ((assv elt lst)
  14.                           => (lambda (x)
  15.                                (alist-cons elt (add1 (cdr x))
  16.                                            (alist-delete elt lst))))
  17.                          (else (alist-cons elt 1 lst))))
  18.                  '() (string->list data)) #:key cdr <)))
  19.   ;; ハフマン木を生成
  20.   (define (generateHuffman lst)
  21.     (foldl (lambda (elt lst)
  22.              (if (null? lst)
  23.                  elt
  24.                  `(,(+ (car elt) (car lst)) (,elt ,lst))))
  25.            '() lst))
  26.   ;; 符号情報を作成
  27.   (define (codeInfo n)
  28.   (apply + (map (lambda (x)
  29.                   (expt 2 x)) (range 1 (add1 n)))))
  30.   (define value2code
  31.     (case-lambda
  32.       ((tree acc)
  33.        (match-let ((`(,x ,xs) tree))
  34.          (if (char? xs)
  35.              (foldl (lambda (y x)
  36.                       (match-let ((`(,parent (,left '())) y))
  37.                         `(,parent (,left ,x))))
  38.                     `(,(add1 (codeInfo (sub1 x))) ,xs) acc)
  39.              (match-let ((`((,m ,left) (,n ,right)) xs))
  40.                (let ((k (codeInfo x)))
  41.                  (value2code `(,(add1 x) ,right)
  42.                              (cons `(,x ((,k ,left) '())) acc)))))))
  43.       ((tree)
  44.        (value2code tree '()))))
  45.   (define dfs
  46.     (case-lambda
  47.       ((tree acc)
  48.        (match-let ((`(,a (,b ,bs)) tree))
  49.          (match-let ((`(,x ,xs) bs))
  50.            (if (char? xs)
  51.                (let ((lst (reverse `(,bs ,b ,@acc))))
  52.                  (values (map (match-lambda (`(,x ,xs) (cons xs x))) lst)
  53.                          (map (match-lambda (`(,x ,xs) (cons x xs))) lst)))
  54.                (dfs bs (cons b acc))))))
  55.       ((tree)
  56.        (dfs tree '()))))  
  57.   (dfs (value2code (cons 0 (cdr (generateHuffman (countDatum)))))))
  58.  
  59. (define (compress data)
  60.   (let-values (((compress-table uncompress-table) (createValue2Code data)))
  61.     (values (map (lambda (key)
  62.                    (cdr (assv key compress-table))) (string->list data))
  63.             uncompress-table)))
Success #stdin #stdout 0.67s 115628KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/eeyocL
language:
Racket (racket 7.0)
created:
324 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!