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-05-03

L-99 (69)

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

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

難しいのは飛して今回は、P69に挑戦。

しかし、段々煮詰って来てしまい、どれもややこしくなっ

てきた。

またもや、文字列表現とリスト表現の変換がお題。

SchemeはもうすこしSchemeらしいスタイルにしたいとこ

ろ。

残りの問題:'(27 55 58-60 63 66 68 80-94 96-99)

P69

解答
;; LISP Machine LISP
(defun tree<=>dotstring (list-or-string)
  (if (stringp list-or-string)
      (dotstring->tree list-or-string)
    (tree->dotstring list-or-string)))

(defun tree->dotstring (tree)
  (string-join (tree->dotstring-aux tree)))

(defun tree->dotstring-aux (tree)
  (if tree
      `(,(string (car tree)) 
	,@(tree->dotstring-aux (cadr tree))
	,@(tree->dotstring-aux (caddr tree)))
    '(".")))

(defun string-join (strs &optional (delim ""))
  (if strs
      (let ((retstr (car strs)))
	(do ((s (cdr strs) (cdr s))
	     (retstr retstr (string-append retstr delim (car s))))
	    ((null s) retstr)))
    ""))

(defun dotstring->tree (str)
  (if (string-equal "" str)
      '()
    (let ((root (substring str 0 1)))
      (if (string-equal root ".")
	  '()
	(multiple-value-bind (l r) (tree-string>get-children str)
	  `(,(read-from-string root)
	    ,(dotstring->tree l)
	    ,(dotstring->tree r)))))))

(defun tree-string>get-boundary (str)
  (let ((point 1))
    (dotimes (i (1- (string-length str)))
      (if (not (string-equal "." (substring str i (1+ i))))
	  (setq point (+ 1 point))
	(setq point (- point 1)))
      (if (zerop point)
	  (return i)))))

(defun tree-string>get-children (str)
  (let ((rootless (substring str 1)))
    (values 
      (substring rootless 0 (1+ (tree-string>get-boundary rootless)))  
      (substring rootless (1+ (tree-string>get-boundary rootless))))))

;; Common Lisp
(defun tree<=>dotstring (list-or-string)
  (if (stringp list-or-string)
      (dotstring->tree list-or-string)
      (tree->dotstring list-or-string)))

(defun tree->dotstring (tree)
  (labels ((frob (tree)
	     (if tree
		 `(,(string (car tree)) ,@(frob (cadr tree)) ,@(frob (caddr tree)))
		 '("."))))
    (string-join (frob tree))))

(defun string-join (strs &optional (delim ""))
  (if strs
      (reduce #'(lambda (retstr s) (concatenate 'string retstr delim s))
	      strs)
      ""))

(defun dotstring->tree (str)
  (if (string= "" str)
      '()
      (let ((root (subseq str 0 1)))
	(if (string= root ".")
	    '()
	    (multiple-value-bind (l r) (tree-string>get-children str)
	      `(,(read-from-string (subseq str 0 1))
		 ,(dotstring->tree l)
		 ,(dotstring->tree r)))))))

(defun tree-string>get-boundary (str)
  (let ((point 1))
    (dotimes (i (1- (length str)))
      (if (string/= "." (subseq str i (1+ i)))
	  (setq point (+ 1 point))
	  (setq point (- point 1)))
      (if (zerop point)
	  (return i)))))

(defun tree-string>get-children (str)
  (let ((rootless (subseq str 1)))
    (values 
     (subseq rootless 0 (1+ (tree-string>get-boundary rootless)))  
     (subseq rootless (1+ (tree-string>get-boundary rootless)))))) 

;; Scheme
(define (tree<=>dotstring list-or-string)
  (if (string? list-or-string)
      (dotstring->tree list-or-string)
      (tree->dotstring list-or-string)))

(define (tree->dotstring tree)
  (letrec ((frob 
	    (lambda (tree)
	      (if (null? tree)
		  '(".")
		  `(,(symbol->string (car tree)) 
		    ,@(frob (cadr tree))
		    ,@(frob (caddr tree)))))))
    (string-join (frob tree) "")))

(define (dotstring->tree str)
  (if (string=? "" str)
      '()
      (let ((root (substring str 0 1)))
	(if (string=? root ".")
	    '()
	    (receive (l r) (tree-string>get-children str)
		     `(,(string->symbol root)
		       ,(dotstring->tree l)
		       ,(dotstring->tree r)))))))

(define (tree-string>get-boundary str)
  (let/cc exit
    (let ((point 1))
      (dotimes (i (- (string-length str) 1))
	       (if (not (string=? "." (substring str i (+ 1 i))))
		   (set! point (+ 1 point))
		   (set! point (- point 1)))
	       (if (zero? point)
		   (exit i))))))

(define (tree-string>get-children str)
  (let* ((len (string-length str))
	 (rootless (substring str 1 len))
	 (boundary (+ 1 (tree-string>get-boundary rootless))))
    (values 
     (substring rootless 0 boundary)
     (substring rootless boundary (- len 1)))))