Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2007-04-06

L-99 (50)

| 00:13 | L-99 (50) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (50) - わだばLisperになる

L-99 50問目に挑戦 - L-99:Ninety-Nine Lisp Problems

P50

解答
;;; Common Lisp
(defun for-each-tree (f g n tree)
  (cond ((not (listp tree)) (funcall f tree))		
	((endp tree) n)
	('t (funcall g (for-each-tree f g n (car tree))
		     (for-each-tree f g n (cdr tree))))))

(defun make-frequency-list (lst &aux (retlst '()))
  (dolist (item lst retlst)
    (let ((found-item (assoc item retlst)))
      (if found-item
	  (incf (cdr found-item))
	  (setf retlst `(,@retlst (,item . 1)))))))

(defun make-huffman-tree (lst)
  (if (= (length lst) 1)
    (caar lst)
    (make-huffman-tree
     (destructuring-bind (a b &rest c)
	 (sort lst #'(lambda (a b) (< (cdr a) (cdr b))))
       `(((,(car a) ,(car b)) . ,(+ (cdr a) (cdr b))) ,@c)))))

(defun huffman-tree->code (tree &optional (code ""))
  (cond ((not (listp tree)) `(,tree ,code))
	((endp tree) '())
	('t `(,(huffman-tree->code (car tree) (concatenate 'string code "1"))
	       (,(huffman-tree->code (cadr tree) (concatenate 'string code "0")))))))

(defun flatten-tree (tree)
  (for-each-tree #'list #'append '() tree))

(defun rebuild-list (lst)
  (do ((l lst (cddr l))
       (retlst '() `(,@retlst (,(car l) ,(cadr l)))))
      ((endp l) retlst)))

(defun huffman-encode (lst)
  (rebuild-list
   (flatten-tree
    (huffman-tree->code 
     (make-huffman-tree 
      (make-frequency-list lst))))))

(defun pp-huffman-code (lst)
  (mapc #'(lambda (item)
	    (format t "~A => ~A~%" (car item) (cadr item)))
	lst))

; 使い方:
; (pp-huffman-code
; (sort (huffman-encode *testdata*) #'(lambda (a b) (char< (car a) (car b)))))

;;; Scheme
(use util.match)

;; util
(define (for-each-tree f g n tree)
  (cond ((null? tree) n)
	((not (pair? tree)) (f tree))
	(else (g (for-each-tree f g n (car tree))
		 (for-each-tree f g n (cdr tree))))))

(define (make-frequency-list lst)
  (let ((retlst '()))
    (dolist (item lst retlst)
	    (let ((found-item (assoc item retlst)))
	      (if found-item
		  (inc! (cdr found-item))
		  (set! retlst `(,@retlst (,item . 1))))))))

(define (make-huffman-tree lst)
  (if (= (length lst) 1)
      (caar lst)
      (make-huffman-tree
       (match-let (((a b . c) (sort lst (lambda (a b) (< (cdr a) (cdr b))))))
		  `(((,(car a) ,(car b)) . ,(+ (cdr a) (cdr b))) ,@c)))))

(define (huffman-tree->code tree)
  (let tree->code ((tree tree)
		   (code ""))
    (cond ((not (list? tree)) `(,tree ,code))
	  ((null? tree) '())
	  (else `(,(tree->code (car tree) (string-append code "1"))
		  (,(tree->code (cadr tree) (string-append code "0"))))))))

(define (flatten-tree tree)
  (for-each-tree list append '() tree))

(define (rebuild-list lst)
  (do ((l lst (cddr l))
       (retlst '() `(,@retlst (,(car l) ,(cadr l)))))
      ((null? l) retlst)))

(define (huffman-encode lst)
  (rebuild-list
   (flatten-tree
    (huffman-tree->code 
     (make-huffman-tree 
      (make-frequency-list lst))))))

(define (pp-huffman-code lst)
  (for-each (lambda (item)
	      (format #t "~A => ~A~%" (car item) (cadr item)))
	    lst))
;

今回は、データをハフマン符号化してみようというお題。

ハフマン符号とはデータ圧縮などで用いられる符号化方

式で、JPEGとか、LHAで使われているらしい。

今回も日本語版のWikipediaに解説があったので、その

まま実装していたが、そのまま作ると全然圧縮してくれ

てないことに気付いた。あの記載は正しいのだろうか。

良く分かんないので、他のサイトを参照しつつ再度挑戦

しなんとか作成。Scheme版は殆どCLの写し。

また、今回木構造を操作する必要があったので、

(Scheme)(Lisp)さんのところの(高階関数の使い方)から、

for-each-treeとflatten-treeを拝借した。

何が何だか分からない仕上がり。

関数内関数に纏めた方が良いものもあるような、そうで

もないような。