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 |

2007-05-03

L-99 (69)

| 05:08 | L-99 (69) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (69) - わだばLisperになる

L-99 P69に挑戦 - L-99:Ninety-Nine Lisp Problems

難しいのは飛して今回は、P69に挑戦。

しかし、段々煮詰って来てしまい、どれもややこしくなっ

てきた。

またもや、文字列表現とリスト表現の変換がお題。

SchemeはもうすこしSchemeらしいスタイルにしたいとこ

ろ。

残りの問題:'(27 55 58-60 63 66 68 80-94 96-99)

P69

解答
;; LISP Machine LISP
(defun tree<=>dotstring (list-or-string)
  (if (stringp list-or-string)
      (dotstring->tree list-or-string)
    (tree->dotstring list-or-string)))

(defun tree->dotstring (tree)
  (string-join (tree->dotstring-aux tree)))

(defun tree->dotstring-aux (tree)
  (if tree
      `(,(string (car tree)) 
	,@(tree->dotstring-aux (cadr tree))
	,@(tree->dotstring-aux (caddr tree)))
    '(".")))

(defun string-join (strs &optional (delim ""))
  (if strs
      (let ((retstr (car strs)))
	(do ((s (cdr strs) (cdr s))
	     (retstr retstr (string-append retstr delim (car s))))
	    ((null s) retstr)))
    ""))

(defun dotstring->tree (str)
  (if (string-equal "" str)
      '()
    (let ((root (substring str 0 1)))
      (if (string-equal root ".")
	  '()
	(multiple-value-bind (l r) (tree-string>get-children str)
	  `(,(read-from-string root)
	    ,(dotstring->tree l)
	    ,(dotstring->tree r)))))))

(defun tree-string>get-boundary (str)
  (let ((point 1))
    (dotimes (i (1- (string-length str)))
      (if (not (string-equal "." (substring str i (1+ i))))
	  (setq point (+ 1 point))
	(setq point (- point 1)))
      (if (zerop point)
	  (return i)))))

(defun tree-string>get-children (str)
  (let ((rootless (substring str 1)))
    (values 
      (substring rootless 0 (1+ (tree-string>get-boundary rootless)))  
      (substring rootless (1+ (tree-string>get-boundary rootless))))))

;; Common Lisp
(defun tree<=>dotstring (list-or-string)
  (if (stringp list-or-string)
      (dotstring->tree list-or-string)
      (tree->dotstring list-or-string)))

(defun tree->dotstring (tree)
  (labels ((frob (tree)
	     (if tree
		 `(,(string (car tree)) ,@(frob (cadr tree)) ,@(frob (caddr tree)))
		 '("."))))
    (string-join (frob tree))))

(defun string-join (strs &optional (delim ""))
  (if strs
      (reduce #'(lambda (retstr s) (concatenate 'string retstr delim s))
	      strs)
      ""))

(defun dotstring->tree (str)
  (if (string= "" str)
      '()
      (let ((root (subseq str 0 1)))
	(if (string= root ".")
	    '()
	    (multiple-value-bind (l r) (tree-string>get-children str)
	      `(,(read-from-string (subseq str 0 1))
		 ,(dotstring->tree l)
		 ,(dotstring->tree r)))))))

(defun tree-string>get-boundary (str)
  (let ((point 1))
    (dotimes (i (1- (length str)))
      (if (string/= "." (subseq str i (1+ i)))
	  (setq point (+ 1 point))
	  (setq point (- point 1)))
      (if (zerop point)
	  (return i)))))

(defun tree-string>get-children (str)
  (let ((rootless (subseq str 1)))
    (values 
     (subseq rootless 0 (1+ (tree-string>get-boundary rootless)))  
     (subseq rootless (1+ (tree-string>get-boundary rootless)))))) 

;; Scheme
(define (tree<=>dotstring list-or-string)
  (if (string? list-or-string)
      (dotstring->tree list-or-string)
      (tree->dotstring list-or-string)))

