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

L-99 (80) (3)

| 22:10 | L-99 (80) (3) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (80) (3) - わだばLisperになる

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

P80の続き。Lisp Machine Lisp版。

使ってるLisp Machine Lispのバージョンの違いについ

て気になって色々寄り道してしまい、なかなか完成せず。

その寄り道で、Lisp関数の歴史について深追いしてみた。

なかなか面白いので、年表的にまとめてみた。

reduceとか、set-differenceなどは、後期のLisp

Machine Lispにも存在するらしい。しかし、後期は

Common Lispとかなり混ざってしまっていて、Lisp

Machine Lispが起源なのかは良く分からない。

自分が使ってるCADR System 78.48は、Lisp Machine

Manualで言うと、第4版より前のもののようなので、色々

な関数が存在していない様子。

解答
;; Lisp Machine Lisp
;; -----------------------------------------------------------------------------
;;; utility

(defun flatten (list)
  (flatten-aux list '() ))

(defun flatten-aux (list acc)
  (cond ((null list) acc)
	((listp (car list)) 
	 (flatten-aux (cdr list) (append acc (flatten-aux (car list) '()))))
	(t 
	 (flatten-aux (cdr list) (append acc (list (car list))))))))

(defun -set-difference (lst1 lst2)
  (let ((retlst '()))
    (dolist (item lst1)
      (or (memq item lst2)
	  (setq retlst (cons item retlst))))
    (nreverse retlst)))

(defun -remove-duplicates (lst)
  (do ((l lst (cdr l))
       (retlst '() ))
      ((null l) (nreverse retlst))
    (or (member (car l) retlst)
	(setq retlst (cons (car l) retlst)))))

;; -----------------------------------------------------------------------------
;; graph-term <=> edge-clause

;; 1)
(defun graph-term->edge-clause (expr)
  (cadr expr))

;; 2) DIRECTED
(deff graph-term->arc-clause//directed 'graph-term->edge-clause)

;; 3) LABELLED
(deff graph-term->arc-clause//labelled 'graph-term->edge-clause)

;; 1)
(defun edge-clause->graph-term (expr)
  `(,(sort
       (-remove-duplicates
	(let ((retlst '()))
	  (dolist (item expr)
	    (setq retlst (append item retlst)))
	  (nreverse retlst)))
      #'(lambda(a b) (string-lessp (string a) (string b))))
    ,expr))

;; 2) DIRECTED
(deff arc-clause->graph-term//directed 'arc-clause->graph-term//labelled)

;; 3) LABELLED
(defun arc-clause->graph-term//labelled (expr)
  `(,(sort 
      (-remove-duplicates
	(let ((retlst '()))
	  (dolist (item expr)
	    (setq retlst `(,@(butlast item) ,@retlst)))
	  (nreverse retlst)))
      #'(lambda(a b) (string-lessp (string a) (string b))))
    ,expr))

;; -----------------------------------------------------------------------------
;; graph-term <=> adjacency-list

;; 1)
(defun graph-term->adjacency-list (expr)
  `(,@(mapcar #'(lambda (item)
		  `(,item 
		    ,(remove nil
			     (-remove-duplicates 
			      (flatten 
			       (mapcar #'(lambda (lst)
					   (remove item
						   (if (member item lst)
						       lst
						       nil)))
				       (cadr expr)))))))
	      (car expr))))

;; 2) DIRECTED
(defun graph-term->adjacency-list//directed (expr)
  (mapcar #'(lambda (item) `(,item ,(get-direction item (cadr expr))))
          (car expr)))

(defun get-direction (from dist-lst)
  (let ((retlst '()))
    (dolist (item dist-lst)
      (and (eq from (car item))
	   (setq retlst `(,@retlst ,(cadr item)))))
    (nreverse retlst)))

;; 3) LABELLED
(defun graph-term->adjacency-list//labelled (expr)
  (mapcar #'(lambda (item)
              `(,item ,(get-direction//labelled item (cadr expr))))
          (car expr)))
                       
(defun get-direction//labelled (from dist-lst)
  (let ((retlst '()))
    (dolist (item dist-lst)
      (and (eq from (car item))
	   (setq retlst `(,@retlst (,(cadr item) ,(caddr item))))))
    (nreverse retlst)))

;; 1)
(defun adjacency-list->graph-term (expr)
  `(,(mapcar #'car expr)
    ,(sort
       (-remove-duplicates
	 (let ((retlst '()))
	   (dolist (item expr)
	     (setq retlst 
		   `(,@retlst 
		     ,@(mapcar 
			 #'(lambda (j)
			     (sort `(,(car item) ,j)
				   #'(lambda(a b)
				       (string-lessp (string a) (string b)))))
			 (cadr item)))))
	   (nreverse retlst)))
       #'(lambda(a b) (string-lessp (string (car a)) (string (car b)))))))

;; 2) DIRECTED
(defun adjacency-list->graph-term//directed (expr)
  `(,(mapcar #'car expr)
    ,(let ((retlst '()))
       (dolist (item expr)
	 (setq retlst 
	       (if item
		   `(,@retlst ,@(mapcar #'(lambda (i) `(,(car item) ,i)) 
					(cadr item))))))
       retlst)))

;; 3) LEBELLED
(defun adjacency-list->graph-term//labelled (expr)
  `(,(mapcar #'car expr)
    ,(let ((retlst '()))
       (dolist (item expr)
	 (setq retlst
	       `(,@retlst 
		 ,@(let ((ret '()))
		     (dolist (num (cadr item))
		       (setq ret (if num
				     `(,@ret (,(car item) ,@num))
				   ret)))
		     ret))))
       retlst)))

;; -----------------------------------------------------------------------------
;; graph-term <=> human-friendly

;; 1)
(defun graph-term->human-friendly (expr)
  (sort `(,@(mapcar #'(lambda (item)
			(string-append (string (car item)) "-" (string (cadr item))))
		    (cadr expr))
	    ,@(mapcar #'string
		      (-set-difference (car expr) (flatten (cadr expr)))))
	#'string-lessp))

;; 2) DIRECTED
(defun graph-term->human-friendly//directed (expr)
  (sort `(,@(mapcar #'(lambda (item) 
                        (format nil "~A>~A" (car item) (cadr item)))
		    (cadr expr))
          ,@(mapcar #'string
                    (-set-difference (car expr) (flatten (cadr expr)))))
	#'string-lessp))

;; 3) LABELLED
(defun graph-term->human-friendly//labelled (expr)
  (sort `(,@(mapcar #'(lambda (item) (format nil "~{~A>~A//~A~}" item))
		    (cadr expr))
          ,@(mapcar #'string
                    (-set-difference (car expr) (flatten (cadr expr)))))
	#'string-lessp))

;; 1)
(defun human-friendly->graph-term (expr)
  (human-friendly->graph-term-aux expr #'string-split//-))

(defun human-friendly->graph-term-aux (expr split-fn)
  (let ((item-list (mapcar #'(lambda (item)
			       (if (listp item)
				   `(,(read-from-string (car item)) 
				     ,(read-from-string (cadr item)))
				 (read-from-string item)))
			   (funcall split-fn expr))))
    `(,(-remove-duplicates (flatten item-list)) ,(rem-if-not #'listp item-list))))

(defun string-split//- (strlst)
  (mapcar #'(lambda (item)
	      (let ((pos (string-search #/- item)))
		(if pos
		    `(,(substring item 0 pos)
		      ,(substring item (1+ pos)))
		  item)))
	  strlst))

;; 2) DIRECTED
(defun human-friendly->graph-term//directed (expr)
  (human-friendly->graph-term-aux expr #'string-split//>))

(defun string-split//> (strlst)
  (mapcar #'(lambda (item)
	      (let ((pos (string-search #/> item)))
		(if pos
		    `(,(substring item 0 pos)
		      ,(substring item (1+ pos)))
		  item)))
	  strlst))

;; 3) LABELLED
(defun human-friendly->graph-term//labelled (expr)
  (let ((item-list (mapcar #'(lambda (item)
			       (if (listp item)
				   (mapcar #'read-from-string item)
				 (read-from-string item)))
                             (string-split//labelled expr))))
    `(,(-remove-duplicates 
	 (let ((retlst '()))
	   (dolist (item item-list)
	     (setq retlst `(,@retlst ,@(if (listp item) 
					   (butlast item) 
					 `(,item)))))
	   retlst))
      ,(rem-if-not #'listp item-list))))

(defun string-split//labelled (strlst)
  (mapcar #'(lambda (item)
	      (let ((>pos (string-search #/> item))
		    (//pos (string-search #// item)))
		(if >pos 
		    `(,(substring item 0 >pos)
		      ,(substring item (1+ >pos) //pos)
		      ,(substring item (1+ //pos)))
		  item)))
	  strlst))

ゲスト



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