Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2008-07-12

サンプルコードによるSERIES入門 (番外編)

| 16:22 | サンプルコードによるSERIES入門 (番外編) - わだばLisperになる を含むブックマーク はてなブックマーク - サンプルコードによるSERIES入門 (番外編) - わだばLisperになる

LOOP、ITERATEと来たので、SERIESでもやらないではいられません…。

インストール

(asdf-install:install :series)

一発です。

使ってみる

これもなんとなくL-99を25問目まで解いてみました。

なんとなく、iterate、mappingで、繰り返し的に、scan-fnで末尾再帰的な感覚で書ける気がしてきました。

それにつけても、SERIESで書かれたソースがあまり出回ってないので、定石な書法がいまいち分からないんですよね…。

(defpackage :l99-series
  (:use :cl :series))

(in-package :l99-series)

;; P01
(defun last-pair (list)
  (collect-last
   (scan-fn 't
            (lambda () list)
            #'cdr 
            #'atom)))

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

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

;; P02
(defun last-2-pair (list)
  (collect-last
   (scan-fn 't
            (lambda () list)
            #'cdr 
            (lambda (x) (atom (cdr 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)
  (first 
   (collect-last
    (scan-fn-inclusive 
     '(values list integer)
     (lambda () (values list 0))
     (lambda (l cnt) (values (cdr l) (1+ cnt)))
     (lambda (l cnt) (or (null l)
                         (>= cnt (1- position))))))))

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

;; P04
;; 1
(defun len (list)
  (let ((cnt 0))
    (iterate ((i (scan list)))
      (incf cnt))
    cnt))

;; 2
(defun len (list)
  (collect-last
   (scan-fn-inclusive '(values integer t)
                      (lambda () (values 0 list))
                      (lambda (cnt lst) (values (1+ cnt) (cdr lst)))
                      (lambda (cnt lst) 
                        (declare (ignore cnt))
                        (null lst)))))

(len (loop :repeat 5 :collect t))
;=> 5

;; P05
(defun rev (list)
  (collect-last
   (scan-fn-inclusive '(values list list)
                      (lambda () (values () list))
                      (lambda (ans list)
                        (values (cons (car list) ans) (cdr list)))
                      (lambda (ans list)
                        (declare (ignore ans))
                        (null list)))))

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

;; P06
(defun palindrome-p (list)
  (iterate ((org (scan list))
            (rev (scan (reverse list))))
    (unless (equal org rev)
      (return-from palindrome-p nil)))
  'T)

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

;; P07
;; 1. 普通にの繰り返しと再帰
(defun flatten (list)
  (collect-append 
   (mapping ((x (scan list )))
     (if (listp x)
         (flatten x)
         (list x)))))

;; 2. gatheringで要素を投げる系
(defun flatten (list)
  (gathering ((ans collect))
    (labels ((f (list gatherer)
               (iterate ((x (scan list)))
                 (if (listp x)
                     (f x gatherer)
                     (next-out gatherer x)))))
      (f list ans))))

;; 3. 普通にの繰り返しと再帰 その2
(defun flatten (list)
  (collect-last
   (scan-fn-inclusive
    '(values list list)
    (lambda () (values () list ))
    (lambda (acc list)
      (values (append acc
                      (if (listp (car list))
                          (flatten (car list))
                          (list (car list))))
              (cdr list)))
    (lambda (acc list)
      (declare (ignore acc))
      (endp list)))))

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

;; P08
(defun compress (list)
  (gathering((ans collect))
    (iterate ((prev (previous (scan list) (gensym) 1))
              (cur (scan list)))
      (unless (equal prev cur)
        (next-out ans cur)))))

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

;; P09
(defun pack (list)
  (gathering ((ans collect))
    (let ((list (nconc (copy-list list) (list (gensym))))
          tem)
      (iterate ((x (scan list))
                (prev (previous (scan list) (gensym) 1)))
        (unless (or (equal prev x) (null tem))
          (next-out ans tem)
          (setq tem () ))
        (push x tem)))))

(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)
  (collect
    (mapping ((x (scan (pack list))))
      `(,(length x) ,(car x)))))

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

;; P11
(defun single (list)
  (and (consp list)
       (null (cdr list))))

(defun encode-modified (list)
  (collect
    (mapping ((x (scan (pack list))))
      (if (single x)
          (car x)
          `(,(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)
  (collect-nconc
   (mapping ((x (scan list)))
     (if (atom x)
         (list x)
         (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
;; gdgd
(defun encode-direct (list)
  (let ((cnt 0)
        (prev (gensym))
        flag)
    (gathering ((ans collect))
      (iterate ((x (scan (nconc (copy-list list) (list (gensym))))))
        (if (or (equal prev x) (not flag))
            (incf cnt)
            (progn 
              (next-out ans (list cnt prev))
              (setq cnt 1)))
        (setq prev x flag 'T)))))

(encode-direct '(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))

;; P14
(defun dupli (list)
  (collect-nconc 
   (mapping ((x (scan list)))
     (list x x))))

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

;; P15
(defun repli (list times)
  (collect-nconc 
   (mapping ((x (scan list)))
     (make-list times :initial-element x))))

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

;; P16
(defun drop (list n)
  (gathering ((ans collect)) 
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (unless (zerop (mod pos n))
        (next-out ans x)))))

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

;; P17
(defun split (list n)
  (let ((front (gatherer #'collect)))
    (iterate ((tail (scan-sublists list))
              (pos (scan-range :from 1)))
      (if (<= pos n)
          (next-out front (car tail))
          (return-from split (list (result-of front) tail))))))

(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)
  (gathering ((ans collect))
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (when (<= start pos end)
        (next-out ans x)))))

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

;; P19
(defun rotate (list n)
  (let ((front (gatherer #'collect))
        (n (mod n (length list))))
    (iterate ((tail (scan-sublists list))
              (pos (scan-range :from 1)))
      (if (<= pos n)
          (next-out front (car tail))
          (return-from rotate (append tail (result-of front)))))))

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

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

;; P20
(defun remove-at (list n)
  (gathering ((ans collect))
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (unless (= pos n)
        (next-out ans x)))))

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

;; P21
(defun insert-at (item list n)
  (gathering ((ans collect))
    (iterate ((x (scan list))
              (pos (scan-range :from 1)))
      (when (= pos n)
        (next-out ans item))
      (next-out ans x))))

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

;; P22
(defun range (start end)
  (collect (scan-range :from start :upto end)))

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

;; P23
(defun rnd-pop (list)
  (if (null list)
      ()
      (let ((n (1+ (random (length list)))))
        (gathering ((ans collect)
                    (rem collect))
          (iterate ((x (scan list))
                    (pos (scan-range :from 1)))
                   (next-out (if (= pos n) rem ans) 
                             x))))))

(defun rnd-select (list n)
  (collect-nth (1- n) 
    (nth-value 1               
      (scan-fn '(values t t) 
               (lambda () (rnd-pop list))
               (lambda (x ans)
                 (multiple-value-bind (a b) (rnd-pop x)
                   (values a (append b ans))))))))

(rnd-select '(a b c d e f g h) 3)
;=> (D A B)

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

(lotto-select 6 50)
;=> (8 3 45 43 5 34)

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

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