Skip to content

Instantly share code, notes, and snippets.

@y2q-actionman

y2q-actionman/advent-2014-12-11.org

Last active January 17, 2021 07:08
Download ZIP

Revisions

  1. y2q-actionman revised this gist Dec 11, 2014. 1 changed file with 1 addition and 1 deletion.
    2 changes: 1 addition & 1 deletion advent-2014-12-11.org
    View file
    Original file line number Diff line number Diff line change
    @@ -294,7 +294,7 @@ Common Lisp には locale がなく、 ~strftime~ がないので、適当に手
    *** Allegro CL 専用
    ご存知の通り、 Common Lisp の ~format~ には =~//= ディレクティブというものがあり、 ~format~ から任意の関数を呼んで仕事をさせることが出来る。

    Allegro CL には、 この形式で C の ~strftime~ を使うための [[http://franz.com/support/documentation/9.0/doc/operators/excl/locale-format-time.htm][~locale-format-time~]] という関数があるため、単一の ~format~ で達成することが出来るのだ!
    Allegro CL には、 この形式で C の ~strftime~ を使うための [[http://franz.com/support/documentation/9.0/doc/operators/excl/locale-format-time.htm][locale-format-time]] という関数があるため、単一の ~format~ で達成することが出来るのだ!

    #+BEGIN_SRC lisp
    (defun hello-tm-acl (msg)
  2. y2q-actionman revised this gist Dec 11, 2014. 1 changed file with 2 additions and 1 deletion.
    3 changes: 2 additions & 1 deletion advent-2014-12-11.org
    View file
    Original file line number Diff line number Diff line change
    @@ -2,7 +2,8 @@
    #+DATE: <2014-12-11 Thu>
    #+AUTHOR: https://twitter.com/y2q_actionman

    この文章は、 [[http://qiita.com/advent-calendar/2014/lisp][Lisp Advent Calendar 2014]] の記事として書かれました。
    この文章は、 [[http://qiita.com/advent-calendar/2014/lisp][Lisp Advent Calendar 2014]] の 12/11 担当分の記事として書かれました。

    * 概要

    C系言語から Common Lisp に移行した時、「どうして Lisp はこんなに書き辛いんだ？」と思っていたことを記憶しています。
  3. y2q-actionman revised this gist Dec 11, 2014. 1 changed file with 1 addition and 1 deletion.
    2 changes: 1 addition & 1 deletion advent-2014-12-11.org
    View file
    Original file line number Diff line number Diff line change
    @@ -2,7 +2,7 @@
    #+DATE: <2014-12-11 Thu>
    #+AUTHOR: https://twitter.com/y2q_actionman

    この文章は、 [http://qiita.com/advent-calendar/2014/lisp][Lisp Advent Calendar 2014]] の記事として書かれました。
    この文章は、 [[http://qiita.com/advent-calendar/2014/lisp][Lisp Advent Calendar 2014]] の記事として書かれました。
    * 概要

    C系言語から Common Lisp に移行した時、「どうして Lisp はこんなに書き辛いんだ？」と思っていたことを記憶しています。
  4. y2q-actionman revised this gist Dec 11, 2014. 1 changed file with 1 addition and 0 deletions.
    1 change: 1 addition & 0 deletions advent-2014-12-11.org
    View file
    Original file line number Diff line number Diff line change
    @@ -2,6 +2,7 @@
    #+DATE: <2014-12-11 Thu>
    #+AUTHOR: https://twitter.com/y2q_actionman

    この文章は、 [http://qiita.com/advent-calendar/2014/lisp][Lisp Advent Calendar 2014]] の記事として書かれました。
    * 概要

    C系言語から Common Lisp に移行した時、「どうして Lisp はこんなに書き辛いんだ？」と思っていたことを記憶しています。
  5. y2q-actionman revised this gist Dec 11, 2014. 6 changed files with 0 additions and 652 deletions.
    0 doc.org → advent-2014-12-11.org
    View file
    File renamed without changes.
    28 changes: 0 additions & 28 deletions collatz.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,28 +0,0 @@
    ;http://ll.jus.or.jp/2006/blog/doukaku2
    (defun f (n)
    (cond ((= n 1) 1)
    ((evenp n) (f (/ n 2)))
    ((oddp n) (f (1+ (* 3 n))))))

    (defun g (n &optional (c 1))
    (cond ((= n 1) c)
    ((evenp n) (g (/ n 2) (1+ c)))
    ((oddp n) (g (1+ (* 3 n)) (1+ c)))))

    (defun h (n)
    (labels ((worker (now max-val max-pos)
    (if (< n now) max-pos
    (let ((v (g now)))
    (if (> v max-val)
    (worker (1+ now) v now)
    (worker (1+ now) max-val max-pos))))))
    (worker 1 (g 1) 1)))

    ;(defun h (n)
    ; (let* ((lst (loop for x from 1 to n collect (g x)))
    ; (max-value (reduce #'max lst)))
    ; (1+ (position max-value lst))))

    ;(h 100)
    ;(h 100000)

    69 changes: 0 additions & 69 deletions fizzbuzz.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,69 +0,0 @@
    (defun fizzbuzz1 (max)
    (labels ((printer (x)
    (cond ((= (mod x 15) 0) "FizzBuzz")
    ((= (mod x 3) 0) "Fizz")
    ((= (mod x 5) 0) "Buzz")
    (t x))))
    (dotimes (x (1+ max))
    (print (printer x)))))

    (defun fizzbuzz2 (max)
    (labels ((worker (n f b)
    (if (and (plusp f) (plusp b)) (princ n)
    (progn
    (if (= f 0) (princ "Fizz"))
    (if (= b 0) (princ "Buzz"))))
    (princ #\Newline)
    (if (< n max)
    (worker (1+ n)
    (if (<= f 0) 2 (1- f))
    (if (<= b 0) 4 (1- b))))))
    (worker 1 2 4)))

    (defun fizzbuzz3 (max)
    (labels ((worker (n f b)
    (format t "~:[~*~@[Fizz~*~]~@[Buzz~*~]~;~A~2*~]~%" (and (plusp f) (plusp b)) n (= f 0) (= b 0))
    (if (< n max)
    (worker (1+ n)
    (mod (1- f) 3)
    (mod (1- b) 5)))))
    (worker 1 2 4)))

    (defun fizzbuzz4 (max)
    (loop for n from 1 to max
    for f = 2 then (mod (1- f) 3)
    for b = 4 then (mod (1- b) 5)
    do (format t "~:[~*~@[Fizz~*~]~@[Buzz~*~]~;~A~2*~]~%" (and (plusp f) (plusp b)) n (= f 0) (= b 0))))

    (defun fizzbuzz5 (m)
    (loop for n from 1 to m
    do (format t "~:[~:[~A~;Buzz~*~]~;~:[Fuzz~;FizzBuzz~]~*~]~%" (zerop (mod n 3)) (zerop (mod n 5)) n)))

    (defun fizzbuzz6 (m)
    (loop for n from 1 to m do(format t"~:[~:[~A~;Buzz~]~;~:[Fuzz~;FizzBuzz~]~]~%"(=(mod n 3)0)(=(mod n 5)0)n)))



    (defun shinh99-1 ()
    (loop for n downfrom 99 to 1
    do (format t
    "~A~:* shinichiroes of hamaji on the wall, ~A shinichiroes of hamaji.~%~
    ~:[Take one down and pass it around, ~A~
    ~;Go to the store and buy some more, 99~] shinichiroes of hamaji on the wall.~%~%"
    n (= 1 n) (1- n))))

    (defun shinh99-2 ()
    (loop for n downfrom 99 to 1
    do (format t
    "~A ~A, ~0@*~A shinichiroes of hamaji.~%~
    ~2@*~:[Take one down and pass it around, ~A~;Go to the store and buy some more, 99~] ~1@*~A.~%~%"
    n "shinichiroes of hamaji on the wall" (= 1 n) (1- n))))

    (defun shinh99-3 ()
    (loop for n downfrom 99 to 1 do(format t(format nil"~~A~A~A~A~A, ~~@*~~A~@*~A~A~A.~~%~~:[Take one down and pass it around, ~~A~@*~A~A~A~~;Go to the store and buy some more, 99~@*~Aes~*~A~~]~A.~~%~~%"" shinichiro""~1@*~:[es~;~]~:*"" of hamaji"" on the wall")n(= 1 n)(1- n))))



    (defun count100 ()
    (dotimes(n 101)
    (princ (substitute #\space #\- (format nil "~r~%" n)))))
    37 changes: 0 additions & 37 deletions prime-print.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,37 +0,0 @@
    (defparameter *result-stack* '())

    (defun clear-stack ()
    (setf *result-stack* '()))

    (defun stack-length ()
    (length *result-stack*))

    (defun print-stack ()
    (let ((l (reverse *result-stack*)))
    (dolist (i l)
    (princ i) (princ " "))
    (fresh-line)))

    (defun push-and-print (param)
    (push param *result-stack*)
    (when (>= (stack-length) 10)
    (force-print)))

    (defun force-print ()
    (print-stack)
    (clear-stack))

    (defun prime? (n)
    (labels ((worker (n i i-max)
    (cond ((> i i-max) t)
    ((zerop (mod n i)) nil)
    (t (worker n (+ i 2) i-max)))))
    (cond ((<= n 1) nil)
    ((= n 2) t)
    ((zerop (mod n 2)) nil)
    (t (worker n 3 (isqrt n))))))

    (defun main (max)
    (do ((i 2 (1+ i)))
    ((> i max) (force-print))
    (if (prime? i) (push-and-print i))))
    436 changes: 0 additions & 436 deletions srfi-1.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,436 +0,0 @@
    (in-package :srfi-1)

    ;;;定義用Utility
    (defmacro define-rename (newname oldname)
    `(setf (symbol-function ',newname) #',oldname))


    ;;;構築子

    ;cons

    ;list

    (defun xcons (cd ca)
    (cons ca cd))

    (define-rename cons* list*)

    ;make-list

    (defun list-tabulate (n init-proc)
    (loop for i below n collect (funcall init-proc i)))

    (define-rename list-copy copy-list)

    (defun circular-list (&rest args)
    (let ((lst (copy-list args)))
    (setf (cdr (cl:last lst)) lst)))

    (defun iota (cnt &optional (start 0) (step 1))
    (loop repeat cnt
    for n from start by step
    collect n))


    ;;;述語

    (defun proper-list? (lst)
    (when (listp lst)
    (null (cl:last lst 0))))

    (defun circular-list? (lst)
    (labels ((worker (l history)
    (cond ((null l) nil)
    ((cl:find l history :test #'eq) t)
    (t (worker (cdr l) (cons l history))))))
    (when (listp lst)
    (worker lst ()))))

    (defun dotted-list? (lst)
    (when (listp lst)
    (atom (cl:last lst 0))))

    (define-rename pair? consp)

    (define-rename null? null)

    (defun null-list? (lst)
    (cond ((null lst) t)
    ((or (proper-list? lst) (circular-list? lst)) nil)
    (t (error "null-list?に変なものが渡された"))))

    (defun not-pair? (x)
    (not (consp x)))

    (defun list= (&rest lsts)
    (unless (cl:every #'proper-list? lsts)
    (error "list= に真正リスト以外が渡された"))
    (loop for l on lsts
    repeat (1- (length lsts))
    always (equal (car l) (cadr l))))


    ;;;選択子

    ;car,cdr族

    (defun list-ref (lst n)
    (nth n lst))

    ;first, ..., tenth族

    (defun car+cdr (p)
    (values (car p) (cdr p)))

    (defun take (lst n)
    (subseq lst 0 n))

    (defun drop (lst n)
    (nthcdr n lst))

    (define-rename take-right cl:last)

    (define-rename drop-right butlast)

    (defun take! (lst n)
    (setf (cdr (nthcdr (1- n) lst)) nil)
    lst)

    (define-rename drop-right! nbutlast)

    (defun split-at (lst n)
    (values (take lst n) (drop lst n)))

    (defun split-at! (lst n)
    (let ((d (drop lst n)))
    (values (take! lst n) d)))

    ;パッケージで再定義すること(shadowing)
    (defun last (lst)
    (car (cl:last lst)))

    (define-rename last-pair cl:last)


    ;;その他

    ;length

    (defun length+ (lst)
    (if (and (listp lst) (circular-list? lst))
    nil
    (length lst)))

    ;append

    (define-rename append! nconc)

    ;reverse

    (define-rename reverse! nreverse)

    (define-rename append-reverse revappend)

    (define-rename append-reverse! nreconc)

    (defun collect-cars (lsts)
    (loop for l in lsts
    when (null l) return nil
    else collect (car l)))

    (defun cdr-lists (lsts)
    (mapcar #'cdr lsts))

    (defun zip (&rest lsts)
    (labels ((worker (values lsts)
    (let ((v (collect-cars lsts)))
    (if v
    (worker (cons v values) (cdr-lists lsts))
    (nreverse values)))))
    (worker '() lsts)))

    (defun unzip1 (lsts)
    (mapcar #'first lsts))

    (defun unzip2 (lsts)
    (values (unzip1 lsts) (mapcar #'second lsts)))

    (defun unzip3 (lsts)
    (multiple-value-bind (z1 z2) (unzip2 lsts)
    (values z1 z2 (mapcar #'third lsts))))

    (defun unzip4 (lsts)
    (multiple-value-bind (z1 z2 z3) (unzip3 lsts)
    (values z1 z2 z3 (mapcar #'fourth lsts))))

    (defun unzip5 (lsts)
    (multiple-value-bind (z1 z2 z3 z4) (unzip4 lsts)
    (values z1 z2 z3 z4 (mapcar #'fifth lsts))))

    ;要shadowing
    (defun count (func &rest lsts)
    (labels ((worker (n lsts)
    (let ((cars (collect-cars lsts)))
    (if (not cars) n
    (if (apply func cars)
    (worker (1+ n) (cdr-lists lsts))
    (worker n (cdr-lists lsts)))))))
    (worker 0 lsts)))


    ;;畳み込み

    (defmacro def-fold-func (srfi-name &body maker)
    (let ((kons (gensym)) (knil (gensym)) (lsts (gensym))
    (worker (gensym)))
    `(defun ,srfi-name (,kons ,knil &rest ,lsts)
    (labels ((,worker (,kons ,knil ,lsts)
    (if (cl:every #'consp ,lsts)
    (symbol-macrolet ((rec #',worker) (kons ,kons) (knil ,knil) (current-lists ,lsts)
    (cars (mapcar #'car ,lsts)) (cdrs (cdr-lists ,lsts)))
    ,@maker)
    ,knil)))
    (,worker ,kons ,knil ,lsts)))))

    (def-fold-func fold
    (funcall rec kons (apply kons (append cars (list knil))) cdrs))

    (def-fold-func fold-right
    (apply kons (append cars (list (funcall rec kons knil cdrs)))))

    (def-fold-func pair-fold
    (funcall rec kons (apply kons (append current-lists (list knil))) cdrs))

    (def-fold-func pair-fold-right
    (apply kons (append current-lists (list (funcall rec kons knil cdrs)))))

    ;要shadowing
    (defun reduce (f ridentity lst)
    (cl:reduce f lst :initial-value ridentity))

    (defun reduce-right (f ridentity lst)
    (cl:reduce f lst :initial-value ridentity :from-end t))

    (defun unfold (p f g seed &optional tail-gen)
    (if (funcall p seed)
    (if tail-gen (funcall tail-gen seed))
    (cons (funcall f seed)
    (unfold p f g (funcall g seed)))))

    (defun unfold-right (p f g seed &optional tail)
    (labels ((worker (seed lis)
    (if (funcall p seed) lis
    (worker (funcall g seed) (cons (funcall f seed) lis)))))
    (worker seed tail)))

    ;要shadowing
    (define-rename map mapcar)

    (define-rename for-each mapc)

    (defun append-map (f &rest lsts)
    (apply #'append (apply #'mapcar f lsts)))

    (defun append-map! (f &rest lsts)
    (apply #'nconc (apply #'mapcar f lsts)))

    (define-rename map! mapcan)

    (define-rename map-in-order mapcar)

    (define-rename pair-for-each mapl)

    (defun filter-map (f &rest lsts)
    (cl:remove nil (apply #'mapcar f lsts)))


    ;;;フィルタと分割
    (define-rename filter remove-if-not)

    (defun partition (pred lst)
    (values (remove-if-not pred lst)
    (remove-if pred lst)))

    ;要shadowing
    (define-rename remove remove-if)

    (define-rename filter! delete-if-not)

    (defun partition! (pred lst)
    (values (remove-if-not pred lst)
    (delete-if pred lst)))

    (define-rename remove! delete-if)

    ;;;検索
    ;要shadowing
    (define-rename find find-if)

    (define-rename find-tail member-if)

    (defun get-longest-head (pred lst)
    (labels ((worker (lst now n-len prev p-len)
    (if (null lst) (if (> n-len p-len) (values now n-len) (values prev p-len))
    (if (funcall pred (car lst))
    (worker (cdr lst) now (1+ n-len) prev p-len)
    (if (> n-len p-len)
    (worker (cdr lst) (cdr lst) 0 now n-len)
    (worker (cdr lst) (cdr lst) 0 prev p-len))))))
    (worker lst lst 0 nil 0)))

    (defun take-while (pred lst)
    (multiple-value-call #'take (get-longest-head pred lst)))

    (defun take-while! (pred lst)
    (multiple-value-call #'take! (get-longest-head pred lst)))

    (defun drop-while (pred lst)
    (multiple-value-call #'drop (get-longest-head pred lst)))

    (defun span (pred lst)
    (multiple-value-call #'split-at (get-longest-head pred lst)))

    (defun span! (pred lst)
    (multiple-value-call #'split-at! (get-longest-head pred lst)))

    ;要shadowing
    (defun break (pred lst)
    (multiple-value-call #'split-at (get-longest-head (complement pred) lst)))

    (defun break! (pred lst)
    (multiple-value-call #'split-at! (get-longest-head (complement pred) lst)))

    (defun any (pred lst &rest lsts)
    (if (some pred lst)
    t
    (if (null lsts) nil (any pred (car lsts) (cdr lsts)))))

    ;要shadowing
    (defun every (pred lst &rest lsts)
    (if (cl:every pred lst)
    (if (null lsts) nil (every pred (car lsts) (cdr lsts)))
    nil))

    (defun list-index (pred &rest lsts)
    (labels ((worker (lsts index)
    (let ((cars (collect-cars lsts)))
    (if (not cars) nil
    (if (apply pred cars) index
    (worker (cdr-lists lsts) (1+ index)))))))
    (list-index lsts 0)))

    ;要shadowing
    (defun member (x lst &optional (pred #'equal))
    (cl:member x lst :test pred))

    (defun memq (x lst)
    (cl:member x lst :test #'eq))

    (defun memv (x lst)
    (cl:member x lst :test #'eql))


    ;;;削除

    ;要shadowing
    (defun delete (x lst &optional (= #'equal))
    (cl:remove x lst :test =))

    (defun delete! (x lst &optional (= #'equal))
    (cl:delete x lst :test =))

    (defun delete-dupicates (lst &optional (= #'equal))
    (remove-duplicates lst :test =))

    (defun delete-dupicates! (lst &optional (= #'equal))
    (cl:delete-duplicates lst :test =))


    ;;;連想リスト

    (defun assoc (key alist &optional (= #'equal))
    (cl:assoc key alist :key =))

    (defun assq (key alist)
    (cl:assoc key alist :key #'eq))

    (defun assv (key alist)
    (cl:assoc key alist :key #'eql))

    (define-rename alist-cons acons)

    (define-rename alist-copy copy-alist)

    (defun alist-delete (key alist &optional (= #'equal))
    (remove-if #'(lambda (x) (funcall = key (car x))) alist))

    (defun alist-delete! (key alist &optional (= #'equal))
    (delete-if #'(lambda (x) (funcall = key (car x))) alist))


    ;;;集合演算

    (defmacro def-lset-cmp (srfi-name &body test)
    (let ((= (gensym)) (lsts (gensym))
    (worker (gensym)) (lst (gensym)))
    `(defun ,srfi-name (,= &rest ,lsts)
    (labels ((,worker (,lst ,lsts)
    (if (null ,lsts) t
    (if (symbol-macrolet ((left ,lst) (right (car ,lsts)) (test-func ,=))
    ,@test)
    (,worker (car ,lsts) (cdr ,lsts))
    nil))))
    (if (null (cddr ,lsts)) t
    (,worker (car ,lsts) (cdr ,lsts)))))))

    (def-lset-cmp lset<=
    (subsetp left right :test test-func))

    (def-lset-cmp lset=
    (and (subsetp left right :test test-func)
    (subsetp right left :test test-func)))

    (defun lset-adjoin (= lst &rest elts)
    (if (null elts) elts
    (lset-adjoin = (adjoin (car elts) lst :test =) (cdr elts))))

    (defmacro def-lset-func (srfi-name cl-func)
    (let ((= (gensym)) (lsts (gensym))
    (worker (gensym)) (lst (gensym)))
    `(defun ,srfi-name (,= &rest ,lsts)
    (labels ((,worker (,lst ,lsts)
    (if (null ,lsts) ,lst
    (,worker (,cl-func ,lst (car ,lsts) :test ,=)
    (cdr ,lsts)))))
    (,worker (car ,lsts) (cdr ,lsts))))))

    (def-lset-func lset-union union)

    (def-lset-func lset-intersection intersection)

    (def-lset-func lset-difference set-difference)

    (def-lset-func lset-xor set-exclusive-or)

    (defun lset-diff+intersection (= &rest lsts)
    (values (apply #'lset-difference = lsts)
    (apply #'lset-intersection = lsts)))

    (def-lset-func lset-union! nunion)

    (def-lset-func lset-intersection! nintersection)

    (def-lset-func lset-difference! nset-difference)

    (def-lset-func lset-xor! nset-exclusive-or)

    (defun lset-diff+intersection! (= &rest lsts)
    (values (apply #'lset-difference = lsts)
    (apply #'lset-intersection! = lsts)))

    ;;;副作用

    (define-rename set-car! rplaca)

    (define-rename set-cdr! rplacd)
    82 changes: 0 additions & 82 deletions srfi-26.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,82 +0,0 @@
    (in-package :srfi-26)
    ;;; SRFI-26 cut

    (defun <>-num (lst)
    (count '<> lst))

    (defun <...>-num (lst)
    (count '<...> lst))

    (defun make-gensyms (n)
    (loop repeat n collect (gensym)))
    ;(defun make-gensyms (n)
    ; (map-into (make-list n) #'gensym))

    (defun <>-replace (lst syms)
    (labels ((worker (dst src syms)
    (if (null src)
    (nreverse dst)
    (if (eql '<> (car src))
    (worker (cons (car syms) dst) (cdr src) (cdr syms))
    (worker (cons (car src) dst) (cdr src) syms)))))
    (worker () lst syms)))

    (defun <>-lambda (lst)
    (let ((<>s (make-gensyms (<>-num lst)))
    (lst (if (eql (car lst) '<>) (cons 'funcall lst) lst)))
    `#'(lambda (,@<>s) ,(<>-replace lst <>s))))

    (defun <...>-lambda (lst)
    (let* ((<>s (make-gensyms (<>-num lst)))
    (<...>sym (gensym))
    (replaced (<>-replace (butlast lst) <>s))
    (fun (if (eql '<> (car lst))
    (car replaced)
    `#',(car replaced))))
    `#'(lambda (,@<>s &rest ,<...>sym)
    (apply ,fun (append (list ,@(cdr replaced)) ,<...>sym)))))

    (defmacro cut (&body body)
    (case (<...>-num body)
    (0 (<>-lambda body))
    (1 (if (eql (car (last body)) '<...>)
    (<...>-lambda body)
    (error "cutの'<...>'の位置が不正です")))
    (otherwise (error "cutに'<...>'が複数渡されました"))))

    ;(cut + 2 <> <> 3 <> 5)
    ;(cut <> 1)
    ;(cut + <> 1 <...>)
    ;(cut <> 1 2 <...>)

    (defun not-<> (x)
    (and (not (eql x '<>)) (not (eql x '<...>))))

    (defun not-<>-num (lst)
    (count-if #'not-<> lst))

    (defun split-not-<> (lst syms)
    (labels ((worker (let-forms replaced src syms)
    (if (null src) (values (nreverse let-forms) (nreverse replaced))
    (if (not-<> (car src))
    (worker (cons (list (car syms) (car src)) let-forms)
    (cons (car syms) replaced)
    (cdr src)
    (cdr syms))
    (worker let-forms
    (cons (car src) replaced)
    (cdr src)
    syms)))))
    (worker () () lst syms)))

    (defmacro cute (&body body)
    (multiple-value-bind (let-forms replaced)
    (split-not-<> (cdr body) (make-gensyms (not-<>-num (cdr body))))
    `(let (,@let-forms)
    (cut ,(car body) ,@replaced))))

    ;(cute + 2 <> <> 3 <> 5)
    ;(cute <> 1)
    ;(cute + <> 1 <...>)
    ;(cute <> 1 2 <...>)

  6. y2q-actionman revised this gist Dec 11, 2014. 1 changed file with 2 additions and 2 deletions.
    4 changes: 2 additions & 2 deletions doc.org
    View file
    Original file line number Diff line number Diff line change
    @@ -290,9 +290,9 @@ Common Lisp には locale がなく、 ~strftime~ がないので、適当に手
    #+END_SRC

    *** Allegro CL 専用
    ご存知の通り、 Common Lisp の ~format~ には =~//= ディレクティブというものがあり、~format~ から任意の関数を呼んで仕事をさせることが出来る。
    ご存知の通り、 Common Lisp の ~format~ には =~//= ディレクティブというものがあり、 ~format~ から任意の関数を呼んで仕事をさせることが出来る。

    Allegro CL には、 この形式で C の ~strftime~ を使うための ~locale-format-time~ という関数があるため、単一の ~format~ で達成することが出来るのだ~
    Allegro CL には、 この形式で C の ~strftime~ を使うための [[http://franz.com/support/documentation/9.0/doc/operators/excl/locale-format-time.htm][~locale-format-time~]] という関数があるため、単一の ~format~ で達成することが出来るのだ!

    #+BEGIN_SRC lisp
    (defun hello-tm-acl (msg)
  7. y2q-actionman revised this gist Dec 11, 2014. 1 changed file with 283 additions and 13 deletions.
    296 changes: 283 additions & 13 deletions doc.org
    View file
    Original file line number Diff line number Diff line change
    @@ -4,30 +4,300 @@

    * 概要

    C系言語から Common Lisp に移行した時、「どうして Lisp はこんなに書き辛
    いんだ？」と思っていたことを記憶しています。
    C系言語から Common Lisp に移行した時、「どうして Lisp はこんなに書き辛いんだ？」と思っていたことを記憶しています。

    こう思った一番の要因は、 Lisp の一般的なプログラミングスタイルを承知し
    ていなかったことなのですが、その時代のことをなんとなく思い出して書いて
    みようと思います。
    こう思った一番の要因は、 Lisp の一般的なプログラミングスタイルを承知していなかったことなのですが・・
    その時代のことをなんとなく思い出して書いてみようと思います。

    * なにが書き辛いと思っていたのか

    僕は、 C をやり、 C++ をやり、その後 Lisp に流れてきた人間でした。

    そんなわけで、 C系言語で身につけたスタイルが染み付いた状態でコードを書いて遊んでいたのですが・・

    *どうしてこんなにネストが深くなるんだ!?*

    と思っていたのです。

    ** 変数を使おうとするとネストが深くなる。
    ** C 系言語で身につけたスタイル
    C++ を書いてたとき、こんなスタイルで書いてました:

    #+BEGIN_SRC c
    int func (...) {
    if (/* エラーを確認して */) {
    return ERROR_1; // 無理ならさっさとやめる。
    }

    if (/* またエラーを確認して */) {
    return ERROR_2; // 無理ならさっさとやめる。
    }

    // そろそろメインの処理

    int xxx = ... ; // 確認した上で値を取る。
    int yyy = xxx + 1; // なんか上のに依存した値も取ったり

    hoge1(...); // 変数 zzz のために、いくつか前処理を呼んで・・
    hoge2(...);
    int zzz = hoge3(...); // 値を取る。

    fuga1(...); // 変数 www のために、いくつか前処理を呼んで・・
    fuga2(...);
    int www = fuga3(...); // 値を取る。

    return xxx + yyy + zzz + www; // そして何か返す。
    }
    #+END_SRC

    ** そのまま Lisp に
    このノリで Lisp を書くと・・
    #+BEGIN_SRC lisp
    (defun func (...)
    (if (some-condition-1) ; エラーを確認して
    ERROR_1 ; 無理ならさっさとやめる
    (if (some-condition-2) ; またエラーを確認して
    ERROR_2 ; 無理ならさっさとやめる
    ;; そろそろメインの処理
    (let ((xxx ...)) ; 確認した上で値を取る
    (let ((yyy (+ 1 xxx))) ; なんか上のに依存した値も取ったり
    (hoge1 ...) ; 変数 zzz のために、いくつか前処理を呼んで・・
    (hoge2 ...)
    (let ((zzz (hoge3 ...))) ; 値を取る。
    (fuga1 ...) ; 変数 www のために、いくつか前処理を呼んで・・
    (fuga2 ...)
    (let ((www (fuga3 ...))) ; 時たま値を取る。
    (+ xxx yyy zzz www)))))))) ; そして何か返す。
    #+END_SRC

    こんな、なんだか異常にネストが深いコードを書いておりました。当時は、

    - 早く制御を戻そうとするとネストが深くなるとか、おかしいだろ!?
    - 変数を使おうとするとネストが深くなるとか、おかしいだろ!?

    とかなんとか思っていた気がします。

    ** 今ならどう書くか
    *** 素直に condition を投げよう
    エラーをなぜか返り値で戻そうとしていて、それが妙な制御フローを招いています。
    素直にエラーを報告しましよう:
    #+BEGIN_SRC lisp
    (defun func (...)
    (when (some-condition-1) ; エラーを確認して
    (error ERROR_1)) ; 無理ならさっさとやめる
    (when (some-condition-2) ; またエラーを確認して
    (error ERROR_2)) ; 無理ならさっさとやめる
    ;; そろそろメインの処理
    (let ((xxx ...)) ; 確認した上で値を取る
    (let ((yyy (+ 1 xxx))) ; なんか上のに依存した値も取ったり
    (hoge1 ...) ; 変数 zzz のために、いくつか前処理を呼んで・・
    (hoge2 ...)
    (let ((zzz (hoge3 ...))) ; 値を取る。
    (fuga1 ...) ; 変数 www のために、いくつか前処理を呼んで・・
    (fuga2 ...)
    (let ((www (fuga3 ...))) ; 値を取る。
    (+ xxx yyy zzz www)))))) ; そして何か返す。
    #+END_SRC

    *** 専用の構文を使おう
    ~let~ の直下で ~let~ するという、まさにその目的のために、 ~let*~ があります。
    素直に使いましょう:
    #+BEGIN_SRC lisp
    (defun func (...)
    (when (some-condition-1) ; エラーを確認して
    (error ERROR_1)) ; 無理ならさっさとやめる
    (when (some-condition-2) ; またエラーを確認して
    (error ERROR_2)) ; 無理ならさっさとやめる
    ;; そろそろメインの処理
    (let* ((xxx ...) ; 確認した上で値を取る
    (yyy (+ 1 xxx))) ; なんか上のに依存した値も取ったり
    (hoge1 ...) ; 変数 zzz のために、いくつか前処理を呼んで・・
    (hoge2 ...)
    (let ((zzz (hoge3 ...))) ; 値を取る。
    (fuga1 ...) ; 変数 www のために、いくつか前処理を呼んで・・
    (fuga2 ...)
    (let ((www (fuga3 ...))) ; 値を取る。
    (+ xxx yyy zzz www))))) ; そして何か返す。
    #+END_SRC

    *** だらしない制御フローをなんとかしよう
    上記のように書いていると、変数 ~www~ を得るためには、 ~hoge1~, ~hoge2~, ~hoge3~ の呼び出しが必須であるように見えます。
    しかし実際には、直接に必要なのは変数 ~zzz~ であり、それさえ手に入れば依存関係はない、なんてことがあります。
    それなら、こう書けるでしょう。
    #+BEGIN_SRC lisp
    (defun func (...)
    (when (some-condition-1) ; エラーを確認して
    (error ERROR_1)) ; 無理ならさっさとやめる
    (when (some-condition-2) ; またエラーを確認して
    (error ERROR_2)) ; 無理ならさっさとやめる
    ;; そろそろメインの処理
    (let* ((xxx ...) ; 確認した上で値を取る
    (yyy (+ 1 xxx)) ; なんか上のに依存した値も取ったり
    (zzz (progn (hoge1 ...) ; 変数 zzz のために、いくつか前処理を呼んで・・
    (hoge2 ...)
    (hoge3 ...))); 値を取る。
    (www (progn (fuga1 ...) ; 変数 www のために、いくつか前処理を呼んで・・
    (fuga2 ...)
    (fuga3 ...)))) ; 値を取る。
    (+ xxx yyy zzz www))) ; そして何か返す。
    #+END_SRC

    ** あんまりまとまってないまとめ
    C系言語の場合、変数の宣言だけではネストが深くならないということもあり、適当にだらだら変数を宣言しながら書いていっても、そんなに見苦しくならない気がします。
    一方 Lisp の場合、そうしているとどんどんネストが深くなり、ゲロ以下のにおいがするコードになってしまいがちでした。

    今から思うと、そういうのは適切な書き方を知らなかったからなんだなあ、と思います。
    つまり・・
    - ~let*~ や、もしくは ~with-~ 系マクロなど、変数を導入するマクロに一通り目を通しておく。
    - Lisp 流のエラー処理 (condition) を知っておく。
    - ~loop~ や ~format~ なども、伏魔殿っぽいなあといって忌避しない。
    くらいかなあ、と思います。

    * 実例
    全編を疑似コードで通すのもアレなので、ディスクの隅に眠っていた吐き気を催すコードをとりだして、あげつらってみようと思います。

    ** FizzBuzz やりたかったの？
    *** コード
    #+BEGIN_SRC lisp
    (defun fizzbuzz1 (max)
    (labels ((printer (x)
    (cond ((= (mod x 15) 0) "FizzBuzz")
    ((= (mod x 3) 0) "Fizz")
    ((= (mod x 5) 0) "Buzz")
    (t x))))
    (dotimes (x (1+ max))
    (print (printer x)))))
    #+END_SRC

    *** 修正案
    - この規模で ~labels~ いるか？ ~flet~ でいいし、そもそも分けるような規模じゃないだろ。
    - ~printer~ って名前なのに print してないっていう詐欺名称。頭わいてる。

    #+BEGIN_SRC lisp
    (defun fizzbuzz1 (max)
    (dotimes (x (1+ max))
    (print
    (cond ((= (mod x 15) 0) "FizzBuzz")
    ((= (mod x 3) 0) "Fizz")
    ((= (mod x 5) 0) "Buzz")
    (t x)))))
    #+END_SRC

    ** ダサい素数判定
    *** コード
    #+BEGIN_SRC lisp
    (defun prime? (n)
    (labels ((worker (n i i-max)
    (cond ((> i i-max) t)
    ((zerop (mod n i)) nil)
    (t (worker n (+ i 2) i-max)))))
    (cond ((<= n 1) nil)
    ((= n 2) t)
    ((zerop (mod n 2)) nil)
    (t (worker n 3 (isqrt n))))))
    #+END_SRC

    *** 修正案1
    なんで再帰で書きたかったの？ ってのは置いておくとして

    - ~labels~ のスコープは、もっと狭くていいでしょう？
    先頭に置くと、 ~cond~ のどこからでも参照されるのかと思うが、実は一箇所だけ。
    - どうして変化させるつもりがない値を引数で渡してるのだろう

    #+BEGIN_SRC lisp
    (defun prime? (n)
    (cond ((<= n 1) nil)
    ((= n 2) t)
    ((zerop (mod n 2)) nil)
    (t
    (let ((i-max (isqrt n)))
    (labels ((worker (i)
    (cond ((> i i-max) t)
    ((zerop (mod n i)) nil)
    (t (worker (+ i 2))))))
    (worker 3))))))
    #+END_SRC

    *** 修正案2
    もう ~loop~ でいいんじゃないかな・・ ~let~ も ~with~ で内包できるし。

    #+BEGIN_SRC lisp
    (defun prime? (n)
    (cond ((<= n 1) nil)
    ((= n 2) t)
    ((zerop (mod n 2)) nil)
    (t
    (loop with i-max = (isqrt n)
    for i from 3 to i-max by 2
    never (zerop (mod n i))
    finally (return t)))))

    #+END_SRC

    ** 日付つき Hello World

    *** C のコード
    これはまあこれでいいんですが
    #+BEGIN_SRC c
    #include <stdio.h>
    #include <string.h>
    #include <stdlib.h>
    #include <time.h>

    int hello_tm(const char *msg) {
    time_t now = time(NULL);

    struct tm now_tm;
    if(!localtime_r(&now, &now_tm))
    return EXIT_FAILURE;

    char now_str[32] = {0};
    size_t now_str_len = strftime(now_str, sizeof(now_str),
    "%F", &now_tm);
    if(now_str_len == 0)
    return EXIT_FAILURE;

    printf("%*s: %s\n", (int)now_str_len, now_str, msg);
    return EXIT_SUCCESS;
    }

    int main() {
    return hello_tm("Hello, World!");
    }
    #+END_SRC

    *** そのまんま Lisp コード版
    Common Lisp には locale がなく、 ~strftime~ がないので、適当に手書きしてます。

    #+BEGIN_SRC lisp
    (defun hello-tm (msg)
    (let ((now (get-universal-time)))
    (multiple-value-bind (_ __ ___ d m y)
    (decode-universal-time now)
    (declare (ignore _ __ ___))
    (let ((str (with-output-to-string (stream)
    (format stream "~D-~D-~D" y m d))))
    (format t "~A: ~A~%" str msg)))))
    #+END_SRC

    *** 修正案
    - ~get-universal-time~ と ~decode-universal-time~ の組み合わせは、 ~get-decoded-time~ でよい。
    - いちいち ~format~ を二回呼ばなくても、一回の呼び出しにまとめられる。

    ** 早く制御を戻そうとするとネストが深くなる。
    #+BEGIN_SRC lisp
    (defun hello-tm-2 (msg)
    (multiple-value-bind (_ __ ___ d m y)
    (get-decoded-time)
    (declare (ignore _ __ ___))
    (format t "~D-~D-~D: ~A~%" y m d msg)))
    #+END_SRC

    * どうしてこうなった!
    *** Allegro CL 専用
    ご存知の通り、 Common Lisp の ~format~ には =~//= ディレクティブというものがあり、~format~ から任意の関数を呼んで仕事をさせることが出来る。

    * まとまらないまとめ
    Allegro CL には、 この形式で C の ~strftime~ を使うための ~locale-format-time~ という関数があるため、単一の ~format~ で達成することが出来るのだ~

    * 余談
    locale-format-time
    #+BEGIN_SRC lisp
    (defun hello-tm-acl (msg)
    (format t "~,V:@/locale-format-time/: ~A~%"
    "%F"
    (get-universal-time)
    msg))
    #+END_SRC
  8. y2q-actionman revised this gist Dec 10, 2014. 6 changed files with 685 additions and 0 deletions.
    28 changes: 28 additions & 0 deletions collatz.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,28 @@
    ;http://ll.jus.or.jp/2006/blog/doukaku2
    (defun f (n)
    (cond ((= n 1) 1)
    ((evenp n) (f (/ n 2)))
    ((oddp n) (f (1+ (* 3 n))))))

    (defun g (n &optional (c 1))
    (cond ((= n 1) c)
    ((evenp n) (g (/ n 2) (1+ c)))
    ((oddp n) (g (1+ (* 3 n)) (1+ c)))))

    (defun h (n)
    (labels ((worker (now max-val max-pos)
    (if (< n now) max-pos
    (let ((v (g now)))
    (if (> v max-val)
    (worker (1+ now) v now)
    (worker (1+ now) max-val max-pos))))))
    (worker 1 (g 1) 1)))

    ;(defun h (n)
    ; (let* ((lst (loop for x from 1 to n collect (g x)))
    ; (max-value (reduce #'max lst)))
    ; (1+ (position max-value lst))))

    ;(h 100)
    ;(h 100000)

    33 changes: 33 additions & 0 deletions doc.org
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,33 @@
    #+TITLE: C系言語から Common Lisp に移行した時に戸惑ったこと
    #+DATE: <2014-12-11 Thu>
    #+AUTHOR: https://twitter.com/y2q_actionman

    * 概要

    C系言語から Common Lisp に移行した時、「どうして Lisp はこんなに書き辛
    いんだ？」と思っていたことを記憶しています。

    こう思った一番の要因は、 Lisp の一般的なプログラミングスタイルを承知し
    ていなかったことなのですが、その時代のことをなんとなく思い出して書いて
    みようと思います。

    * なにが書き辛いと思っていたのか

    僕は、 C をやり、 C++ をやり、その後 Lisp に流れてきた人間でした。

    そんなわけで、 C系言語で身につけたスタイルが染み付いた状態でコードを書いて遊んでいたのですが・・

    *どうしてこんなにネストが深くなるんだ!?*

    と思っていたのです。

    ** 変数を使おうとするとネストが深くなる。

    ** 早く制御を戻そうとするとネストが深くなる。

    * どうしてこうなった!

    * まとまらないまとめ

    * 余談
    locale-format-time
    69 changes: 69 additions & 0 deletions fizzbuzz.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,69 @@
    (defun fizzbuzz1 (max)
    (labels ((printer (x)
    (cond ((= (mod x 15) 0) "FizzBuzz")
    ((= (mod x 3) 0) "Fizz")
    ((= (mod x 5) 0) "Buzz")
    (t x))))
    (dotimes (x (1+ max))
    (print (printer x)))))

    (defun fizzbuzz2 (max)
    (labels ((worker (n f b)
    (if (and (plusp f) (plusp b)) (princ n)
    (progn
    (if (= f 0) (princ "Fizz"))
    (if (= b 0) (princ "Buzz"))))
    (princ #\Newline)
    (if (< n max)
    (worker (1+ n)
    (if (<= f 0) 2 (1- f))
    (if (<= b 0) 4 (1- b))))))
    (worker 1 2 4)))

    (defun fizzbuzz3 (max)
    (labels ((worker (n f b)
    (format t "~:[~*~@[Fizz~*~]~@[Buzz~*~]~;~A~2*~]~%" (and (plusp f) (plusp b)) n (= f 0) (= b 0))
    (if (< n max)
    (worker (1+ n)
    (mod (1- f) 3)
    (mod (1- b) 5)))))
    (worker 1 2 4)))

    (defun fizzbuzz4 (max)
    (loop for n from 1 to max
    for f = 2 then (mod (1- f) 3)
    for b = 4 then (mod (1- b) 5)
    do (format t "~:[~*~@[Fizz~*~]~@[Buzz~*~]~;~A~2*~]~%" (and (plusp f) (plusp b)) n (= f 0) (= b 0))))

    (defun fizzbuzz5 (m)
    (loop for n from 1 to m
    do (format t "~:[~:[~A~;Buzz~*~]~;~:[Fuzz~;FizzBuzz~]~*~]~%" (zerop (mod n 3)) (zerop (mod n 5)) n)))

    (defun fizzbuzz6 (m)
    (loop for n from 1 to m do(format t"~:[~:[~A~;Buzz~]~;~:[Fuzz~;FizzBuzz~]~]~%"(=(mod n 3)0)(=(mod n 5)0)n)))



    (defun shinh99-1 ()
    (loop for n downfrom 99 to 1
    do (format t
    "~A~:* shinichiroes of hamaji on the wall, ~A shinichiroes of hamaji.~%~
    ~:[Take one down and pass it around, ~A~
    ~;Go to the store and buy some more, 99~] shinichiroes of hamaji on the wall.~%~%"
    n (= 1 n) (1- n))))

    (defun shinh99-2 ()
    (loop for n downfrom 99 to 1
    do (format t
    "~A ~A, ~0@*~A shinichiroes of hamaji.~%~
    ~2@*~:[Take one down and pass it around, ~A~;Go to the store and buy some more, 99~] ~1@*~A.~%~%"
    n "shinichiroes of hamaji on the wall" (= 1 n) (1- n))))

    (defun shinh99-3 ()
    (loop for n downfrom 99 to 1 do(format t(format nil"~~A~A~A~A~A, ~~@*~~A~@*~A~A~A.~~%~~:[Take one down and pass it around, ~~A~@*~A~A~A~~;Go to the store and buy some more, 99~@*~Aes~*~A~~]~A.~~%~~%"" shinichiro""~1@*~:[es~;~]~:*"" of hamaji"" on the wall")n(= 1 n)(1- n))))



    (defun count100 ()
    (dotimes(n 101)
    (princ (substitute #\space #\- (format nil "~r~%" n)))))
    37 changes: 37 additions & 0 deletions prime-print.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,37 @@
    (defparameter *result-stack* '())

    (defun clear-stack ()
    (setf *result-stack* '()))

    (defun stack-length ()
    (length *result-stack*))

    (defun print-stack ()
    (let ((l (reverse *result-stack*)))
    (dolist (i l)
    (princ i) (princ " "))
    (fresh-line)))

    (defun push-and-print (param)
    (push param *result-stack*)
    (when (>= (stack-length) 10)
    (force-print)))

    (defun force-print ()
    (print-stack)
    (clear-stack))

    (defun prime? (n)
    (labels ((worker (n i i-max)
    (cond ((> i i-max) t)
    ((zerop (mod n i)) nil)
    (t (worker n (+ i 2) i-max)))))
    (cond ((<= n 1) nil)
    ((= n 2) t)
    ((zerop (mod n 2)) nil)
    (t (worker n 3 (isqrt n))))))

    (defun main (max)
    (do ((i 2 (1+ i)))
    ((> i max) (force-print))
    (if (prime? i) (push-and-print i))))
    436 changes: 436 additions & 0 deletions srfi-1.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,436 @@
    (in-package :srfi-1)

    ;;;定義用Utility
    (defmacro define-rename (newname oldname)
    `(setf (symbol-function ',newname) #',oldname))


    ;;;構築子

    ;cons

    ;list

    (defun xcons (cd ca)
    (cons ca cd))

    (define-rename cons* list*)

    ;make-list

    (defun list-tabulate (n init-proc)
    (loop for i below n collect (funcall init-proc i)))

    (define-rename list-copy copy-list)

    (defun circular-list (&rest args)
    (let ((lst (copy-list args)))
    (setf (cdr (cl:last lst)) lst)))

    (defun iota (cnt &optional (start 0) (step 1))
    (loop repeat cnt
    for n from start by step
    collect n))


    ;;;述語

    (defun proper-list? (lst)
    (when (listp lst)
    (null (cl:last lst 0))))

    (defun circular-list? (lst)
    (labels ((worker (l history)
    (cond ((null l) nil)
    ((cl:find l history :test #'eq) t)
    (t (worker (cdr l) (cons l history))))))
    (when (listp lst)
    (worker lst ()))))

    (defun dotted-list? (lst)
    (when (listp lst)
    (atom (cl:last lst 0))))

    (define-rename pair? consp)

    (define-rename null? null)

    (defun null-list? (lst)
    (cond ((null lst) t)
    ((or (proper-list? lst) (circular-list? lst)) nil)
    (t (error "null-list?に変なものが渡された"))))

    (defun not-pair? (x)
    (not (consp x)))

    (defun list= (&rest lsts)
    (unless (cl:every #'proper-list? lsts)
    (error "list= に真正リスト以外が渡された"))
    (loop for l on lsts
    repeat (1- (length lsts))
    always (equal (car l) (cadr l))))


    ;;;選択子

    ;car,cdr族

    (defun list-ref (lst n)
    (nth n lst))

    ;first, ..., tenth族

    (defun car+cdr (p)
    (values (car p) (cdr p)))

    (defun take (lst n)
    (subseq lst 0 n))

    (defun drop (lst n)
    (nthcdr n lst))

    (define-rename take-right cl:last)

    (define-rename drop-right butlast)

    (defun take! (lst n)
    (setf (cdr (nthcdr (1- n) lst)) nil)
    lst)

    (define-rename drop-right! nbutlast)

    (defun split-at (lst n)
    (values (take lst n) (drop lst n)))

    (defun split-at! (lst n)
    (let ((d (drop lst n)))
    (values (take! lst n) d)))

    ;パッケージで再定義すること(shadowing)
    (defun last (lst)
    (car (cl:last lst)))

    (define-rename last-pair cl:last)


    ;;その他

    ;length

    (defun length+ (lst)
    (if (and (listp lst) (circular-list? lst))
    nil
    (length lst)))

    ;append

    (define-rename append! nconc)

    ;reverse

    (define-rename reverse! nreverse)

    (define-rename append-reverse revappend)

    (define-rename append-reverse! nreconc)

    (defun collect-cars (lsts)
    (loop for l in lsts
    when (null l) return nil
    else collect (car l)))

    (defun cdr-lists (lsts)
    (mapcar #'cdr lsts))

    (defun zip (&rest lsts)
    (labels ((worker (values lsts)
    (let ((v (collect-cars lsts)))
    (if v
    (worker (cons v values) (cdr-lists lsts))
    (nreverse values)))))
    (worker '() lsts)))

    (defun unzip1 (lsts)
    (mapcar #'first lsts))

    (defun unzip2 (lsts)
    (values (unzip1 lsts) (mapcar #'second lsts)))

    (defun unzip3 (lsts)
    (multiple-value-bind (z1 z2) (unzip2 lsts)
    (values z1 z2 (mapcar #'third lsts))))

    (defun unzip4 (lsts)
    (multiple-value-bind (z1 z2 z3) (unzip3 lsts)
    (values z1 z2 z3 (mapcar #'fourth lsts))))

    (defun unzip5 (lsts)
    (multiple-value-bind (z1 z2 z3 z4) (unzip4 lsts)
    (values z1 z2 z3 z4 (mapcar #'fifth lsts))))

    ;要shadowing
    (defun count (func &rest lsts)
    (labels ((worker (n lsts)
    (let ((cars (collect-cars lsts)))
    (if (not cars) n
    (if (apply func cars)
    (worker (1+ n) (cdr-lists lsts))
    (worker n (cdr-lists lsts)))))))
    (worker 0 lsts)))


    ;;畳み込み

    (defmacro def-fold-func (srfi-name &body maker)
    (let ((kons (gensym)) (knil (gensym)) (lsts (gensym))
    (worker (gensym)))
    `(defun ,srfi-name (,kons ,knil &rest ,lsts)
    (labels ((,worker (,kons ,knil ,lsts)
    (if (cl:every #'consp ,lsts)
    (symbol-macrolet ((rec #',worker) (kons ,kons) (knil ,knil) (current-lists ,lsts)
    (cars (mapcar #'car ,lsts)) (cdrs (cdr-lists ,lsts)))
    ,@maker)
    ,knil)))
    (,worker ,kons ,knil ,lsts)))))

    (def-fold-func fold
    (funcall rec kons (apply kons (append cars (list knil))) cdrs))

    (def-fold-func fold-right
    (apply kons (append cars (list (funcall rec kons knil cdrs)))))

    (def-fold-func pair-fold
    (funcall rec kons (apply kons (append current-lists (list knil))) cdrs))

    (def-fold-func pair-fold-right
    (apply kons (append current-lists (list (funcall rec kons knil cdrs)))))

    ;要shadowing
    (defun reduce (f ridentity lst)
    (cl:reduce f lst :initial-value ridentity))

    (defun reduce-right (f ridentity lst)
    (cl:reduce f lst :initial-value ridentity :from-end t))

    (defun unfold (p f g seed &optional tail-gen)
    (if (funcall p seed)
    (if tail-gen (funcall tail-gen seed))
    (cons (funcall f seed)
    (unfold p f g (funcall g seed)))))

    (defun unfold-right (p f g seed &optional tail)
    (labels ((worker (seed lis)
    (if (funcall p seed) lis
    (worker (funcall g seed) (cons (funcall f seed) lis)))))
    (worker seed tail)))

    ;要shadowing
    (define-rename map mapcar)

    (define-rename for-each mapc)

    (defun append-map (f &rest lsts)
    (apply #'append (apply #'mapcar f lsts)))

    (defun append-map! (f &rest lsts)
    (apply #'nconc (apply #'mapcar f lsts)))

    (define-rename map! mapcan)

    (define-rename map-in-order mapcar)

    (define-rename pair-for-each mapl)

    (defun filter-map (f &rest lsts)
    (cl:remove nil (apply #'mapcar f lsts)))


    ;;;フィルタと分割
    (define-rename filter remove-if-not)

    (defun partition (pred lst)
    (values (remove-if-not pred lst)
    (remove-if pred lst)))

    ;要shadowing
    (define-rename remove remove-if)

    (define-rename filter! delete-if-not)

    (defun partition! (pred lst)
    (values (remove-if-not pred lst)
    (delete-if pred lst)))

    (define-rename remove! delete-if)

    ;;;検索
    ;要shadowing
    (define-rename find find-if)

    (define-rename find-tail member-if)

    (defun get-longest-head (pred lst)
    (labels ((worker (lst now n-len prev p-len)
    (if (null lst) (if (> n-len p-len) (values now n-len) (values prev p-len))
    (if (funcall pred (car lst))
    (worker (cdr lst) now (1+ n-len) prev p-len)
    (if (> n-len p-len)
    (worker (cdr lst) (cdr lst) 0 now n-len)
    (worker (cdr lst) (cdr lst) 0 prev p-len))))))
    (worker lst lst 0 nil 0)))

    (defun take-while (pred lst)
    (multiple-value-call #'take (get-longest-head pred lst)))

    (defun take-while! (pred lst)
    (multiple-value-call #'take! (get-longest-head pred lst)))

    (defun drop-while (pred lst)
    (multiple-value-call #'drop (get-longest-head pred lst)))

    (defun span (pred lst)
    (multiple-value-call #'split-at (get-longest-head pred lst)))

    (defun span! (pred lst)
    (multiple-value-call #'split-at! (get-longest-head pred lst)))

    ;要shadowing
    (defun break (pred lst)
    (multiple-value-call #'split-at (get-longest-head (complement pred) lst)))

    (defun break! (pred lst)
    (multiple-value-call #'split-at! (get-longest-head (complement pred) lst)))

    (defun any (pred lst &rest lsts)
    (if (some pred lst)
    t
    (if (null lsts) nil (any pred (car lsts) (cdr lsts)))))

    ;要shadowing
    (defun every (pred lst &rest lsts)
    (if (cl:every pred lst)
    (if (null lsts) nil (every pred (car lsts) (cdr lsts)))
    nil))

    (defun list-index (pred &rest lsts)
    (labels ((worker (lsts index)
    (let ((cars (collect-cars lsts)))
    (if (not cars) nil
    (if (apply pred cars) index
    (worker (cdr-lists lsts) (1+ index)))))))
    (list-index lsts 0)))

    ;要shadowing
    (defun member (x lst &optional (pred #'equal))
    (cl:member x lst :test pred))

    (defun memq (x lst)
    (cl:member x lst :test #'eq))

    (defun memv (x lst)
    (cl:member x lst :test #'eql))


    ;;;削除

    ;要shadowing
    (defun delete (x lst &optional (= #'equal))
    (cl:remove x lst :test =))

    (defun delete! (x lst &optional (= #'equal))
    (cl:delete x lst :test =))

    (defun delete-dupicates (lst &optional (= #'equal))
    (remove-duplicates lst :test =))

    (defun delete-dupicates! (lst &optional (= #'equal))
    (cl:delete-duplicates lst :test =))


    ;;;連想リスト

    (defun assoc (key alist &optional (= #'equal))
    (cl:assoc key alist :key =))

    (defun assq (key alist)
    (cl:assoc key alist :key #'eq))

    (defun assv (key alist)
    (cl:assoc key alist :key #'eql))

    (define-rename alist-cons acons)

    (define-rename alist-copy copy-alist)

    (defun alist-delete (key alist &optional (= #'equal))
    (remove-if #'(lambda (x) (funcall = key (car x))) alist))

    (defun alist-delete! (key alist &optional (= #'equal))
    (delete-if #'(lambda (x) (funcall = key (car x))) alist))


    ;;;集合演算

    (defmacro def-lset-cmp (srfi-name &body test)
    (let ((= (gensym)) (lsts (gensym))
    (worker (gensym)) (lst (gensym)))
    `(defun ,srfi-name (,= &rest ,lsts)
    (labels ((,worker (,lst ,lsts)
    (if (null ,lsts) t
    (if (symbol-macrolet ((left ,lst) (right (car ,lsts)) (test-func ,=))
    ,@test)
    (,worker (car ,lsts) (cdr ,lsts))
    nil))))
    (if (null (cddr ,lsts)) t
    (,worker (car ,lsts) (cdr ,lsts)))))))

    (def-lset-cmp lset<=
    (subsetp left right :test test-func))

    (def-lset-cmp lset=
    (and (subsetp left right :test test-func)
    (subsetp right left :test test-func)))

    (defun lset-adjoin (= lst &rest elts)
    (if (null elts) elts
    (lset-adjoin = (adjoin (car elts) lst :test =) (cdr elts))))

    (defmacro def-lset-func (srfi-name cl-func)
    (let ((= (gensym)) (lsts (gensym))
    (worker (gensym)) (lst (gensym)))
    `(defun ,srfi-name (,= &rest ,lsts)
    (labels ((,worker (,lst ,lsts)
    (if (null ,lsts) ,lst
    (,worker (,cl-func ,lst (car ,lsts) :test ,=)
    (cdr ,lsts)))))
    (,worker (car ,lsts) (cdr ,lsts))))))

    (def-lset-func lset-union union)

    (def-lset-func lset-intersection intersection)

    (def-lset-func lset-difference set-difference)

    (def-lset-func lset-xor set-exclusive-or)

    (defun lset-diff+intersection (= &rest lsts)
    (values (apply #'lset-difference = lsts)
    (apply #'lset-intersection = lsts)))

    (def-lset-func lset-union! nunion)

    (def-lset-func lset-intersection! nintersection)

    (def-lset-func lset-difference! nset-difference)

    (def-lset-func lset-xor! nset-exclusive-or)

    (defun lset-diff+intersection! (= &rest lsts)
    (values (apply #'lset-difference = lsts)
    (apply #'lset-intersection! = lsts)))

    ;;;副作用

    (define-rename set-car! rplaca)

    (define-rename set-cdr! rplacd)
    82 changes: 82 additions & 0 deletions srfi-26.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,82 @@
    (in-package :srfi-26)
    ;;; SRFI-26 cut

    (defun <>-num (lst)
    (count '<> lst))

    (defun <...>-num (lst)
    (count '<...> lst))

    (defun make-gensyms (n)
    (loop repeat n collect (gensym)))
    ;(defun make-gensyms (n)
    ; (map-into (make-list n) #'gensym))

    (defun <>-replace (lst syms)
    (labels ((worker (dst src syms)
    (if (null src)
    (nreverse dst)
    (if (eql '<> (car src))
    (worker (cons (car syms) dst) (cdr src) (cdr syms))
    (worker (cons (car src) dst) (cdr src) syms)))))
    (worker () lst syms)))

    (defun <>-lambda (lst)
    (let ((<>s (make-gensyms (<>-num lst)))
    (lst (if (eql (car lst) '<>) (cons 'funcall lst) lst)))
    `#'(lambda (,@<>s) ,(<>-replace lst <>s))))

    (defun <...>-lambda (lst)
    (let* ((<>s (make-gensyms (<>-num lst)))
    (<...>sym (gensym))
    (replaced (<>-replace (butlast lst) <>s))
    (fun (if (eql '<> (car lst))
    (car replaced)
    `#',(car replaced))))
    `#'(lambda (,@<>s &rest ,<...>sym)
    (apply ,fun (append (list ,@(cdr replaced)) ,<...>sym)))))

    (defmacro cut (&body body)
    (case (<...>-num body)
    (0 (<>-lambda body))
    (1 (if (eql (car (last body)) '<...>)
    (<...>-lambda body)
    (error "cutの'<...>'の位置が不正です")))
    (otherwise (error "cutに'<...>'が複数渡されました"))))

    ;(cut + 2 <> <> 3 <> 5)
    ;(cut <> 1)
    ;(cut + <> 1 <...>)
    ;(cut <> 1 2 <...>)

    (defun not-<> (x)
    (and (not (eql x '<>)) (not (eql x '<...>))))

    (defun not-<>-num (lst)
    (count-if #'not-<> lst))

    (defun split-not-<> (lst syms)
    (labels ((worker (let-forms replaced src syms)
    (if (null src) (values (nreverse let-forms) (nreverse replaced))
    (if (not-<> (car src))
    (worker (cons (list (car syms) (car src)) let-forms)
    (cons (car syms) replaced)
    (cdr src)
    (cdr syms))
    (worker let-forms
    (cons (car src) replaced)
    (cdr src)
    syms)))))
    (worker () () lst syms)))

    (defmacro cute (&body body)
    (multiple-value-bind (let-forms replaced)
    (split-not-<> (cdr body) (make-gensyms (not-<>-num (cdr body))))
    `(let (,@let-forms)
    (cut ,(car body) ,@replaced))))

    ;(cute + 2 <> <> 3 <> 5)
    ;(cute <> 1)
    ;(cute + <> 1 <...>)
    ;(cute <> 1 2 <...>)

  9. y2q-actionman revised this gist Dec 10, 2014. 2 changed files with 25 additions and 1 deletion.
    23 changes: 23 additions & 0 deletions strftime.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,23 @@
    (in-package :cl-user)

    (defun hello-tm (msg)
    (let ((now (get-universal-time)))
    (multiple-value-bind (_ __ ___ d m y)
    (decode-universal-time now)
    (declare (ignore _ __ ___))
    (let ((str (with-output-to-string (stream)
    (format stream "~D-~D-~D" y m d))))
    (format t "~A: ~A~%" str msg)))))

    (defun hello-tm-2 (msg)
    (multiple-value-bind (_ __ ___ d m y)
    (get-decoded-time)
    (declare (ignore _ __ ___))
    (format t "~D-~D-~D: ~A~%" y m d msg)))

    (defun hello-tm-acl (msg)
    (format t "~,V:@/locale-format-time/: ~A~%"
    "%F"
    (get-universal-time)
    msg))

    3 changes: 2 additions & 1 deletion strftime_test.c
    View file
    Original file line number Diff line number Diff line change
    @@ -11,7 +11,8 @@ int hello_tm(const char *msg) {
    return EXIT_FAILURE;

    char now_str[32] = {0};
    size_t now_str_len = strftime(now_str, sizeof(now_str), "%F", &now_tm);
    size_t now_str_len = strftime(now_str, sizeof(now_str),
    "%F", &now_tm);
    if(now_str_len == 0)
    return EXIT_FAILURE;

  10. y2q-actionman created this gist Dec 5, 2014.
    24 changes: 24 additions & 0 deletions strftime_test.c
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,24 @@
    #include <stdio.h>
    #include <string.h>
    #include <stdlib.h>
    #include <time.h>

    int hello_tm(const char *msg) {
    time_t now = time(NULL);

    struct tm now_tm;
    if(!localtime_r(&now, &now_tm))
    return EXIT_FAILURE;

    char now_str[32] = {0};
    size_t now_str_len = strftime(now_str, sizeof(now_str), "%F", &now_tm);
    if(now_str_len == 0)
    return EXIT_FAILURE;

    printf("%*s: %s\n", (int)now_str_len, now_str, msg);
    return EXIT_SUCCESS;
    }

    int main() {
    return hello_tm("Hello, World!");
    }