(define (tree->dotstring tree)
  (letrec ((frob 
	    (lambda (tree)
	      (if (null? tree)
		  '(".")
		  `(,(symbol->string (car tree)) 
		    ,@(frob (cadr tree))
		    ,@(frob (caddr tree)))))))
    (string-join (frob tree) "")))

(define (dotstring->tree str)
  (if (string=? "" str)
      '()
      (let ((root (substring str 0 1)))
	(if (string=? root ".")
	    '()
	    (receive (l r) (tree-string>get-children str)
		     `(,(string->symbol root)
		       ,(dotstring->tree l)
		       ,(dotstring->tree r)))))))

(define (tree-string>get-boundary str)
  (let/cc exit
    (let ((point 1))
      (dotimes (i (- (string-length str) 1))
	       (if (not (string=? "." (substring str i (+ 1 i))))
		   (set! point (+ 1 point))
		   (set! point (- point 1)))
	       (if (zero? point)
		   (exit i))))))

(define (tree-string>get-children str)
  (let* ((len (string-length str))
	 (rootless (substring str 1 len))
	 (boundary (+ 1 (tree-string>get-boundary rootless))))
    (values 
     (substring rootless 0 boundary)
     (substring rootless boundary (- len 1)))))

すべての音階を求める

| 02:33 | すべての音階を求める - わだばLisperになる を含むブックマーク はてなブックマーク - すべての音階を求める - わだばLisperになる

あまりやる気が出ないので、前々から自分が知りたいと

思っていた問題に挑戦してみることにした。

中学生の頃から、12音の組み合わせで可能なすべての音

階を求める方法が知りたかった。色々頭をひねって考え

たり全部書き出してみたりしたけれど、いまいちぱっと

しなかった。

音階の総数自体は、エドモン・コステールの「和声の変

貌」という音楽理論書によれば、351らしい。

本当にそうなのか、それを全部書き出してみるのが今回

の課題。

音階を、0と1の組み合わせの12ビットで表現するなら、

2の12乗である4096より多くはないが、問題は、重複を

いかに取り除くかということで、これが良く分からなかっ

た。

具体的に説明すると、上記の4096の組み合わせの中には、

ハ長調の音階とト長調の音階と…という風に12の重複が

ある。

では、12で割れば良いかというと、大体妥当な数字には

なるけれど、そうも行かない。

ということでコンピュータ様の得意な力ずくでの総当た

りで書き出してみることにした。

まず、音階は数字として、例えば、長音階ならば、

101010110101と2進数で表現する。

これは、10進数では、2741になる。

これを12通り移調(循環シフト)させると

(2741 1387 2774 1453 2906 1717 3434 2773 1451 2902 1709 3418)

となるので、この中から一番小さいものを選ぶ。

この手順を、0〜4095まで繰り返し、重複を削除する。

プログラムとしては、非常に適当だけど

(mapcar #'(lambda (n)
	    (format nil "~12,'0b" n))
	(remove-duplicates
	 (do ((i 0 (1+ i))
	      (retlst '() (cons (apply #'min
				       (mapcar #'(lambda (n)
						   (mod (logior (ash i n)
								(ash i (- (- 12 n))))
							(expt 2 12)))
					       '(0 1 2 3 4 5 6 7 8 9 10 11)))
				retlst)))
	     ((= i 4096) retlst))))

のようなものを作成した。

これで352通りの組み合わせを得ることができた。一つ

多いのは、音がない0も勘定しているためなので、351の

組み合わせということになる。

