utility_functions.lisp

;; ユーティリティの書き方は， 書くときのテクニックとするよりも心得とした方が上手く説明できる．
;; 心得とは...

(defun nicknames (name)
  (case name
    ('bob '(b bb))
    ('alice '(a))
    (otherwise '())))

(nicknames 'bob)
(nicknames 'alice)
(nicknames 'kim)

(defun all-nicknames (names)
  (if (null names)
      nil
      (nconc (nicknames (car names)) ;; ここではnconc = concatだと思っていい(nconcの後ろの引数が新しく生成されるリストなので)
	     (all-nicknames (cdr names)))))

(all-nicknames '(bob alice))

(defun all-nicknames2 (names) (mapcan #'nicknames names))
;; mapcan : http://www.lispworks.com/documentation/HyperSpec/Body/f_mapc_.htm
;; mapcan function &rest lists+ => concatenated-results
;; map + concat
(all-nicknames2 '(bob alice))

;; 近い順に並んでるとする
(setq *towns* '(gotanda meguro shibuya))

;; find-if: (find-if pred lst)
;; predをみたす最初の要素を返す

(defun bookshops (town)
  (case town
    ('gotanda '())
    ('meguro '(A))
    ('shibuya '(B C))
    (otherwise '())))

(let ((town (find-if #'bookshops *towns*)))
  (values town (bookshops town)))
;; bookshopsの呼び出しが１回余分(find-ifに内部で呼ばれた(bookshops town)が捨てられている）

(defun find-books (towns)
  (if (null towns)
      nil
      (let ((shops (bookshops (car towns))))
        (if shops
            (values (car towns) shops)
            (find-books (cdr towns))))))
;; bookshopsの呼び出しを１回減らせているが
;; find-ifをちょっと変形するだけのものを再実装している

;; find-booksをユーティリティー関数にする = もっと汎用のものにする
(defun find2 (fn lst)
  (if (null lst)
      nil
      (let ((val (funcall fn (car lst))))
        (if val
            (values (car lst) val)
            (find2 fn (cdr lst))))))

;; find-books with find2
(defun find-books2 (towns) (find2 #'bookshops towns))


;; (> (length x) (length y))よりちょっとだけ効率的な実装がある
;; => あとで出てくるのでそっち見たほうがいいと思う
(defun compare-length (x y)	 ;; (> (length x) (length y))
    (cond ((and (not x) (not y)) ;; xとyがnull
	   nil)
	  ((not x)
	   nil)
	  ((not y)
	   t)
	  (t
	   (compare-length (cdr x) (cdr y)))))

(compare-length '(1 2 3) '(1 2))
(compare-length '(1 2) '(1 2))
(compare-length '(1 2) '(1))

;; (mapcar fn (append x y z)) の良くない点 => find-ifと同じ
;; appendしながらfnを適用してやればいい


(proclaim '(inline last1 single append1 conc1 mklist))

(defun last1 (lst)
  (car (last lst)))

(defun single (lst)
  (and (consp lst) (not (cdr lst))))

(defun append1 (lst obj)
  (append lst (list obj)))

(defun conc1 (lst obj)
  (nconc lst (list obj)))

(defun mklist (obj)
  (if (listp obj) obj (list obj)))

;; (mapcan #'(lambda (d) ...)) lookupの結果がリストのときとリストじゃないときがあるとすればmklist内部でcheckすると簡潔になりそう


;; LargeF
;; 本の付録に簡単なバージョンは本のp396に書いてある

;; (and (consp x) (or (null y) (compare (cdr x) (cdr y))))
;; <=> 分配法則したほうがわかりやすい
;; (or (and (consp x) (null y))
;;     (and (consp x) (compare (cdr x) (cdr y))))
;; consp -> http://clhs.lisp.se/Body/f_consp.htm
(defun longer (x y)
  (labels ((compare (x y)
                    (and (consp x) ;; (consp x) == (and (pair? x) (not (null? x))) -> 要素が１以上のリストかしらべてる. (1 . 2) も通るけど大丈夫なのか
                         (or (null y)
                             (compare (cdr x) (cdr y))))))
    (if (and (listp x) (listp y))
        (compare x y)
        (> (length x) (length y)))))
(longer '(1 2) '(1))
(longer '(1 . 2) '(1))
;; (longer '(1 2) '(1 . 3)) error. 非対称な動きだな...
(longer "unko" "unchi") ;; stringでも動作する. 多分stringに対するlengthは定数時間

;; 次の関数filterの性質は...
;; filter <=> some
;; remove-if-not <=> find-if
;; filterとsomeは、fnをapplyした結果がlistになって帰ってくる。
;; remove-if-notとfind-ifは、判定にだけ使われる。

;; dolist -> http://clhs.lisp.se/Body/m_dolist.htm
;; clojureだとdoseq clojureは複数のvarを宣言できるけど...(その場合宣言したvarのすべての組み合わせについて、みたいな処理になるらしい)
;; 関数的インターフェースの話を思い出すな(副作用を使ってない関数だと思っていいやつ)
(defun filter (fn lst)
  (let ((acc nil))
    (dolist (x lst)
      (let ((val (funcall fn x)))
        (if val (push val acc)))) ;; ここでxをpushしたとしたらremove-if-notになる
    (nreverse acc)))

;; 「組み込み関数remove-if-notの返り値は...」
;; remove-if-notをfind-ifを使って定義してみるとわかってくる気がする。
;; ここらへん時間取って自分で書いてみるのも演習に良さそうだが...
;; こういうことかな
(defun remove-if-not-with-find-if
    (fn seq)
  (if (not seq)
      nil
      (let ((res (find-if fn seq)))
	(if (eq (car seq) res) ;; オブジェクトとして比較
	    (cons res (remove-if-not-with-find-if fn (cdr seq)))
	    (remove-if-not-with-find-if fn (cdr seq))))))
(remove-if-not-with-find-if #'oddp '(1 2 3 4))
(remove-if-not #'oddp '(1 2 3 4))

;; filterをsomeをつかって定義してみる.
;; remove-if-not-with-find-ifを比較してみるとなにを言ってるのかがわかる気がする
(defun filter-with-some
    (fn seq)
  (if (not seq)
      nil
      (let ((res (some fn seq)))
	(if (equal (funcall fn (car seq)) res)
	    (cons res (filter-with-some fn (cdr seq)))
	    (filter-with-some fn (cdr seq))))))

(filter #'(lambda (x) (if (numberp x) (1+ x))) '(a 1 2 b 3 c d 4))
(filter-with-some #'(lambda (x) (if (numberp x) (1+ x))) '(a 1 2 b 3 c d 4))


;; Clojureのpartition-allと同じ
;; (subseq lst i j) <-> lstのiからj-1までとって返す
(subseq '(0 1 2 3 4) 1)
;; (subseq lst 0 n) = (take n lst) in Clojure

;; nthcdr = drop in Clojure
(nthcdr 2 '(5 3 2 3 4))
(nthcdr 10 '(1 2 3 4)) ;; => NIL

(defun group (source n)
  (if (zerop n) (error "zero length"))
  (labels ((rec (source acc)
                (let ((rest (nthcdr n source)))
                  (if (consp rest)
                      (rec rest (cons (subseq source 0 n) acc))
                      (nreverse (cons source acc))))))
    (if source (rec source nil) nil)))

;; ラピッドプロトタイピング is 何
;; rapid(not rabbit) prototyping 


;; Doubly-recusive
;; こういうのを末尾再帰で書くのは難しい...
;; 遅延評価使うと楽
(defun flatten (x)
  (labels ((rec (x acc)
                (cond ((null x) acc)
                      ((atom x) (cons x acc))
                      (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil)))

;; 木の構造を変えずにtestがtrueのときは消しちゃう
(defun prune (test tree)
  (labels ((rec (tree acc)
                (cond ((null tree) (nreverse acc))
                      ((consp (car tree)) ;; when tree is nested tree
                       (rec (cdr tree)
			    ;; 木の構造は保つ
                            (cons
			     (rec (car tree) nil) ;; (部分木についておなじことをやる)
			     acc)))
                      (t ;; when tree flat list
		       ;; ここの定義だけ見ると remove-ifと同じことをやっているということに注意
		       (rec (cdr tree)
			    (if (funcall test (car tree))
                                acc
                                (cons (car tree) acc)))))))
    (rec tree nil)))

(flatten '(a (b c) ((d e) f)))
(prune #'evenp '(1 2 (3 (4 5) 6) 7 8 (9)))
;; 実験
(prune #'evenp '(1 2 (3 (4 4) 6) 7 8 (9)))
(prune #'evenp '(1 2 (3 (4 (((4)))) 6) 7 8 (9)))

;; 難しいのでこれくらいのをホワイトボードで追ってみるといいかも
(prune #'evenp '(1 (2 3) 4))


;; tree <=> list
;; prune <=> remove-if
;; copy-tree <=> copy-list
;; 部分リストに対して再帰するかどうかの違いがある
;; copy-tree(list)は先に出てくる p73



;; 4.4

;; 出てくる関数はmemberの一般化らしい。memberを書いてみる
;; NOTE: package lockがかかってるので再定義しようとするとエラーになるのでmy-member
(defun my-member (obj lst &key (test #'eql))
  (and lst
       (if (funcall test obj (car lst))
	   lst
	   (member obj (cdr lst) :test test))))
(my-member 'a '(x y a b c))
(my-member 'a '(z y z))

;; my-memberがtの代わりにlistを返すことの利点を見ていく
;; listを返すので、memberに乗っかったutilityが書きやすそうってことだとおもう

(defun find2 (fn lst)
  (if (null lst)
    nil
    (let ((val (funcall fn (car lst))))
      (if val
          (values (car lst) val)
          (find2 fn (cdr lst))))))

(defun key-arg-test (&key (a 1) (b 2))
  (list a b))
(key-arg-test :a 19)
(key-arg-test :b 10)
(key-arg-test :a 2 :b 1)
(key-arg-test :b 1 :a 2)

(defun before (x y lst &key (test #'eql))
  (and lst ;; carをとるので、nil出ないことを調べる必要がある。
       (let ((first (car lst)))
         (cond ((funcall test y first) nil)
               ((funcall test x first) lst)
               (t (before x y (cdr lst) :test test))))))
;; 結局、xが先に現れるかだけしらべればよいよね
(before 'a 'b '(a b c d))
(before 'a 'b '(x y a c z x))
(before 'a 'b '(a)) ;; これが(A)を返すのに注意。「もっと精密に調べるには、afterを使う」

;; xがyの後に現れるか？ (...  y ... x ...)なら (x ...)をかえす
(defun after (x y lst &key (test #'eql))
  (let ((rest (before y x lst :test test)))
    (and rest (member x rest :test test))))
;; 精密版のbefore
(defun exact-before (x y lst &key (test #'eql))
  (after y x lst :test test))
(exact-before 'a 'b '(a))
(exact-before 'a 'b '(a b c d)) ;; (b c d)が帰ってくるが...

;; objがlstに複数存在するか？
;; <=>
;; obj がlstに存在し、(cdr (member obj))にも存在する
(defun duplicate (obj lst &key (test #'eql))
  (member obj (cdr (member obj lst :test test))
          :test test))

;; NOTE: lstは何らかの順序で整列済みと仮定
;; http://www.lispworks.com/documentation/HyperSpec/Body/m_do_do.htm
(defun split-if (fn lst)
  (let ((acc nil))
    (do ((src lst (cdr src)))
      ((or (null src) (funcall fn (car src)))
       (values (nreverse acc) src)) ;; (終了条件 返す値)
      (push (car src) acc);; 値の更新(src <- (cdr src))前にやる処理
      )))

(split-if #'(lambda (x) (> x 4)) '(1 2 3 4 5 6 7 8 9 10))

;; fig 4.5
(defun most (fn lst)
  (if (null lst)
      (values nil nil)
      (let* ((wins (car lst))
             (max (funcall fn wins)))
        (dolist (obj (cdr lst))
          (let ((score (funcall fn obj)))
            (when (> score max)
              (setq wins obj
                    max score))))
        (values wins max))))

(most #'length '((a b) (a b c) (a) (e f g)))

(defun best (fn lst)
  (if (null lst)
      nil
      (let ((wins (car lst)))
        (dolist (obj (cdr lst))
          (if (funcall fn obj wins)
              (setq wins obj)))
        wins)))
(best #'> '(1 2 3 4 5))

(defun mostn (fn lst)
  (if (null lst)
      (values nil nil)
      (let ((result (list (car lst)))
            (max (funcall fn (car lst))))
        (dolist (obj (cdr lst))
          (let ((score (funcall fn obj)))
            (cond ((> score max)
                   (setq max score
                         result (list obj)))
                  ((= score max)
                   (push obj result)))))
        (values (nreverse result) max))))
(mostn #'length '((a b) (a b c) (a) (e f g)))

;; 4.5
;; map系

(defun mapa-b (fn a b &optional (step 1))
  (do ((i a (+ i step)) ;; (varname init how-to-update)
       (result nil)) ;; (varname init)
    ((> i b) (nreverse result))
    (push (funcall fn i) result)))

(defun map0-n (fn n)
  (mapa-b fn 0 n))
(map0-n #'1+ 5)

(defun map1-n (fn n)
  (mapa-b fn 1 n))
(map1-n #'1+ 10)

;; mapa-bの一般化
;; >とか数にしか使えないけど、抽象化されているので他のデータ型にも使える
(defun map-> (fn start test-fn succ-fn)
  (do ((i start (funcall succ-fn i))
       (result nil))
    ((funcall test-fn i) (nreverse result))
    (push (funcall fn i) result)))

(defun mapa-b (fn a b &optional (step 1))
  (map-> fn a #'(lambda (x) (> x b)) #'(lambda (x) (+ x step))))
(mapa-b #'1+ 1 5)

;; mapcan
(defun our-mapcan (fn &rest lsts)
  (apply #'nconc (apply #'mapcar fn lsts)))
;; fnはlistを新しく作って返す関数であるべき

;; そうでないときはmappendを使おう

(defun mappend (fn &rest lsts)
  (apply #'append (apply #'mapcar fn lsts)))


(mapcar #'sqrt (append (list 1 2 3 4 5) (list 6 7 8 9)))
;; 1. (append list1 list2)はlist1の長さ分consを呼んで新しくlistを生成している
;; 2. mapcarはlist1++list2の長さ分consを呼んで新しくlistを生成している。
;; 1 はすぐ捨てられるので効率が悪い

(defun mapcars (fn &rest lsts)
  (let ((result nil))
    (dolist (lst lsts)
      (dolist (obj lst)
        (push (funcall fn obj) result)))
    (nreverse result)))

(mapcars #'sqrt (list 1 2 3 4 5) (list 6 7 8 9))
;; mappendとmapcarsの使い分けがわからん.
;; mapcars

(defun rmapcar (fn &rest args)
  (if (some #'atom args) ;; argsがリストのリストでないか？
      (apply fn args)
      (apply #'mapcar
             #'(lambda (&rest args)
                 (apply #'rmapcar fn args))
             args)))
(atom 1)
(atom 2)
(atom (list 1 2 3))
(atom "aaaa")
;; atom = list以外
;; なんでこの定義でうまく行くのかよくわからなくなった
;; *slime-repl sbcl* のバッファに出力されるので注意
(rmapcar #'princ '(1 2 (3 4 (5) 6) 7 (8 9)))
;; よくわからないのでおってみる
(some #'atom '((1 2 (3 4 (5) 6) 7 (8 9))))
;; => NIL
(apply #'mapcar
       #'(lambda (&rest args) (apply #'rmapcar #'princ args))
       '((1 2 (3 4 (5) 6) 7 (8 9))))
;; 上は結局コレと同じ
(mapcar #'(lambda (&rest args) (apply #'rmapcar #'princ args))
	'(1 2 (3 4 (5) 6) 7 (8 9)))
;; 各要素、1,2,(3 5 (5) 6),7, (8 9)に対して,listに包んだ上でrmapcar princをやる
(list (apply #'rmapcar #'princ '(1))
      (apply #'rmapcar #'princ '(2))
      (apply #'rmapcar #'princ '((3 4 (5) 6)))
      (apply #'rmapcar #'princ '(7))
      (apply #'rmapcar #'princ '((8 9))))

(list (rmapcar #'princ 1)
      (rmapcar #'princ 2)
      (rmapcar #'princ '(3 4 (5) 6))
      (rmapcar #'princ 7)
      (rmapcar #'princ '(8 9)))

(rmapcar #'+ '(1 (2 (3) 4)) '(10 (20 (30) 40)))
;; おってみる
(some #'atom '((1 (2 (3) 4)) (10 (20 (30) 40))))
(apply #'mapcar
       #'(lambda (&rest args)
	   (apply #'rmapcar #'+ args))
       '((1 (2 (3) 4)) (10 (20 (30) 40))))
(mapcar #'(lambda (&rest args)
	    (apply #'rmapcar #'+ args))
	'(1 (2 (3) 4))
	'(10 (20 (30) 40)))
(list (apply #'rmapcar #'+ '(1 10))
      (apply #'rmapcar #'+ '((2 (3) 4) (20 (30) 40))))
(list (rmapcar #'+ 1 10)
      (rmapcar #'+ '(2 (3) 4) '(20 (30) 40)))
;; なんとなくわかったような？


;; series macro?
;; https://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node347.html#SECTION003400000000000000000
;; Mfnというのが何なのかわからなかった
;; http://www.nct9.ne.jp/m_hiroi/clisp/clispb11a.html
;; ここらへんを見る限り、lazy sequenceを作ってcollectすると普通のリストに変換されるみたい
;; scan-rangeは関数みたいだけど
;; error
(scan-range :from 1 :upto 10 :by 2)
(collect (#Mfn (scan-range :from 1 :upto 10 :by 2)))

;; 4.6
(defun readlist (&rest args)
  (values (read-from-string
            (concatenate 'string "("
                         (apply #'read-line args)
                         ")"))))
(values (read-from-string (concatenate 'string "("  "Call me ed" ")")))
;; *slime-repl sbcl* のバッファを開いてそっちで(readlist)すると試せる

;; *query-io* は標準入出力だと思って良さそう？
(defun prompt (&rest args)
  (apply #'format *query-io* args)
  (read *query-io*))

;; 多分~Aはobjをreplに表示されるように表示してほしいやつだと思われる。gaucheだと~aだったので
;; ~%で改行か
(defun break-loop (fn quit &rest args)
  (format *query-io* "Entering break-loop.~%")
  (loop
    (let ((in (apply #'prompt args)))
      (if (funcall quit in)
          (return) ;; loop return http://www.gigamonkeys.com/book/macros-standard-control-constructs.html
          (format *query-io* "~A~%" (funcall fn in))))))

;; 実行時ライセンスわからん
;; http://www.lispworks.com/products/lispworks.html
;; これにもruntime licenseとあるな
;; userにevalを提供することを許可するってことなんですかね
;; 実質処理系自体を配布tしているようなものだから？

;; 4.7
(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(mkstr pi " pieces of " 'pi)
;; string bufferみたいなのにprincすることもできるっぽい。すごい

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))
(intern (apply #'mkstr  (list 'ar "Madi" #\L #\L 0)))
(symb 'ar "Madi" #\L #\L 0)

;; Madiの小文字が含まれているので||で囲われている

;;「ひつようならば新しく生成して」はinternがやってくれるみたい
(symb '(a b))
(let ((s (symb '(a b))))
  (and (eq s '|(A B)|) (eq s '\(A\ B\)))) ;; ( と " "（スペース）と)に\をつけているということかな

(defun reread (&rest args)
  (values (read-from-string (apply #'mkstr args))))
(reread '(1 2 3))
(reread "(1 " ")")
(reread "(+ 1 " "2" "" ")")
;; (reread '|a:b|) package a doesn't exist
;; packageはp387だが...まだ見てない

(defun explode (sym)
  (map 'list ;; listで返す。mapは返すsequenceのtypeを指定できるらしい. 他にもstringとかを指定できる. (mapcar ...) = (map 'list ...) だったということか。;; http://clhs.lisp.se/Body/f_map.htm
       #'(lambda (c)
	   (intern (make-string 1 ;; 1文字からなる文字列を生成する
				:initial-element c)))
       (symbol-name sym)))

(explode 'bomb)
(symbol-name 'bomb) ;; symbol -> string