lispの再帰関数，関数作成の練習

;リスト→最後の要素を取除いたリストを返す．
(defun butlast$ (lst)
  (reverse (cdr (reverse lst)))
  )

;階乗計算
;1つめの方法
(defun factorial (x)
  (if (<= x 1) x
	(* x (factorial (- x 1)))
	))

;２つめの方法
(defun factorial2 (n)
  (fac-loop 1 n 1))

(defun fac-loop (i n p)
  (if (< n i) p
	(fac-loop (+ i 1) n (* p i))
	))
fac-loop

;３つめの方法
(defun factorial3 (n)
  (let ((p 1))
  (loop
	(if (<= n 0) (return p)
	  (and (setf p (* p n))
		   (decf n))
	  ))))


;fibonacci without recursion
(defun fibonacci (n)
  (* (/ 1 (sqrt 5))
	 (- (expt (/ (+ 1 (sqrt 5)) 2) (+ n 1))
		(expt (/ (- 1 (sqrt 5)) 2) (+ n 1)))
	 ))
fibonacci

;トップレベルのリストの長さを返す
;例：(length$ '(3 4 5 (6 7 8) 9)) => 5
(defun length$ (lst)
  (if (null lst) 0
	(+ 1 (length$ (cdr lst)))
	))

(defun length2$ (lst)
  (length2-loop lst 0))


(defun length2-loop (lst n)
  (if (null lst) n
	(length2-loop (cdr lst) (1+ n))
	))

;appendを自作
2このリストを合体する．
(defun append$ (lst1 lst2)
  (if (null lst1) lst2
	(cons (car lst1) (append$ (cdr lst1) lst2))
	))
append$

;改良版
(defun append2$ (lst1 lst2)
  (if (<= (length lst1) (length lst2))
	  (append$ lst1 lst2)
	(reverse (append$ (reverse lst2)
					  (reverse lst1)))
	))


;さらに改良版
(defun $append (&rest lists)
  (append-aux lists))
$append


(defun append-aux (lists)
  (if (null lists)
	  nil
	($append2 (first lists)
			  (append-aux (rest lists)))
	))
append-aux


(defun $append2 (lst1 lst2)
  (if (null lst1)
	  lst2
	(cons (first lst1)
		  ($append2 (rest lst1) lst2))
	))
$append2


;reverseを自作
;appendをつかっていいなら
(defun reverse$ (lst)
  (if (= (length lst) 1)
	  lst
	(append (reverse$ (cdr lst)) (list (car lst)))
	))
reverse$


;appendを使わないで定義する．
(defun reverse2$ (lst)
  (reverse-loop lst nil))
reverse2$


(defun reverse-loop (lst1 res)
  (if (null lst1) res
	(reverse-loop (cdr lst1) (cons (car lst1) res))
	))

;トップレベルでデータitemがlstの中にあるかどうか検索
(defun member$ (item lst)
  (if (null lst) nil
	(if (equal (car lst) item)
		lst
	  (member$ item (cdr lst))
	  )))

;リストの中でデータitemがlstの中にあるか検索
(defun member2$ (item lst)
  (if (null lst) nil
	(if (equal (car lst) item)
		t
	  (if (atom (car lst))
		  (member2$ item (cdr lst))
		(or (member2$ item (car lst))
			 (member2$ item (cdr lst)))
		))))


(setq x '(d m "doo"))
(d m "doo")
(member$ "doo" x)
("doo")
(member "doo" x) ;common lispで定義されているmember関数
nil

;assoc関数を自作
(defun assoc$ (item alist)
  (if (null alist) null
	(if (eql item (caar alist))
		(cdar alist)
	  (assoc$ item (cdr alist))
	  )))
assoc$


;equal関数の自作
(defun equal$ (x y)
  (if (atom x)
	  (eql x y)
	(if (atom y) nil
	  (and (equal$ (car x) (car y))
		   (equal$ (cdr x) (cdr y)))
	  )))

(defun sublis$ (alist tree)
  (if (atom tree)
	  (let ((x (assoc tree alist)))
		(if x
			(cdr x)
		  tree))
	(cons (sublis$ alist (car tree))
		  (sublis$ alist (cdr tree)))
	))

;リスト処理
;前にinsertする
(defun insert$ (list elem new)
  ;setfで値を書き換えること．
  (setf list (cons 'dummy list))
  (insert-2 (cdr list) elem new list)
  (cdr list))

(defun insert-2 (list elem new tmp)
  (if (null list) nil
	(if (eql (car list) elem)
		(and (setf ins (list new))
			 (rplacd ins list)
			 (rplacd tmp ins))
	  (insert-2 (cdr list) elem new list)
	  )))


;見つかったものを一つだけ消す．
(defun delete$ (list elem)
  (setf list (cons 'dummy list))
  (delete-2 (cdr list) elem list)
  (cdr list))
delete$



(defun delete-2 (list elem tmp)
  (if (null list) nil
	(if (eql (car list) elem)
		(rplacd tmp (cdr list))
	  (delete-2 (cdr list) elem list)
	  )))

;見つかったものをすべて消す．(トップレベルのみ)
(defun delete$ (list elem)
  (setf list (cons 'dummy list))
  (delete-3 (cdr list) elem list)
  (cdr list))


(defun delete-3 (list elem tmp)
  (if (null list) nil
	(and
	 (if (eql (car list) elem)
		 (rplacd tmp (cdr list))
	   t)
	 (delete-3 (cdr list) elem list))
	))

;recursive
(defun keep-first-n (num list)
  (if (<= num 0)
	  nil
	(cons (car list) (keep-first-n (- num 1) (cdr list)))
	))
keep-first-n

;tail recursive
(defun keep-first-n-cleverly (num lst)
  (keep-first-n-cleverly-aux num lst nil))
keep-first-n-cleverly


(defun keep-first-n-cleverly-aux (num lst res)
  (if (<= num 0)
	  (reverse res)
	(keep-first-n-cleverly-aux (- num 1)
		                   (cdr lst)
				   (cons (car lst) res))
	))
keep-first-n-cleverly-aux

;リストの中身をコピー
(defun copy (lst)
  (cond ((null lst) nil)
		((atom lst) lst)
		(t (cons (copy (first lst))
				 (rest lst)))
		))
copy

;かっこを外す
(defun squash (tree)
  (if (null tree)
	  nil
	(if (atom tree)
		(list tree)
	  (append (squash (car tree)) (squash (cdr tree)))
	  )))


;&optionalを使ってみた
(defun clever-count-atoms (lst &optional (res 0))
  (cond ((null lst) res)
		((atom lst) (+ res 1))
		(t (clever-count-atoms (cdr lst)
                                       (clever-count-atoms (car lst) res))
		   )))
clever-count-atoms







(defun rotate-list (lst &key direction (distance 1))
  (if (eq direction 'left)
	  (rotate-list-left lst distance)
	(rotate-list-right lst distance)
	))
rotate-list


(defun rotate-list-right (lst n)
  (if (= n 0)
	  lst
	(rotate-list-right (append (last lst) (butlast lst))
					   (- n 1))
	))
rotate-list-right




(defun rotate-list-left (lst n)
  (if (= n 0)
	  lst
	(rotate-list-left (append (rest lst)
							  (list (car lst)))
					  (- n 1))
	))
rotate-list-left