#:g1: サンプルコードによるLOOPマクロ入門 (番外編 L-99)

Posted 2008-07-06 06:25:00 GMT

機能を順に紹介して行くのも良いのですが、実際に手を動かしてみるのも良いだろうということで、意味なくL-99のP25まで、無理にLOOPを使って解いてみました。

「できるだけLOOPマクロ内で完結させる」ということをテーマに書いてみました。
自分はLOOPマクロは苦手でしたが、それでも200行位LOOPばっかり書けば、いい加減馴れて来るようです…。
;; P01
(defun last-pair (list)
  (loop :for x :on list :when (atom (cdr x)) :return x))

(last-pair '(1 2 3 4)) ;=> (4)

(last-pair '(1 2 3 . 4)) ;=> (3 . 4)

;; P02 (defun last-2-pair (list) (loop :for x :on list :when (atom (cddr x)) :return x))

(last-2-pair '(1 2 3 4)) ;=> (3 4)

(last-2-pair '(1 2 3 . 4)) ;=> (2 3 . 4)

;; P03 (defun element-at (list position) (loop :for p := 1 :then (1+ p) :for x :in list :when (= position p) :return x))

(element-at '(a b c d e) 13) ;=> NIL

(element-at '(a b c d e) 3) ;=> C

;; P04 (defun len (list) (loop :for x :in list :count 'T))

(len '(1 2 3 4)) ;=> 4

;; P05 (defun rev (list) (loop :for a := (copy-list list) :then (prog1 (cdr a) (rplacd a b)) :and b := () :then a :when (null a) :return b))

(rev '(1 2 3 4)) ;=> (4 3 2 1)

;; P06 (defun palindrome-p (list) (loop :for nom :in list :and rev :in (reverse list) :always (equal nom rev)))

(palindrome-p '(1 2 3 2 1)) ;=> T

;; P07 (defun flatten (list) (loop :for x :in list :if (listp x) :append (flatten x) :else :collect x))

(flatten '(1 2 3 (4 5 (6 (7 (8 (9 (((10((((((())))))))))))))))) ;=> (1 2 3 4 5 6 7 8 9 10)

;; P08 (defun compress (list) (loop :for x :in list :and prev := (gensym) :then x :unless (equal prev x) :collect x))

(compress '(a a a a b c c a a d e e e e)) ;=> (A B C A D E)

;; P09 (defun pack (list) (loop :for x :in (nconc (copy-list list) (list (gensym))) :and prev := (gensym) :then x :and tem := () :then (cons x tem) :unless (or (equal prev x) (null tem)) :collect tem :and :do (setq tem () ) :end))

(pack '(a a a a b c c a a d e e e e e)) ;=> ((A A A A) (B) (C C) (A A) (D) (E E E E E))

;; P10 (defun encode (list) (loop :for x :in (pack list) :collect `(,(length x) ,(car x))))

(encode '(a a a a b c c a a d e e e e)) ;=> ((4 A) (1 B) (2 C) (2 A) (1 D) (4 E))

;; P11 (defun encode-modified (list) (loop :for x :in (pack list) :when (= 1 (length x)) :collect (car x) :else :collect `(,(length x) ,(car x))))

(encode-modified '(a a a a b c c a a d e e e e)) ;=> ((4 A) B (2 C) (2 A) D (4 E))

;; P12 (defun decode (list) (loop :for x :in list :when (atom x) :collect x :else :append (make-list (first x) :initial-element (second x))))

(decode '((4 A) B (2 C) (2 A) D (4 E))) ;=> (A A A A B C C A A D E E E E)

;; P13 (defun encode-direct (list) (loop :for x :in (nconc (copy-list list) (list (gensym))) :and prev := (gensym) :then x :and tem := () :then (cons x tem) :and cnt := 0 :then (1+ cnt) :unless (or (equal prev x) (null tem)) :when (= 1 cnt) :collect prev :else :collect (list cnt prev) :end :and :do (setq tem () cnt 0) :end))

(encode-direct '(a a a a b c c a a d e e e e)) ;=> ((4 A) B (2 C) (2 A) D (4 E))

;; P14 (*) Duplicate the elements of a list. (defun dupli (list) (loop :for x :in list :nconc (list x x)))

(dupli '(a b c c d)) ;=> (A A B B C C C C D D)

;; P15 (defun repli (list times) (loop :for x :in list :nconc (loop :repeat times :collect x)))

(repli '(a b c) 3) ;=> (A A A B B B C C C)

;; P16 (defun drop (list n) (loop :for x :in list :and pos :from 1 :unless (zerop (mod pos n)) :collect x))

(drop '(a b c d e f g h i k) 3) ;=> (A B D E G H K)

;; P17 (defun split (list n) (loop :for x :on list :for pos :from 1 :when (> pos n) :do (return-from split (list tem x)) :else :collect (car x) :into tem) :end :finally (return-from split (list list () )))

(split '(a b c d e f g h i k) 3) ;=> ((A B C) (D E F G H I K))

;; P18 (defun slice (list start end) (loop :for x :in list :for pos :from 1 :when (<= start pos end) :collect x :into res :finally (return res)))

(slice '(a b c d e f g h i k) 3 7) ;=> (C D E F G)

;; P19 (defun rotate (list n) (loop :with n := (mod n (length list)) :for x :on list :for pos :from 1 :when (> pos n) :do (return-from rotate (append x tem)) :else :collect (car x) :into tem) :end :finally (return-from rotate list))

(rotate '(a b c d e f g h) 3) ;=> (D E F G H A B C)

;; P20 (defun remove-at (list n) (loop :for x :in list :and pos :from 1 :unless (= pos n) :collect x))

(remove-at '(a b c d) 2) ;=> (A C D)

;; P21 (defun insert-at (item list n) (loop :for x :in list :and pos :from 1 :when (= pos n) :append (list item x) :else :collect x))

(insert-at 'alfa '(a b c d) 2) ;=> (A ALFA B C D)

;; P22 (defun range (start end) (loop :for i :from start :to end :collect i))

(range 4 9) ;=> (4 5 6 7 8 9)

;; P23 (defun remove-at (list n) "取り除く要素/残りの多値を返すバージョン" (loop :for x :in list :and pos :from 1 :unless (= pos n) :collect x :into res :else :collect x :into item :finally (return-from remove-at (values res item))))

(remove-at '(1 2 3 4) 4) ;=> (1 2 3),(4)

(defun rnd-select (list n) (flet ((choose (lst) (multiple-value-list (remove-at lst (1+ (random (length lst))))))) (loop :for i :from 1 :to (min n (length list)) :for (tem x) := (choose list) :then (choose tem) :append x)))

(rnd-select '(a b c d e f g h) 7) ;=> (H E G F D B C)

;; P24 (defun lotto-select (n range) (rnd-select (range 1 range) n))

(lotto-select 6 49) ;=> (14 37 4 8 9 46)

;; P25 (defun rnd-permu (list) (rnd-select list (length list)))

(rnd-permu '(a b c d e f)) ;=> (A C B F D E)


comments powered by Disqus