deferred-memo.el

;; http://d.hatena.ne.jp/kiwanami/20101022/1287770278

;; ■■再帰と非同期

;; ■同期的に実行

(defun fib (n)
  (if (<= n 1) n
    (+ (fib (- n 1)) 
       (fib (- n 2)))))

(defun callfunc (upper func)
  (let ((buf (get-buffer-create "*callfunc*"))
        (start-time (float-time)))
    (with-current-buffer buf
      (erase-buffer)
      (loop for i from 0 upto upper
            do (insert (format "%4d > %s  (%f msec)\n" i 
                               (funcall func i)
                               (- (float-time) start-time)))))
    (pop-to-buffer buf)))

(callfunc 30 'fib) ; 実行

  ;;  0 > 0  (0.000150 msec)
  ;;  1 > 1  (0.000192 msec)
  ;;  2 > 1  (0.000211 msec)
  ;;  3 > 2  (0.000229 msec)
  ;;   :
  ;; 28 > 317811  (0.916898 msec)
  ;; 29 > 514229  (1.468117 msec)
  ;; 30 > 832040  (2.361155 msec)

;; ■継続渡しで同期的に実行

(defun fib-cb (n cc)
  (if (<= n 1) (funcall cc n)
    (lexical-let
        ((n n) (cc cc))
      (fib-cb (- n 1)
            (lambda (x)
              (lexical-let ((x x))
                (fib-cb (- n 2)
                      (lambda (y)
                        (funcall cc (+ x y))))))))))

(defun callfuncb (upper func)
  (lexical-let
      ((func func) (start-time (float-time))
       (buf (get-buffer-create "*callfunc*")))
    (with-current-buffer buf
      (erase-buffer))
    (loop for i from 0 upto upper
          do
          (lexical-let ((i i))
            (ignore-errors 
              (funcall 
               func i 
               (lambda (x)
                 (with-current-buffer buf 
                   (insert (format "%4d > %s  (%f msec)\n" 
                                   i x (- (float-time) start-time)))))))))
    (pop-to-buffer buf)))

(callfuncb 10 'fib-cb) ; 実行 -> 7まででスタックオーバーフロー

;; 0 > 0  (0.000076 msec)
;; 1 > 1  (0.000131 msec)
;; 2 > 1  (0.000743 msec)
;; 3 > 2  (0.002135 msec)
;; 4 > 3  (0.004876 msec)
;; 5 > 5  (0.009524 msec)
;; 6 > 8  (0.015993 msec)
;; 7 > 13  (0.024714 msec)

;; ■継続渡しをそのまま非同期に実行

(defun fib-cbd (n cc)
  (if (<= n 1) (deferred:call cc n)
    (lexical-let
        ((n n) (cc cc))
      (deferred:call 'fib-cbd (- n 1)
            (lambda (x)
              (lexical-let ((x x))
                (deferred:call 'fib-cbd (- n 2)
                      (lambda (y)
                        (deferred:call cc (+ x y))))))))))

(callfuncb 14 'fib-cbd) ; 実行 -> 時間はかかるがいくらでも実行できる

  ;;  1 > 1  (0.115368 msec)
  ;;  2 > 1  (0.478819 msec)
  ;;  3 > 2  (0.569296 msec)
  ;;  4 > 3  (0.628987 msec)
  ;;  5 > 5  (0.693703 msec)
  ;;  6 > 8  (0.859047 msec)
  ;;  7 > 13  (1.057171 msec)
  ;;  8 > 21  (1.306539 msec)
  ;;  9 > 34  (1.644403 msec)
  ;; 10 > 55  (2.132786 msec)
  ;; 11 > 89  (2.750348 msec)
  ;; 12 > 144  (3.555442 msec)
  ;; 13 > 233  (4.632972 msec)
  ;; 14 > 377  (6.410187 msec)

;; ■deferredで書き直し

(defun dfib (n)
  (lexical-let* ((n n))
    (if (<= n 1) n
      (deferred:nextc
        (deferred:parallel
          (lambda () (dfib (- n 1)))
          (lambda () (dfib (- n 2))))
        (lambda (vars)
          (apply '+ vars))))))

(defun callfuncd (upper func)
  (lexical-let
      ((func func)
       (buf (get-buffer-create "*callfunc*"))
       (start-time (float-time)))
    (with-current-buffer buf
      (erase-buffer))
      (loop for i from 0 upto upper
            with prev = (deferred:next 'identity)
            do 
            (lexical-let ((i i))
              (setq prev
                    (deferred:$ prev
                      (deferred:nextc it 
                        (lambda (x) (deferred:call func i)))
                      (deferred:nextc it
                        (lambda (x)
                          (with-current-buffer buf
                            (insert
                             (format 
                              "%4d > %s  (%f msec)\n" 
                              i x  (- (float-time) start-time))))))))))
      (pop-to-buffer buf)))

(callfuncd 14 'dfib) ; 実行 / 遅いが順次答えが出る

  ;;  0 > 0  (0.166032 msec)
  ;;  1 > 1  (0.176301 msec)
  ;;  2 > 1  (0.195016 msec)
  ;;  3 > 2  (0.230990 msec)
  ;;  4 > 3  (0.282278 msec)
  ;;  5 > 5  (0.341147 msec)
  ;;  6 > 8  (0.415635 msec)
  ;;  7 > 13  (0.643584 msec)
  ;;  8 > 21  (0.933274 msec)
  ;;  9 > 34  (1.322742 msec)
  ;; 10 > 55  (2.129785 msec)
  ;; 11 > 89  (3.606189 msec)
  ;; 12 > 144  (6.592131 msec)
  ;; 13 > 233  (12.646216 msec)
  ;; 14 > 377  (26.510287 msec)



;; ■■無限リスト

;; ■遅延評価による無限リスト

(defmacro delay (v) ; 
  (let ((done (gensym)) (val (gensym)))
  `(lexical-let (,val ,done)
     (lambda () 
       (unless ,done
         (setq ,val ,v
               ,done t))
       ,val))))

;; ↑は以下と大体同じ
;; (defmacro delay (v)
;;  `(lambda () ,v))

(defun force (v)
  (funcall v))

(defun stream-car (v)
  (car v))

(defun stream-cdr (v)
  (if (null v) nil
    (force (cdr v))))

(defmacro stream-cons (a b)
  `(cons ,a (delay ,b)))

;; explicit form

(defun fib-gen (a b)
  (lexical-let ((a a) (b b))
    (stream-cons
     a
     (fib-gen b (+ a b)))))

(setq stream-fib (fib-gen 0 1))


(defun print-stream (upper stream)
  (let ((buf (get-buffer-create "*callfunc*"))
        (start-time (float-time)))
    (with-current-buffer buf
      (erase-buffer)
      (loop for i from 1 upto upper
            with a = stream
            do
            (setq a (stream-cdr a))
            (insert (format "%4d > %s   (%f msec)\n" 
                            i (stream-car a) 
                            (- (float-time) start-time)))))
    (pop-to-buffer buf)))

(print-stream 50 stream-fib)

  ;;  1 > 1   (0.000136 msec)
  ;;  2 > 1   (0.000187 msec)
  ;;  3 > 2   (0.000210 msec)
  ;;  4 > 3   (0.000230 msec)
  ;;  5 > 5   (0.000251 msec)
  ;;  6 > 8   (0.000271 msec)
  ;;    :
  ;; 49 > 7778742049   (0.001231 msec)
  ;; 50 > 12586269025   (0.001260 msec)

;; →足し算の連鎖なので速い


;; implicit form

;; (defun stream-nth (n v)
;;   (loop for i from 0 below n
;;         do (setq v (stream-cdr v))
;;         finally return (stream-car v)))

(defun stream-map (proc &rest lsts)
  (lexical-let ((proc proc)(lsts lsts))
    (stream-cons
     (apply proc (mapcar 'stream-car lsts))
     (apply 'stream-map proc (mapcar 'stream-cdr lsts)))))

(defun stream-add (&rest lsts)
  (apply 'stream-map '+ lsts))

;; (defun stream-filter (filter lst)
;;   (if (funcall filter (stream-car lst))
;;       (stream-cons
;;        (stream-car lst) (stream-filter filter (stream-cdr lst)))
;;     (stream-filter filter (stream-cdr lst))))

;; 無限リストの例
;; (setq ones (stream-cons 1 ones))
;; (setq integer (stream-cons 0 (stream-add integer ones)))
;; (print-stream 10 ones)
;; (print-stream 10 (stream-map (lambda (x) (* 2 x)) ones))
;; (print-stream 10 integer)

(setq fibs (stream-cons 0 (stream-cons 1 (stream-add fibs (stream-cdr fibs)))))

(print-stream 50 fibs) ; 実行

  ;;  1 > 1   (0.000191 msec)
  ;;  2 > 1   (0.001191 msec)
  ;;  3 > 2   (0.002192 msec)
  ;;  4 > 3   (0.003199 msec)
  ;;  5 > 5   (0.004195 msec)
  ;;  6 > 8   (0.005198 msec)
  ;;    :
  ;; 49 > 7778742049   (0.025621 msec)
  ;; 50 > 12586269025   (0.026044 msec)

;; 定義が再帰的で自分自身を参照している
;; 遅延評価にメモ化が無いとかなり遅い


;; ■継続渡し（callback）による無限リスト

;; CPS変換で遅延評価を作る

(defun streamcb-car (v)
  (car v))

(defun streamcb-cdr (v cb)
  ;; cbのコールバック関数にcdrの値が渡ってくる
  (if v (funcall (cdr v) cb)))

(defun streamcb-cons-gen (a cdr-fun)
  ;; cdr-funにはコールバックでcdrの内容を返す関数を入れる
  (cons a cdr-fun))

;; 例：
;; (streamcb-car (streamcb-cons-gen 'x (lambda (cb) (funcall cb 'y))))
;; (streamcb-cdr (streamcb-cons-gen 'x (lambda (cb) (funcall cb 'y))) 'identity)

(defmacro streamcb-cons (a b)
  ;; マクロでショートカット（bに入れるものはlexical-letしておかなければならない）
  `(streamcb-cons-gen ,a (lambda (cb) (funcall cb ,b) nil)))
;; ※lambdaの返値でnilを返しておかないと、deferredで意図しない連結が起きる

;; (streamcb-car (streamcb-cons 'x 'y))
;; (streamcb-cdr (streamcb-cons 'x 'y) 'identity)

;; explicit form

(defun fibcb-gen (a b)
  (lexical-let ((a a)(b b))
    (streamcb-cons a (fibcb-gen b (+ a b)))))

(setq stream-fibcb (fibcb-gen 0 1))

(defun print-streamcb (upper stream)
  (let ((buf (get-buffer-create "*callfunc*"))
        (start-time (float-time)))
    (with-current-buffer buf
      (erase-buffer)
      (loop for i from 1 upto upper
            with a = stream
            do
            (streamcb-cdr a (lambda (v) (setq a v)))
            (insert (format "%4d > %s   (%f msec)\n" 
                            i (streamcb-car a)
                            (- (float-time) start-time)))))
    (pop-to-buffer buf)))

(print-streamcb 50 stream-fibcb) ; 実行

  ;;  1 > 1   (0.000465 msec)
  ;;  2 > 1   (0.000810 msec)
  ;;  3 > 2   (0.001152 msec)
  ;;  4 > 3   (0.001457 msec)
  ;;  5 > 5   (0.001780 msec)
  ;;  6 > 8   (0.002117 msec)
  ;;    :
  ;; 49 > 7778742049   (0.015663 msec)
  ;; 50 > 12586269025   (0.015886 msec)

;; →速い、簡単

;; implicit form

(defun streamcb-map (proc &rest lsts)
  (lexical-let ((proc proc)(lsts lsts))
    (streamcb-cons
     (apply proc (mapcar 'streamcb-car lsts))
     (apply 'streamcb-map proc 
            (lexical-let (rests) ; とりあえず同期実行を仮定
              (mapcar 
               (lambda (lst) 
                 (streamcb-cdr 
                  lst (lambda (v) (push v rests))))
               lsts)
              (nreverse rests))))))

(defun streamcb-add (&rest lsts)
  (apply 'streamcb-map '+ lsts))

;(setq ones (streamcb-cons 1 ones))
;(setq integer (streamcb-cons 0 (streamcb-add integer ones)))
;(print-streamcb 10 ones)
;(print-streamcb 10 (streamcb-map (lambda (x) (* 2 x)) ones))
;(print-streamcb 10 integer)

(setq fibs 
      (streamcb-cons 0 
        (streamcb-cons 1
          (lexical-let (ret) ; ここでも同期実行を仮定
          (streamcb-cdr fibs 
            (lambda (second-fibs) 
              (lexical-let ((second-fibs second-fibs))
                (setq ret (streamcb-add fibs second-fibs)))))
          ret))))

;; cdrでコールバック取るので非常に見づらい
;; マクロにする

(defmacro streamcb-acdr (v &rest body)
  (let ((retsym (gensym)) (ccsym (gensym)) (restsym (gensym)))
    `(lexical-let (,retsym)
       (streamcb-cdr 
        ,v
        (lambda (,ccsym) 
          (lexical-let ((next ,ccsym))
            (setq ,retsym (progn ,@body)))))
       ,retsym)))

(setq fibs 
      (streamcb-cons 0 
        (streamcb-cons 1
          (streamcb-acdr fibs 
             (streamcb-add fibs next)))))
  
;; まあまあ見やすいかも

(print-streamcb 10 fibs) ; 実行

  ;;  1 > 1   (0.000139 msec)
  ;;  2 > 1   (0.002061 msec)
  ;;  3 > 2   (0.005589 msec)
  ;;  4 > 3   (0.012304 msec)
  ;;  5 > 5   (0.018342 msec)
  ;;  6 > 8   (0.026619 msec)
  ;;  7 > 13   (0.040379 msec)
  ;;  8 > 21   (0.063050 msec)
  ;;  9 > 34   (0.102074 msec)
  ;; 10 > 55   (0.279283 msec)

;; とりあえずCPS変換できた


;; ■非同期の連鎖による無限リスト

;; cdrのコールバックを非同期実行にしてみる

(defalias 'streamcba-car 'streamcb-car) ; 前と同じ
(defalias 'streamcba-cons 'streamcb-cons) ; 前と同じ

(defun streamcba-cdr (v cb)
  ;; cbに継続でcdrの値が渡ってくる
  ;; deferred:callで非同期実行
  (if v (deferred:call (cdr v) cb)))

;; explicit form

(defun fibcba-gen (a b)
  (lexical-let ((a a)(b b))
    (streamcba-cons a (fibcba-gen b (+ a b)))))

(setq stream-fibcba (fibcba-gen 0 1))

(defun print-streamcba (upper stream)
  (let ((buf (get-buffer-create "*callfunc*")))
    (with-current-buffer buf
      (erase-buffer)
      (print-streamcba-sub (float-time) upper 0 stream))
    (pop-to-buffer buf)))

(defun print-streamcba-sub (start-time upper counter stream)
  (lexical-let ((upper upper) 
                (counter counter) 
                (stream stream) (val (streamcba-car stream))
                (start-time start-time))
    (when (<= counter upper)
      (streamcba-cdr
       stream
       (lambda (v)
         (when v ; nilなら停止
           (insert (format "%4d > %s   (%f msec)\n" 
                           counter val (- (float-time) start-time)))
           (print-streamcba-sub start-time upper (1+ counter) v) nil))))))

  
(print-streamcba 20 stream-fibcba) ; 実行

  ;;  0 > 0   (0.004574 msec)
  ;;  1 > 1   (0.014462 msec)
  ;;  2 > 1   (0.026175 msec)
  ;;  3 > 2   (0.036261 msec)
  ;;  4 > 3   (0.040766 msec)
  ;;  5 > 5   (0.047652 msec)
  ;;  6 > 8   (0.052124 msec)
  ;;    :
  ;; 19 > 4181   (0.248151 msec)
  ;; 20 > 6765   (0.254341 msec)

;; mapなどは非同期待ち合わせが必要なので、implicit formを
;; ちゃんと書くには相当なコーディングが必要！


;; ■deferredで無限リスト

(defun dstream-car (v)
  (car v))

(defun dstream-cdr (v)
  ;; deferredでcdrの値が渡ってくる
  (if v (deferred:call (cdr v))))

(defun dstream-cons-gen (a cdr-func)
  ;; cbにはコールバックでcdrの内容を返す関数
  (cons a cdr-func))

(defun dmessage (d)
  (deferred:nextc d (lambda (x) (message ">>> %s" x))))

;; 使い方例
;; (dstream-car (dstream-cons-gen 'x (lambda () 'y)))
;; (dmessage (dstream-cdr (dstream-cons-gen 'x (lambda () 'y))))

(defmacro dstream-cons (a b)
  ;; マクロでショートカット（bに入れるものはlexical-letしておかなければならない）
  `(dstream-cons-gen ,a (lambda () ,b)))

;; (dstream-car (dstream-cons 'x 'y))
;; (dmessage (dstream-cdr (dstream-cons 'x 'y)))

;; explicit form

(defun print-dstream (upper stream)
  (let ((buf (get-buffer-create "*callfunc*")))
    (with-current-buffer buf
      (erase-buffer)
      (print-dstream-sub (float-time) upper 0 stream))
    (pop-to-buffer buf)))

(defun print-dstream-sub (start-time upper counter stream)
  (lexical-let ((upper upper) 
                (counter counter) 
                (stream stream) (val (dstream-car stream))
                (start-time start-time))
    (when (<= counter upper)
      (deferred:$
        (dstream-cdr stream)
        (deferred:nextc it
          (lambda (v)
            (when v ; nilなら停止
              (insert (format "%4d > %s   (%f msec)\n"
                              counter val (- (float-time) start-time)))
              (print-dstream-sub start-time upper (1+ counter) v) nil)))))))
  
(defun dfib-gen (a b)
  (lexical-let ((a a)(b b))
    (dstream-cons a (dfib-gen b (+ a b)))))

(setq dstream-fib (dfib-gen 0 1))

(print-dstream 20 dstream-fib)

  ;;  0 > 0   (0.012137 msec)
  ;;  1 > 1   (0.025186 msec)
  ;;  2 > 1   (0.033219 msec)
  ;;  3 > 2   (0.044255 msec)
  ;;  4 > 3   (0.052157 msec)
  ;;  5 > 5   (0.059485 msec)
  ;;  6 > 8   (0.066301 msec)
  ;;  7 > 13   (0.073657 msec)
  ;;    :
  ;; 19 > 4181   (0.155933 msec)
  ;; 20 > 6765   (0.162500 msec)

;; →元々速いので速い
;; 何となく見通しよさそう

;; implicit form

(defun dstream-map (proc &rest lsts)
  (lexical-let ((proc proc)(lsts lsts))
    (dstream-cons-gen
     (apply proc (mapcar 'dstream-car lsts))
     (lambda () 
       (deferred:$ 
         (deferred:parallel
           ;;ここでcdrを取って回る処理
           (loop for lst in lsts
                 collect
                 (lexical-let ((lst lst))
                   (lambda () (dstream-cdr lst)))))
         (deferred:nextc it ; すべてのリストのcdrを待ち合わせて次へ
           (lambda (results)
             (cond
              (results
               (apply 'dstream-map proc results))
              (t nil)))))))))

(defun dstream-add (&rest lsts)
  (apply 'dstream-map '+ lsts))

;; 非同期無限リストの例
;; (setq ones (dstream-cons 1 ones))
;; (setq integer (dstream-cons 0 (dstream-add integer ones)))
;; (print-dstream 10 ones)
;; (print-dstream 10 (dstream-map (lambda (x) (* 2 x)) ones))
;; (print-dstream 10 integer)

(setq dfibs 
      (dstream-cons 0 
        (dstream-cons 1
          (deferred:$
            (dstream-cdr dfibs)
            (deferred:nextc it
              (lambda (next)
                (dstream-add dfibs next)))))))

;; ここもcdrでコールバック取るので非常に見づらい
;; ここもマクロにしてみる

(defmacro dstream-acdr (v &rest body)
  `(deferred:nextc (dstream-cdr ,v)
     (lambda (next)
       ,@body)))

(setq dfibs
      (dstream-cons 0 
        (dstream-cons 1
          (dstream-acdr dfibs  
            (dstream-add dfibs next)))))

(print-dstream 13 dfibs) ; 実行

  ;;  0 > 0   (0.011688 msec)
  ;;  1 > 1   (0.032416 msec)
  ;;  2 > 1   (0.054518 msec)
  ;;  3 > 2   (0.093877 msec)
  ;;  4 > 3   (0.145098 msec)
  ;;  5 > 5   (0.221853 msec)
  ;;  6 > 8   (0.438380 msec)
  ;;    :
  ;; 12 > 144   (8.800115 msec)
  ;; 13 > 233   (17.125121 msec)

;; →遅いが非同期で答えが出る
;; 非同期だが、ほとんど同期のプログラムと変わらないレベルで書ける

;; ■deferredの継続でジェネレーター定義

;; コルーチン準備

(defun co-routine-replace-yield (tree)
  (let (ret)
    (loop for i in tree
          do (cond
              ((eq i 'yield) 
               (push 'funcall ret)
               (push i ret))
              ((listp i)
               (push (co-routine-replace-yield i) ret))
              (t
               (push i ret))))
    (nreverse ret)))

(defun co-routine-line (line)
  (cond
   ((functionp line)
    `(setq ,chain (deferred:nextc ,chain ,line)))
   ((eq 'while (car line))
    (let ((condition (cadr line))
          (body (cddr line)))
    `(setq ,chain 
      (deferred:nextc ,chain 
        (deferred:lambda (x) 
         (if ,condition 
             (deferred:nextc 
               (progn
                 ,@(co-routine-replace-yield body)) self)))))))
   (t
    `(setq ,chain 
           (deferred:nextc ,chain 
             (deferred:lambda (x) ,(co-routine-replace-yield line)))))))

(defmacro co-routine (argcc &rest argbody)
  (let ((chain (gensym))
        (cc (gensym))
        (waiter (gensym)))
    `(lexical-let*
         (,chain
          (,cc ,argcc)
          (,waiter (deferred:new))
          (yield (lambda (x) (funcall ,cc x) ,waiter)))
       (setq ,chain ,waiter)
       ,@(loop for i in argbody
               collect
               (co-routine-line i))
       (lambda () (deferred:callback ,waiter)))))

;; 実際に使ってみる

(defun fib-generator (cc)
  (lexical-let* ((a 0) (b 1) (n 0))
    (co-routine cc
      (yield a)
      (yield b)
      (while t
        (setq n (+ a b))
        (setq a b
              b n)
        (yield n)))))

(defun fact-generator (cc)
  (lexical-let* ((count 1) (fact 1))
    (co-routine cc
      (while t
        (setq fact (* fact count))
        (incf count)
        (yield fact)))))

(setq ret nil) ; 結果の入れもの

(setq fibgen (fib-generator (lambda (x) (push x ret))))
(progn (funcall fibgen) ret) ; 評価するたびに増えていく

(setq factgen (fact-generator (lambda (x) (push x ret))))
(progn (funcall factgen) ret)