P28: リストの長さで並び替え

サブリストの長さで並び替える。
さらに、サブリストの長さの頻度で並び替える。

まずは、sort関数を定義。

(defun my-sort (lis smaller-p &key (key #'identity))
  (if (null lis)
      nil
    (do ((x (car lis))
	 (bigger '())
	 (smaller '())
	 (l (cdr lis) (cdr l)))
	((null l)
	 (append (my-sort smaller smaller-p :key key)
		 (list x)
		 (my-sort bigger smaller-p :key key)))
      (if (funcall smaller-p (funcall key x) (funcall key (car l)))
	  (push (car l) bigger)
	(push (car l) smaller)))))

(my-sort '(1 -5 2 -9 3) #'<)
;; => (-9 -5 1 2 3)
(my-sort '(1 -5 2 -9 3) #'< :key #'abs)
;; => (1 2 3 -5 -9)

P28-a はkeyを長さにして昇順に並び替えるだけ。

;; P28 a
(defun sort-by-length (lis)
  (my-sort lis #'< :key #'length))

(sort-by-length '((a b) (c d e) (f) (g h) (i j k l) (g h) (m)))
;; => ((M) (F) (A B) (G H) (G H) (C D E) (I J K L))

P28-bを解くために、補助関数を定義。
collect-and-frequencyは、要素をget-keyが返すkey毎にまとめ、keyの出現回数を計上する。

(defun collect-and-frequency (lis get-key)
  (if (null lis)
      nil
    (do ((table (make-hash-table))
	 (l lis (cdr l))
	 (acc '()))
	((null l)
	 (maphash (lambda (key val)
		    (push (list key (length val) val) acc)) table)
	 acc)
      (push (car l) (gethash (funcall get-key (car l)) table)))))

(collect-and-frequency '(a b c d 1 2 3 4 "a" "b" "c" "d") #'class-of)
;; => ((#<BUILT-IN-CLASS SB-KERNEL::SIMPLE-CHARACTER-STRING> 4 ("d" "c" "b" "a"))
;;    (#<BUILT-IN-CLASS FIXNUM> 4 (4 3 2 1))
;;    (#<BUILT-IN-CLASS SYMBOL> 4 (D C B A)))

(collect-and-frequency '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)) #'length)
;; => ((1 1 ((O))) (4 1 ((I J K L))) (2 3 ((M N) (D E) (D E)))
;;     (3 2 ((F G H) (A B C))))

collect-and-frequencyを使って、リストの長さの出現回数順に並べ替える関数を定義する。

;; P28 b
(defun sort-by-frequency (lis)
  (apply #'append
	 (mapcar (lambda (entry)
		   (third entry))
		 (my-sort (collect-and-frequency lis #'length) #'< :key #'second))))

(sort-by-frequency '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))
;; => ((I J K L) (O) (F G H) (A B C) (M N) (D E) (D E))

お、これでList系の問題は完了の模様。
次はP31から、算術系の問題。
# あれ？P29,P30は？