misc:software:Common Lisp:Yet Another Common Lisp Problems:1-25

misc:software:Common Lisp:Yet Another Common Lisp Problems:1-25

1 singlep

(defun singlep (l)
  (when (consp l)
    (null (cdr l))))

(5am:test p-1
  (5am:is (equal
           (singlep '(a))
           t
           ))
  (5am:is (equal
           (singlep '(a b))
           nil
           ))
  (5am:is (equal
           (singlep '())
           nil
           ))
  )

(5am:run! 'p-1)

2. doublep

;; 空リストなら (cdr l) が nil を返す
;; 要素が1つのリストも (cdr l) が nil を返す
;; 要素が2つのリストは (cdr l) で2つめの要素を取得し、singlep 関数で t を返す
;; 要素が3つ以上のリストは (cdr l) で2つめ以後の要素を取得し、singlep 関数で nil を返す
(defun doublep (l)
  (singlep (cdr l)))

(5am:test p-2
  (5am:is (equal
           (doublep '(a b))
           t
           ))
  (5am:is (equal
           (doublep '(a b c))
           nil
           ))
  (5am:is (equal
           (doublep '(a))
           nil
           ))
  )
(5am:run! 'p-2)

3. longerp

(defun longerp (xs ys)
  (loop
     for x on xs
     for y on ys
     finally (return (consp x))
       ))

(5am:test p-3
  (5am:is (equal
           (longerp '(a b c) '(a b))
           t
           ))
  (5am:is (equal
           (longerp '(a b) '(a b))
           nil
           ))
  (5am:is (equal
           (longerp '(a) '(a b))
           nil
           ))
  )
(5am:run! 'p-3)

4 my-last / my-butlast

(defun my-last (xs)
  (loop
     for x on xs
     when (singlep x)
     return x))

(defun my-butlast (xs)
  (loop
     for x on xs
     unless (singlep x)
     collect (car x)))

(5am:test p-4
  (5am:is (equal
           (my-last '(a b c))
           '(c)
           ))
  (5am:is (equal
           (my-last '(a))
           '(a)
           ))
  (5am:is (equal
           (my-butlast '(a b c))
           '(a b)
           ))
  (5am:is (equal
           (my-butlast '(a))
           '()
           ))
  )
(5am:run! 'p-4)

5 take

(defun take (xs n)
  (loop
     for x in xs
     for i = 0 then (incf i)
     when (< i n)
     collect x))

(5am:test p-5
  (5am:is (equal
           (take '(a b c d e) 3)
           '(a b c)
           ))
  (5am:is (equal
           (take '(a b c d e) 0)
           '()
           ))
  (5am:is (equal
           (take '(a b c d e) 6)
           '(a b c d e)
           ))
  )
(5am:run! 'p-5)

6 drop

(defun drop (xs n)
  (loop
     for x on xs
     for i = 0 then (incf i)
     when (= i n)
     return x))


(5am:test p-6
  (5am:is (equal
           (drop '(a b c d e) 3)
           '(d e)
           ))
  (5am:is (equal
           (drop '(a b c d e) 0)
           '(a b c d e)
           ))
  (5am:is (equal
           (drop '(a b c d e) 6)
           '()
           ))
  )
(5am:run! 'p-6)

7 my-subseq

(defun my-subseq (xs n m)
  (take (drop xs n) (- m n)))

(5am:test p-7
  (5am:is (equal
           (my-subseq '(a b c d e) 2 4)
           '(c d)
           ))
  (5am:is (equal
           (my-subseq '(a b c d e) 0 5)
           '(a b c d e)
           ))
  (5am:is (equal
           (my-subseq '(a b c d e) 0 0)
           '()
           ))
  )
(5am:run! 'p-7)

8 my-butlast2

(defun my-butlast2 (ls &optional (n 1))
  (take ls (- (length ls) n)))

(5am:test p-8
  (5am:is (equal
           (my-butlast2 '(a b c d e) 3)
           '(a b)
           ))
  (5am:is (equal
           (my-butlast2 '(a b c d e) 0)
           '(a b c d e)
           ))
  (5am:is (equal
           (my-butlast2 '(a b c d e) 5)
           '()
           ))
  )
(5am:run! 'p-8)

9 group

(defun group (xs n)
  (loop
     for i from 0 to (- (length xs) 1) by n
     collect (my-subseq xs i (+ i n))))


(5am:test p-9
  (5am:is (equal
           (group '(a b c d e f) 2)
           '((a b) (c d) (e f))
           ))
  (5am:is (equal
           (group '(a b c d e f) 3)
           '((a b c) (d e f))
           ))
  (5am:is (equal
           (group '(a b c d e f) 4)
           '((a b c d) (e f))
           ))
  )
(5am:run! 'p-9)

10 my-position

(defun my-position (x ls)
  (loop
     for item in ls
     for i = 0 then (incf i)
     when (equal item x)
     return i))
         
(5am:test p-10
  (5am:is (equal
           (my-position 'a '(a b c d e))
           0
           ))
  (5am:is (equal
           (my-position 'c '(a b c d e))
           2
           ))
  (5am:is (equal
           (my-position 'e '(a b c d e))
           4
           ))
  (5am:is (equal
           (my-position 'f '(a b c d e))
           nil
           ))
  )
(5am:run! 'p-10)

11 my-count

(defun my-count (x ls)
  (loop
     for item in ls
     when (equal item x)
     sum 1))
         
(5am:test p-11
  (5am:is (equal
           (my-count 'a '(a b a b c a b c d))
           3
           ))
  (5am:is (equal
           (my-count 'c '(a b a b c a b c d))
           2
           ))
  (5am:is (equal
           (my-count 'd '(a b a b c a b c d))
           1
           ))
  (5am:is (equal
           (my-count 'e '(a b a b c a b c d))
           0
           ))
  )
(5am:run! 'p-11)

12 sum-list

(defun sum-list (ls)
  (loop
     for item in ls
     sum item))
         
(5am:test p-12
  (5am:is (equal
           (sum-list '(1 2 3 4 5))
           15
           ))
  )
(5am:run! 'p-12)

13 max-list / min-list

(defun max-list (ls)
  (loop
     for item in ls
     maximize item))
         
(defun min-list (ls)
  (loop
     for item in ls
     minimize item))
         
(5am:test p-13
  (5am:is (equal
           (max-list '(5 6 4 7 3 8 2 9 1))
           9
           ))
  (5am:is (equal
           (min-list '(5 6 4 7 3 8 2 9 1))
           1
           ))
  )
(5am:run! 'p-13)

14 adjacent

(defun adjacent (x y ls)
  (loop
     for item on ls
     thereis (and (equal x (car item))
                  (equal y (cadr item)))))

(5am:test p-14
  (5am:is (equal
           (adjacent 'a 'b '(a b c d e f))
           t
           ))
  (5am:is (equal
           (adjacent 'e 'f '(a b c d e f))
           t
           ))
  (5am:is (equal
           (adjacent 'f 'e '(a b c d e f))
           nil
           ))
  )
(5am:run! 'p-14)

15 before

(defun before (x y ls)
  (member y (member x ls)))
         
(5am:test p-15
  (5am:is (equal
           (before 'a 'b '(a b c d e f))
           '(b c d e f)
           ))
  (5am:is (equal
           (before 'c 'b '(a b c d e f))
           nil
           ))
  )
(5am:run! 'p-15)

16 iota

(defun iota (n m)
  (loop
     for i from n to m
     collect i))
         
(5am:test p-16
  (5am:is (equal
           (iota 1 5)
           '(1 2 3 4 5)
           ))
  )
(5am:run! 'p-16)

17 set-of-list

(defun set-of-list (ls)
  (remove-duplicates ls))
       
(5am:test p-17
  (5am:is (equal
           (set-of-list '(a b c d e f a b c))
           '(d e f a b c)
           ))
  )
(5am:run! 'p-17)

18 my-union

(defun my-union (xs ys)
  (append xs
          (loop
             for y in ys
             unless (my-position y xs)
             collect y)))

(5am:test p-18
  (5am:is (equal
           (my-union '(a b c d) '(c d e f))
           '(a b c d e f)
           ))
  )
(5am:run! 'p-18)

19 my-intersection

(defun my-intersection (xs ys)
  (set-of-list
   (loop
      for x in xs
      when (member x ys)
      collect x)))

(5am:test p-19
  (5am:is (equal
           (my-intersection '(a b c d) '(c d e f))
           '(c d)
           ))
  )
(5am:run! 'p-19)

20 difference

(defun difference (xs ys)
  (set-of-list
   (loop
      for x in xs
      unless (member x ys)
      collect x)))

(5am:test p-20
  (5am:is (equal
           (difference '(a b c d) '(c d e f))
           '(a b)
           ))
  )
(5am:run! 'p-20)

21 merge-list

(defun merge-list (pred xs ys)
  (cond
    ((null xs) ys)
    ((null ys) xs)
    ((aux-merge-list-p pred xs ys)
     (cons (car xs) (merge-list pred (cdr xs) ys)))
    (t
     (cons (car ys) (merge-list pred xs (cdr ys))))
    ))

(defun aux-merge-list-p (pred xs ys)
  (loop
       for x in xs
       for y in ys
       return (funcall pred x y)))

(5am:test p-21
  (5am:is (equal
           (merge-list #'< '(1 3 5 7) '(2 4 6 8))
           '(1 2 3 4 5 6 7 8)
           ))
  )
(5am:run! 'p-21)

22 merge-sort

(defun merge-sort (pred len ls)
  (take (aux-merge-sort pred ls) len))

(defun aux-merge-sort (pred ls)
  (let ((mid (floor (length ls) 2)))
    (if (zerop mid)
        ls
        (merge-list pred
                    (aux-merge-sort pred (take ls mid))
                    (aux-merge-sort pred (drop ls mid))
                    ))))

(5am:test p-22
  (5am:is (equal
           (merge-sort #'< 9 '(5 6 4 7 8 3 2 9 1 10))
           '(1 2 3 4 5 6 7 8 9)
           ))
  (5am:is (equal
           (merge-sort #'< 10 '(5 6 4 7 8 3 2 9 1 10))
           '(1 2 3 4 5 6 7 8 9 10)
           ))
  (5am:is (equal
           (merge-sort #'< 11 '(5 6 4 7 8 3 2 9 1 10 0))
           '(0 1 2 3 4 5 6 7 8 9 10)
           ))
  )
(5am:run! 'p-22)

23 prefix

(defun prefix (xs ys)
  (loop
     for x in xs
     for y in ys
     always (equal x y)))

(5am:test p-23
  (5am:is (equal
           (prefix '(a b c d e f) '(a b c))
           t
           ))
  (5am:is (equal
           (prefix '(a b c d e f) '(a b c e))
           nil
           ))
  (5am:is (equal
           (prefix '(a b c d e f) '())
           t
           ))
  )
(5am:run! 'p-23)

24 suffix

(defun suffix (xs ys)
  (prefix (drop xs (- (length xs) (length ys))) ys))

(5am:test p-24
  (5am:is (equal
           (suffix '(a b c d e f) '(d e f))
           t
           ))
  (5am:is (equal
           (suffix '(a b c d e f) '())
           t
           ))
  (5am:is (equal
           (suffix '(a b c d e f) '(f g))
           nil
           ))
  )
(5am:run! 'p-24)

25 sublistp

(defun sublistp (xs ls)
  (loop
     for l on ls
     thereis (prefix l xs)))

(5am:test p-25
  (5am:is (equal
           (sublistp '(c d e) '(a b c d e f))
           t
           ))
  (5am:is (equal
           (sublistp '(d e) '(a b c d e f))
           t
           ))
  (5am:is (equal
           (sublistp '(d e g) '(a b c d e f))
           nil
           ))
  (5am:is (equal
           (sublistp '() '(a b c d e f))
           t
           ))
  )
(5am:run! 'p-25)

Last modified : 2014/07/05 18:39:54 JST
blechmusik (blechmusik@gmail.com)