いやー、長らく知りたかっただけにすっきりした(*´д`*)

そして利用価値はないけれども記念に書き出し。

ちょっと見辛いけれども、

101010110101
b.a.g.fe.d.c

という風に眺めると分かりやすいかもしれない。

"000000000000" "000000000001" "000000000011" "000000000101" "000000000111"
"000000001001" "000000001011" "000000001101" "000000001111" "000000010001"
"000000010011" "000000010101" "000000010111" "000000011001" "000000011011"
"000000011101" "000000011111" "000000100001" "000000100011" "000000100101"
"000000100111" "000000101001" "000000101011" "000000101101" "000000101111"
"000000110001" "000000110011" "000000110101" "000000110111" "000000111001"
"000000111011" "000000111101" "000000111111" "000001000001" "000001000011"
"000001000101" "000001000111" "000001001001" "000001001011" "000001001101"
"000001001111" "000001010001" "000001010011" "000001010101" "000001010111"
"000001011001" "000001011011" "000001011101" "000001011111" "000001100001"
"000001100011" "000001100101" "000001100111" "000001101001" "000001101011"
"000001101101" "000001101111" "000001110001" "000001110011" "000001110101"
"000001110111" "000001111001" "000001111011" "000001111101" "000001111111"
"000010000101" "000010000111" "000010001001" "000010001011" "000010001101"
"000010001111" "000010010001" "000010010011" "000010010101" "000010010111"
"000010011001" "000010011011" "000010011101" "000010011111" "000010100011"
"000010100101" "000010100111" "000010101001" "000010101011" "000010101101"
"000010101111" "000010110001" "000010110011" "000010110101" "000010110111"
"000010111001" "000010111011" "000010111101" "000010111111" "000011000011"
"000011000101" "000011000111" "000011001001" "000011001011" "000011001101"
"000011001111" "000011010001" "000011010011" "000011010101" "000011010111"
"000011011001" "000011011011" "000011011101" "000011011111" "000011100011"
"000011100101" "000011100111" "000011101001" "000011101011" "000011101101"
"000011101111" "000011110001" "000011110011" "000011110101" "000011110111"
"000011111001" "000011111011" "000011111101" "000011111111" "000100010001"
"000100010011" "000100010101" "000100010111" "000100011001" "000100011011"
"000100011101" "000100011111" "000100100011" "000100100101" "000100100111"
"000100101001" "000100101011" "000100101101" "000100101111" "000100110011"
"000100110101" "000100110111" "000100111001" "000100111011" "000100111101"
"000100111111" "000101000101" "000101000111" "000101001001" "000101001011"
"000101001101" "000101001111" "000101010011" "000101010101" "000101010111"
"000101011001" "000101011011" "000101011101" "000101011111" "000101100011"
"000101100101" "000101100111" "000101101001" "000101101011" "000101101101"
"000101101111" "000101110011" "000101110101" "000101110111" "000101111001"
"000101111011" "000101111101" "000101111111" "000110001101" "000110001111"
"000110010011" "000110010101" "000110010111" "000110011001" "000110011011"
"000110011101" "000110011111" "000110100101" "000110100111" "000110101001"
"000110101011" "000110101101" "000110101111" "000110110011" "000110110101"
"000110110111" "000110111001" "000110111011" "000110111101" "000110111111"
"000111000111" "000111001001" "000111001011" "000111001101" "000111001111"
"000111010011" "000111010101" "000111010111" "000111011001" "000111011011"
"000111011101" "000111011111" "000111100101" "000111100111" "000111101001"
"000111101011" "000111101101" "000111101111" "000111110011" "000111110101"
"000111110111" "000111111001" "000111111011" "000111111101" "000111111111"
"001001001001" "001001001011" "001001001101" "001001001111" "001001010011"
"001001010101" "001001010111" "001001011011" "001001011101" "001001011111"
"001001100101" "001001100111" "001001101011" "001001101101" "001001101111"
"001001110011" "001001110101" "001001110111" "001001111011" "001001111101"
"001001111111" "001010010101" "001010010111" "001010011011" "001010011101"
"001010011111" "001010100111" "001010101011" "001010101101" "001010101111"
"001010110011" "001010110101" "001010110111" "001010111011" "001010111101"
"001010111111" "001011001011" "001011001101" "001011001111" "001011010011"
"001011010101" "001011010111" "001011011011" "001011011101" "001011011111"
"001011100111" "001011101011" "001011101101" "001011101111" "001011110011"
"001011110101" "001011110111" "001011111011" "001011111101" "001011111111"
"001100110011" "001100110101" "001100110111" "001100111011" "001100111101"
"001100111111" "001101001101" "001101001111" "001101010101" "001101010111"
"001101011011" "001101011101" "001101011111" "001101100111" "001101101011"
"001101101101" "001101101111" "001101110101" "001101110111" "001101111011"
"001101111101" "001101111111" "001110011101" "001110011111" "001110101011"
"001110101101" "001110101111" "001110110101" "001110110111" "001110111011"
"001110111101" "001110111111" "001111001111" "001111010101" "001111010111"
"001111011011" "001111011101" "001111011111" "001111101011" "001111101101"
"001111101111" "001111110101" "001111110111" "001111111011" "001111111101"
"001111111111" "010101010101" "010101010111" "010101011011" "010101011111"
"010101101011" "010101101111" "010101110111" "010101111011" "010101111111"
"010110101111" "010110110111" "010110111011" "010110111111" "010111010111"
"010111011011" "010111011111" "010111101111" "010111110111" "010111111011"
"010111111111" "011011011011" "011011011111" "011011101111" "011011110111"
"011011111111" "011101110111" "011101111111" "011110111111" "011111011111"
"011111111111" "111111111111"