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-20

L-99 (64)

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

L-99 P64に挑戦 - L-99:Ninety-Nine Lisp Problems

二分木を座標付きで下図のように表現すると、

N=(8,1)Q=(10,5)のようになる。

  1  2  3  4  5  6  7  8  9 10 11 12
1                 ,---(N)---------,
2     ,---------(K),   	    ,-----(U)
3  ,(C)------, 	   (M) 	 (P)---,     
4 A    	    ,-H	       	      ,-S
5	  ,G   	       	     Q 	 
6	E

ということで、二分木のデータを与えて、ノード名に座

標が入った同じ構造の二分木を返すというのが今回のお

題。

Lisp Machine Lispの回答では用意されていない関数を適宜定義してみた。

P64

解答
;; Lisp Machine Lisp
(defun range (start end)
  (do ((i start (1+ i))
       (retlst '()))
      ((> i end) (nreverse retlst))
    (push i retlst)))

(defun subseq (lst start end)
  (let ((len (length lst)))
    (cond ((or (minusp start) (minusp end))
	   (ferror nil "The value is out of range for ~S")
	  ((> end len) 
	   (ferror nil "The bounding indeces ~S and ~S are bad for sequence of length ~S" 
		   start end len))
	  ('T
	   (if lst
	       (do ((l (nthcdr start lst) (cdr l))
		    (c (- end start) (1- c))
		    (retlst '() ))
		   ((zerop c) (nreverse retlst))
		 (setq retlst (cons (car l) retlst)))))))))

(defun count-leaves-and-nods (tree)
  (if tree
      (+ 1
	 (count-leaves-and-nodes (second tree))
	 (count-leaves-and-nodes (third tree)))
    0))

(defun tree->numlist (tree)
  (let ((len (count-leaves-and-nodes tree)))
    (let ((numlist (range 1 len)))
      numlist)))

(defun layout-binary-tree (tree &optional (numlist (tree->numlist tree)) (level 1))
  (if (null tree)
      '()
    (let ((llen (count-leaves-and-nodes (cadr tree))))
      `((,(nth llen numlist) . ,level)		;root
	,(if (zerop llen)			;left
	     '()
	   (layout-binary-tree (cadr tree)
			       (subseq numlist 0 llen)
			       (1+ level)))
	,(layout-binary-tree (caddr tree)	;right
			     (nthcdr (1+ llen)  numlist)
			     (1+ level))))))

;; Common Lisp
(defun count-leaves-and-nodes (tree)
  (prog (total job tmp)
        (setq total 0)
	(push tree  job)
     l  (cond ((endp job) (return total)))
	(and (setq tmp (pop job))
	     (setq total (1+ total))
	     (push (caddr tmp) job)	;right
	     (push (cadr tmp)  job))	;left
	(go l)))

(defun tree->numlist (tree)
  (let ((len (count-leaves-and-nodes tree)))
    (let ((numlist (range 1 len)))
      numlist)))

(defun layout-binary-tree (tree)
  (labels ((frob (tree numlist level)
	     (if (endp tree)
		 '()
		 (let ((llen (count-leaves-and-nodes (cadr tree))))
		   `((,(nth llen numlist) . ,level) ;root
		     ,(if (zerop llen)		    ;left
			  '()
			  (frob (cadr tree) (subseq numlist 0 llen) (1+ level)))
		     ,(frob (caddr tree) (nthcdr (1+ llen)  numlist) (1+ level))))))) ;right
    (frob tree (tree->numlist tree) 1)))

;; Scheme 
(define (count-leaves-and-nodes tree)
  (let loop ((count 0) 
	     (job tree))
    (if (null? job)
	count
	(if (pair? (car job))		;list
	    (loop (+ count 1)		
		  (cdr `(,@(car job) ,@(cdr job))))
	    (if (null? (car job))	;atom
		(loop count (cdr job))
		(loop (+ count 1) (cdr job)))))))

(define (tree->numlist tree)
  (let ((len (count-leaves-and-nodes tree)))
    (let ((numlist (range 1 len)))
      numlist)))

(define (layout-binary-tree tree)
  (let frob ((tree tree)
	     (numlist (tree->numlist tree))
	     (level 1)
	     (cont values))
    (if (null? tree)
	(cont '())
	(let ((llen (count-leaves-and-nodes (cadr tree))))
	  (frob (cadr tree) (take numlist (+ llen 1)) (+ level 1) 
		(lambda (left)
		  (frob (caddr tree) (list-tail numlist  (+ llen 1)) (+ level 1) 
			(lambda (right)
			  (cont `((,(list-ref numlist llen) . ,level)
				  ,(if (zero? llen) '() left)
				  ,right))))))))))

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20070420