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-10-08

MAP(TI Explorer)

| 01:22 | MAP(TI Explorer) - わだばLisperになる を含むブックマーク はてなブックマーク - MAP(TI Explorer) - わだばLisperになる

今回は、テキサス・インスツルメンツ(TI)社が製造していてLispマシンのExplorerのMAPに挑戦してみます。

Explorerのソースコードはウェブで公開されています。

Error 404 (Not Found)!!1

1986~1989年位のソースコードのようなので、CLTL1の時期でしょうか。

お題:

(DEFUN MAP (result-type fcn &REST sequences)
  "Maps over successive elements of each SEQUENCE, returns a sequence of the results.
FCN is called first on the 0'th elements of all the sequences,
then on the 1st elements of all, and so on until some argument sequence is exhausted.
The values returned by FCN are put into a result sequence which is returned by MAP.
RESULT-TYPE is a sequence type; the result is of that type.
Or RESULT-TYPE can be NIL, meaning call FCN for effect only,
throw away the values, and return NIL."

  (UNLESS sequences (RETURN-FROM MAP nil))      ;;; if no sequences, then exit
  (LET ((number-of-args (LENGTH sequences))
	(result-length (COMPUTE-MIN-SEQUENCE-LENGTH sequences)))
    ;; <return-length> is the length of the shortest sequence in <sequences>
    
    (WHEN (ZEROP result-length)                 ;;; If some sequence has length 0, return fast.
      (RETURN-FROM MAP (IF result-type (MAKE-SEQUENCE result-type 0) nil)))
    (%ASSURE-PDL-ROOM (+ number-of-args 4))	;;; make sure %PUSH's don't lose
    (IF result-type
	(LET* ((result (MAKE-SEQUENCE result-type result-length)))
	  (IF (LISTP result)
	      ;; if <result> is a list, then CDR-down <result> replacing the i-th element with the
	      ;;   result of applying <fcn> to the i-th element of each sequence
	      (DO ((res result (CDR res))
		   (index 0 (1+ index)))     ;; use <index> to traverse any seuqnces which are arrays
		  ((NULL res) result)        
		(SETF (CAR res)
		      (DO ((seqlist sequences (CDR seqlist)))   ;; push the i-th element of each sequence onto the stack
			  ((NULL seqlist) (%CALL fcn number-of-args))   ;; when done, call the function.
			(%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
				   (POP (CAR seqlist)))))))
	      ;; else <result> is an array of some sort.
	      (DOTIMES (index result-length result)   
		(SETF (AREF result index)
		      (DO ((seqlist sequences (CDR seqlist)))
			  ((NULL seqlist) (%CALL fcn number-of-args))
			(%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
				   (POP (CAR seqlist)))))))))
	;;  <result-type> unspecified -- just call <fcn> for effect
	(DO ((index 0 (1+ index)))
	    ((= index result-length) nil) 
	  (DO ((seqlist sequences (CDR seqlist)))
	      ((NULL seqlist) (%CALL fcn number-of-args))
	    (%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
		       (POP (CAR seqlist)))))))))

初見時の感想:

  • 関数名を大文字にする主義らしい。
  • %assure-pdl-room等Lispマシン依存なコードにみえる。
  • なんとなく複雑な気がする。

暗記で再現:いま一歩

(DEFUN MY-MAP (result-type fcn &rest sequences)
  (UNLESS sequences (RETURN-FROM MY-MAP nil))
  (LET ((result-length (COMPUTE-MIN-LENGTH sequences))
	(seq-len (length sequences)))
    (%ASSURE-PDL-ROOM (+ 4 seq-len))
    (IF (ZEROP result-length)
	(RETURN-FROM MY-MAP (MAKE-SEQUENCE (OR result-type 'list) 0)) ;間違い
	(LET ((result (MAKE-SEQUENCE (or result-type 'list) result-length))) ;間違い
	  (IF result-type
	      (IF (LISTP result)
		  (DO ((index 0 (1+ index))
		       (res result (cdr res)))
		      ((ENDP res) result)
		    (SETF (CAR res)
			  (DO ((seqlist sequences (CDR seqlist)))
			      ((ENDP seqlist) (%CALL fcn seq-len))
			    (%PUSH (IF (ARRAYP (CAR seqlist))
				       (AREF (CAR seqlist) index)
				       (POP (CAR seqlist)))))))
		  (DOTIMES (index result-length result)
		    (SETF (AREF result index)
			  (DO ((seqlist sequences (cdr seqlist)))
			      ((ENDP seqlist) (%CALL fcn seq-len))
			    (%PUSH (IF (ARRAYP (CAR seqlist))
				       (AREF (CAR seqlist) index)
				       (POP (CAR seqlist))))))))
	      (DO ((index 0 (1+ index)))
		  ((= index result-length) nil)
		(DO ((seqlist sequences (CDR seqlist)))
		    ((ENDP seqlist) (%CALL fcn seq-len))
		  (%PUSH (IF (ARRAYP (CAR seqlist))
			     (AREF (CAR seqlist) index)
			     (POP (CAR seqlist)))))))))))

;;; lispm固有のところを想像して適当に補完するための補助関数群
(defvar *pdl* nil)

(defun %assure-pdl-room (size)
  (setq *pdl* (make-list size)))

(defun %push (item)
  (push item *pdl*))

(defun %call (fcn times)
  (let (result)
    (apply fcn (dotimes (i times result)
		 (push (pop *pdl*) result)))))

(defun compute-min-length (seq)
  (apply #'min (mapcar (lambda (x) (length x)) seq)))

反省と観察:

  • make-sequenceの辺がちゃんと再現できなかった。返り値の型がnilになった場合に、とりあえずlistを返してしまうことにしてしまった。正しくは、nilの場合の処理に分岐する。
  • seq-lenよりは、元のnumber-of-argsの方が良い名前。
  • %push、%assure-pdl-room、%call等はLispマシンの関数用?のスタック(PDL)のようで、多分これを使うとLispマシンでは普通より速いんだとは思う。

以上を踏まえて自分なりにまとめてみた:

(DEFUN MY-MAP (result-type fcn &rest sequences)
  (UNLESS sequences (RETURN-FROM my-map nil))
  (LET ((result-length (COMPUTE-MIN-LENGTH sequences))
	(number-of-args (LENGTH sequences)))
    (%ASSURE-PDL-ROOM (+ 4 number-of-args))
    (IF (ZEROP result-length)
	(RETURN-FROM MY-MAP (IF result-type (MAKE-SEQUENCE result-type 0) nil))
	(FLET ((FUNCALL-SEQ (fcn sequences index)
		 (DO ((seqlist sequences (CDR seqlist)))
		     ((ENDP seqlist) (%CALL fcn number-of-args))
		   (%PUSH (IF (ARRAYP (CAR seqlist))
			      (AREF (CAR seqlist) index)
			      (POP (CAR seqlist)))))))
	  (IF result-type
	      (LET ((result (MAKE-SEQUENCE result-type result-length)))
		(IF (LISTP result)
		    (DO ((index 0 (1+ index))
			 (res result (cdr res)))
			((ENDP res) result)
		      (SETF (CAR res) (FUNCALL-SEQ fcn sequences index)))
		    (DOTIMES (index result-length result)
		      (SETF (AREF result index) (FUNCALL-SEQ fcn sequences index)))))
	      (DOTIMES (index result-length nil)
		(FUNCALL-SEQ fcn sequences index)))))))

…けれど、あまりぱっとしない…。