Common Lisp

(defparameter *small* 1)
*small*

(defparameter *foo* 5)
*foo*
(defparameter *foo* 6)
*foo*

(defun guess-my-number ()
  (ash (+ *small* *big*) -1))

(guess-my-number)

(defun smaller ()
  (setf *big* (1- (guess-my-number)))
  (guess-my-number))
(defun bigger ()
  (setf *small* (1+ (guess-my-number)))
  (guess-my-number))

(bigger)

(defun start-over ()
  (defparameter *small* 1)
  (defparameter *big* 100)
  (guess-my-number))
(start-over)

(expt 53 53)

(/ 4 6)

(princ "aaaa")

(car (cdr '(pork beef chicken)))
(cadr '(pork beef chicken))

(and *file-modified* (ask-user-about-saving) (save-file))

(if (member nil '(3 4 nil 5))
    'nil-is-in-the-list
    'nil-is-not-in-the-list)

(defparameter *nodes* '((living-room (you are in the living-room.
                                      a wizard is snoring loudly on the couch.))
                        (garden (your are in a beautiful garden.
                                 there is a well in front of you.))
                        (attic (you are in the attic.
                                there is a giant welding torch in the corner.))))

(assoc 'garden *nodes*)

(defun describe-location (location nodes)
  (cadr (assoc location nodes)))
(describe-location 'living-room *nodes*)

(defparameter *edges* '((living-room (garden west door)
                                     (attic upstairs ladder))
                        (garden (living-room east door))
                        (attic (living-room downstairs ladder))))

(defun describe-path (edge)
  `(there is a ,(caddr edge) going ,(cadr edge) from here.))
(describe-path '(garden west door))

(defun describe-paths (location edges)
  (apply #'append (mapcar #'describe-path (cdr (assoc location edges)))))
(describe-paths 'living-room *edges*)

(mapcar #'sqrt '(1 2 3 4))

(mapcar #'car '((foo bar) (baz qux)))

(mapcar (function car) '((foo bar) (baz qux)))

(let ((car "Honda Civic"))
  (mapcar #'car '((foo bar) (baz qux))))

(apply #'append '((mary had) (a) (little lamb)))

(apply #'append '((THERE IS A DOOR GOING WEST FROM HERE.)
                  (THERE IS A LADDER GOING UPSTAIRS FROM HERE.)))

(defparameter *objects* '(whiskey bucket frog chain))

(defparameter *object-locations* '((whiskey living-room)
                                   (bucket living-room)
                                   (chain garden)
                                   (frog garden)))
*object-locations*

(defun objects-at (loc objs obj-locs)
  (labels ((at-loc-p (obj)
             (eq (cadr (assoc obj obj-locs)) loc)))
    (remove-if-not #'at-loc-p objs)))

(objects-at 'living-room *objects* *object-locations*)

(defun describe-objects (loc objs obj-loc)
  (labels ((describe-obj (obj)
             `(you see a ,obj on the floor.)))
    (apply #'append (mapcar #'describe-obj (objects-at loc objs obj-loc)))))

(describe-objects 'living-room *objects* *object-locations*)

(defparameter *location* 'living-room)
*location*

(defun look ()
(append (describe-location *location* *nodes*)
      (describe-paths *location* *edges*)
      (describe-objects *location* *objects* *object-locations*)))
(look)

(defun walk (direction)
  (let ((next (find direction
                    (cdr (assoc *location* *edges*))
                    :key #'cadr)))
    (if next
        (progn (setf *location* (car next))
               (look))
        '(you cannot go that way.))))

(find 'y '((5 x) (3 y) (7 z)) :key #'cadr)

(find '3 '((5 x) (3 y) (7 z)) :key #'car)

(walk 'west)

(defun pickup (object)
  (cond ((member object
                 (objects-at *location* *objects* *object-locations*))
         (push (list object 'body) *object-locations*)
         `(you are now carrying the ,object))
        (t '(you cannot get that.))))

(walk 'east)

(pickup 'whiskey)

(defun inventory ()
    (cons 'items- (objects-at 'body *objects* *object-locations*)))
(inventory)

(defparameter *foo* '(1 2 3))
(push 7 *foo*)

(setf *foo* (cons 7 '(1 2 3)))

(walk 'east)

(pickup 'whiskey)

(print "foo")

(progn (print "this")
       (print "is")
       (print "a")
       (print "test"))

(progn (prin1 "this")
       (prin1 "is")
       (prin1 "a")
       (prin1 "test"))

(defun say-hello ()
  (print "Please type your name:")
  (let ((name (read)))
    (print "Nice to meet you, ")
    (print name)))

(defun say-hello()
  (princ "Please type your name:")
  (let ((name (read-line)))
    (princ "Nice to meet you, ")
    (princ name)))

(defun game-repl ()
  (loop (print (eval (read)))))
(game-repl)

CL-USER> (look)
(YOU ARE IN THE LIVING-ROOM. A WIZARD IS SNORING LOUDLY ON THE COUCH. THERE IS
 A DOOR GOING WEST FROM HERE. THERE IS A LADDER GOING UPSTAIRS FROM HERE. YOU
 SEE A BUCKET ON THE FLOOR.)

(defun game-repl ()
  (let ((cmd (game-read)))
    (unless (eq (car cmd) 'quit)
      (game-print (game-eval cmd))
      (game-repl))))

(defun game-read ()
  (let ((cmd (read-from-string
              (concatenate 'string "(" (read-line) ")"))))
    (flet ((quote-it (x)
             (list 'quote x)))
      (cons (car cmd) (mapcar #'quote-it (cdr cmd))))))

(defparameter *allowed-commands* '(look walk pickup inventory))

(defun game-eval (sexp)
  (if (member (car sexp) *allowed-commands*)
      (eval sexp)
      '(i do not know that command.)))

(defun tweak-text (lst caps lit)
  (when lst
    (let ((item (car lst))
          (rest (cdr lst)))
      (cond ((eql item #\space) (cons item (tweak-text rest caps lit)))
            ((member item '(#\! #\? #\.)) (cons item (tweak-text rest t lit))) ;; 文章の先頭は、!,?,.,のあとに現れる
            ((eql item #\") (tweak-text rest caps (not lit)))
            (lit (cons  item (tweak-text rest nil lit)))
            (caps (cons (char-upcase item) (tweak-text rest nil lit)))
            (t (cons (char-downcase item) (tweak-text rest nil nil))))))) ;; どの条件も満たさなければ、小文字になる

(defun game-print (lst)
  (princ (coerce (tweak-text (coerce (string-trim "() "
                                                  (prin1-to-string lst))
                                     'list)
                             t
                             nil)
                 'string)
         (fresh-line)))

(game-print '(not only does this sentence have a "comma," it also mentions the "iPad."))

(mapcar (lambda (n) (/ n 2)) '(2 4 6))

(funcall (lambda (n) (/ n 2)) 2)

(cons 1 (cons 2 (cons 3 nil)))

(cons 1 (cons 2 3))

(setf *print-circle* t)

(defparameter foo (list 1 2 3))
(setf (cdddr foo) foo)

(defparameter *drink-order* '((bill . double-espresso)
                              (lisa . small-drip-coffee)
                              (john . medium-latter)))
(assoc 'lisa *drink-order*)

(push '(lisa . large-mocha-with-whipped-cream) *drink-order*)

(assoc 'lisa *drink-order*)

(defun dot-name (exp)
    (substitute-if #\_ (complement #'alphanumericp) (prin1-to-string exp)))
(dot-name 'foo!)

(substitute-if #\e #'digit-char-p "I'm a l33t hack3r!")

(substitute-if 0 #'oddp '(1 2 3 4 5 6 7 8 9))

(defparameter *max-label-length* 30)

(defun dot-label (exp)
  (if exp
      (let ((s (write-to-string exp :pretty nil)))
        (if (> (length s) *max-label-length*)
            (concatenate 'string (subseq s 0 (- *max-label-length* 3)) "...")
            s))
      ""))

(defun nodes->dot (nodes)
  (mapc (lambda (node)
          (fresh-line)
          (princ (dot-name (car node)))
          (princ "[label=\"")
          (princ (dot-label node))
          (princ "\"];"))
        nodes))

(defparameter *wizard-edges* '((living-room (garden west door)
                         (attic upstairs ladder))
                        (garden (living-room east door))
                        (attic (living-room downstairs ladder))))

(defparameter *wizard-nodes* '((living-room (you are in the living-room.
                                      a wizard is snoring loudly on the couch.))
                        (garden (your are in a beautiful garden.
                                 there is a well in front of you.))
                        (attic (you are in the attic.
                                there is a giant welding torch in the corner.))))

(nodes->dot *wizard-nodes*)

(defun edges->dot (edges)
  (mapc (lambda (node)
          (mapc (lambda (edge)
                  (fresh-line)
                  (princ (dot-name (car node)))
                  (princ "->")
                  (princ (dot-name (car edge)))
                  (princ "[label=\"")
                  (princ (dot-label (cdr edge)))
                  (princ "\"];"))
                (cdr node)))
        edges))

(cond ((>= 1 1) (print 0))
      ((= 0 0) (print 1)))

(defun my-member (x y)
  (cond ((null y) nil)
        ((eq x (car y)) t)
        (t (member x (cdr y)))))
(my-member 'a '(a b))

(my-member 'c '(a b))

(setq dict '((unum . 1) (duo . 2) (tria . 3)))
(assoc 'unum dict)

(defun my-assoc (x y)
  (cond ((null y) nil)
        ((eq x (caar y)) (car y))
        (t (assoc x (cdr y)))))
(my-assoc 'unum dict)

(defun my-rassoc (x y)
  (cond ((null y) nil)
        ((eq x (cdar y)) (car y))
        (t (rassoc x (cdr y)))))
(my-rassoc 1 dict)

(rplaca '(1 1) 2)

(rplacd '(1 1) 2)

(defun update-phone (p x y)
    (rplacd (assoc x p) y)
    p  )

(setq dict '((unum . 1) (duo . 2) (tria . 3)))
(update-phone dict 'unum 111)

  (defun my-remove (x y)
    (cond ((null y) nil)
          ((eq (car y) x) (remove x (cdr y)))
          (t (cons (car y) (remove x (cdr y))))))
(my-remove 'mo '(to mo do mo mo to mo to mo))

(defun my-delete-1 (x y)
  (setq y (cons 'dummy y))
  (my-del2 x (cdr y) y)
  (cdr y))

(defun my-del2 (x y z)
  (cond ((null y) nil)
        ((eq (car y) x) (rplacd z (cdr y)))
        (t (my-del2 x (cdr y) y))))
(my-delete-1 'mo '(mo mo mo to to to))

(defun my-delete (x y)
  (setq y (cons 'dummy y))
  (my-dela x y)
  (cdr y))

(defun my-dela (x y)
  (cond ((null (cdr y)) nil)
        ((eq (cadr y) x)
         (rplacd y (cddr y))
         (my-dela x (cdr y)))
  (t (my-dela x (cdr y)))))

(my-delete 'mo '(mo to mo to))

(nreverse '(A B C))

(defun my-nreverse (x)
  (nrev2 x nil))

(defun nrev2 (x r)
  (cond ((null x) r)
        (t (rplacd x r)
           (nrev2 (cdr x) x))))
(my-nreverse '(A B C))

(defun nrev2 (x r)
  (cond ((null x) r)
        (t (prog1 (nrev2 (cdr x) x)
             (rplacd x r)))))
(my-nreverse '(A B C))

(setq numl '(1 2 3))
(nreverse numl)

numl

(setq numl '(1 2 3))
(setq numl (nreverse numl))
numl

(setq numl '(1 2 3))
(append numl 1)
numl

(setq numl '(1 2 3))
(nconc numl 1)
numl

(defun my-nconc (x y)
  (cond ((null x) y)
        (t (rplacd (last x) y) x)))
(my-nconc '(1 2 3) 1)

(defun my-last (x)
  (cond ((null x) nil)
        (t (my-last2 x))))

(defun my-last2 (x)
  (cond ((null (cdr x)) x)
        (t (my-last2 (cdr x)))))

(my-last '(1 2 3))

(subst 'a 'b '(a b (a b (b ba) nil a)))

(defun my-subst (new old tree)
  (cond ((eq old Tree) new)
        ((atom tree) tree)
        (t (cons (subst new old (car tree))
                 (subst new old (cdr tree))))))
(my-subst 'a 'b '(a b a b))

(subst 'kk nil '(a b (b ba) nil a))

(subst 'a 'b '(a a a))

(defun my-copy (tree)
  (cond ((atom tree) tree)
        (t (cons (my-copy (car tree))
                 (my-copy (cdr tree))))))
(my-copy '(a a a))

(defun my-subst (new old tree)
  (cond ((eq old tree) new)
        ((atom tree) tree)
        (t (let ((a (my-subst new old (car tree)))
                 (d (my-subst new old (cdr tree))))
             (cond ((and (eq a (car tree))
                         (eq d (cdr tree)))
                    tree)
                   (t (cons a d)))))))
(my-subst 'a 'b '(a b))

(defun my-sublis (alist tree)
  (let ((pair (assoc tree alist)))
    (cond (pair (cdr pair))
          ((atom tree) tree)
          (t (let ((a (my-sublis alist (car tree)))
                   (d (my-sublis alist (cdr tree))))
               (cond ((and (eq a (car tree))
                           (eq d (cdr Tree)))
                      tree)
                     (t (cons a d))))))))
(my-sublis '((unum . 1) (duo . 2) (tria . 3)) '(unum duo tria unum (unum tria)))

(defun my-if (p x y)
  (cond (p x)
        (t y)))

(setq x 4)
(setq flag t)
(my-if flag (setq x (+ x 1)) (setq x (+ x 2))) ;; => 5
x ;; => 7

(defsubst my-if (p x y)
  (cond (p x)
        (t y)))

;; (setq x 4)
;; (setq flag t)
;; (my-if flag (setq x (+ x 1)) (setq x (+ x 2)))

(defun my-list (&rest x) x)
(my-list 1 1)

(defmacro my-first (x)
  (list 'car x))
(my-first (list 1 2 3))

(defun my-first (x)
  (list 'car x))
(my-first '(1 2 3)) ;; '(car (1 2 3)) と同じ

(defmacro my-cond (&rest clauses)
  (expand-cond clauses))

(defun expand-cond (clauses)
  (my-cond ((null clauses) nil)
        ((eq (caar clauses) 't)
         (cons 'progn (cdar clauses)))
        (t (list 'if
                 (caar clauses)
                 (cons 'progn (cdar clauses))
                 (expand-cond (cdr clauses))))))
(my-cond (1 '(1))
         (t '(t)))

(defmacro my-first (x)
  `(car ,x))
(my-first '(1 2 3))

(cond ((null なんとか) どうする1)
      (t どうする2))

(defmacro if-null (nan dos1 dos2)
  `(cond ((null ,nan) ,dos1)
         (t ,dos2)))
(defun my-even (x)
  (if-null (= (mod x 2) 1) t nil))
(my-even 2)

(defmacro my-pop (x)
  `(prog1 (car ,x) (setq ,x (cdr ,x))))
(defmacro my-push (y x)
  `(setq ,x (cons ,y ,x)))

(setq pop-test '(1 2 3))
(my-pop pop-test)

pop-test

(defmacro image (var list &rest forms)
  `(let (($list$ ,list)
         ($r$ nil)
         (,var nil))
    (while ($list$ (nreverse $r$))
     (setq ,var (pop $list$))
     (push (progn ,@forms) $r$))))
(image i (list 1 2 3 4) (* i i)) ;; => (1 4 9 16)になるはずだが動かない
;; i をrubyでいうブロック引数とするように定義するマクロ
;; このようにもともとの特殊形式と同じように自由に定義できるのがLispらしさ

(eq "tide" "tide")

(equal "tide" "tide")

(defun my-get (symbol property)
  (let ((plist (symbol-plist symbol)))
    (loop (until (null plist) nil)
       (until (eq (car plist) property) (cadr plist))
       (setq plist (cddr plist)))))

(putprop 'foo
         (cons (symbol-function 'foo)
               (get 'foo 'old-definition))
         'old-definition)

(apply (lambda (x y) (+ (* x x) (* y y))) (list 3 4))

(apply '+ '(1 2 3 4))

(funcall '+ 1 2 3 4)

(defun my-mapcar (fn mlist)
  (cond ((null mlist) nil)
        (t (cons (funcall fn (car mlist))
                 (mapcar fn (cdr mlist))))))
(my-mapcar #'sqrt '(1 2 3))

(defun my-maplist (fn mlist)
  (cond ((null mlist) nil)
        (t (cons (funcall fn mlist) ;; mapcar との違いはここだけ。carではなくリストに対してfnをapplyする
                 (maplist fn (cdr mlist))))))
(my-maplist #'append '(1 2 3))

(reverse
 (my-maplist (lambda (x) (apply #'+ x))
             (reverse '(10 5 6 12 3 5 9 7 0 4 2 15))))

(setq monthly-sales
      '((Jan . 10) (Feb . 5) (Mar . 6) (Apr . 12) (May . 3)(Jun . 5) (Jul . 9) (Aug . 7) (Sep . 0) (Oct . 4)(Nov . 2) (Dec . 15)))
(sort monthly-sales #'(lambda (x y) (> (cdr x) (cdr y))))

(defun eval (form)
  (cond
    ((or (null form) (numberp form) (stringp form)) form) ; nil, 数, 文字列の値はそれ自身
    ((symbolp form) (variable-value form)) ; シンボルは変数と解釈される
    ((member (car form)
             '(quote cond setq prog progn prog1 prog2 go let let* if do do* defun defmacro function ...))
     (eval-special-form form)) ; 特殊形式の処理(ここから先はセルとわかっている)
    ((and (consp (car Form)) ; ラムダ式
          (eq (caar form) 'lambda))
     (apply (car form) (evlis (cdr form))))
    ((function-symbol-p (car form)  ; 関数シンボル
                        (evlis (cdr form))))
    ((macro-symbol-p (car form)) ; マクロ呼び出し。ただしbackquoteには未対応
     (eval (apply (macro-function (car form)) (cdr form))))
    (t (error 'concat-evaluate form))))

;; 引数を順次評価してリストにする(実際はリストを作らずスタックに積む ??)
(defun evlis (args)
  (cond ((null args) nil)
        (t (cons (eval (car args)) (evlis (cdr args))))))

(defun eval-special-form (form)
  (cond ((eq (car form) 'quote) (cadr form))
        ((eq (car form 'cond) (evcon (cdr form))))
        ((eq (car form) 'setq') ...)
        ((eq (car form) 'progn) (evprogn (cdr form)))))

(defun evcon (clauses)
  (cond
    ;; もうcond節が残ってなければnilを返す
    ((null clauses) nil)
    ;; 述語が真であれば、帰結の暗黙のprognを順次評価する
    ((eval (caar clauses))
     (evprogn (cdr clauses)))
    ;; 次のcond節を調べる
    (t (evcon (cdr clauses)))))

(defun evprogn (forms)
  (cond
    ((null forms) nil)
    ((null (cdr forms)) (eval (car forms)))
    (t (eval (car forms)) (evprogn (cdr forms)))))