Top / 安東基範 / Diary

日記一覧

2006/3/10 (金)

「農夫と鷄」の問題 †

(define (subtract x y)
  (do ((x x (cdr x))
       (y y (cdr y))
       (s '() (cons (- (car x)(car y)) s)))
      ((null? x) (reverse s))))
 
 
(define call/cc call-with-current-continuation)
 
 
(define (subtract x y)
  (call/cc (lambda (exit)
            (do ((x x (cdr x))
                 (y y (cdr y))
                 (s '() (cons
                         (let ((z (- (car x)(car y))))
                           (cond ((< z 0) (exit #f))
                                 (#t z)))
                         s)))
                ((null? x) (reverse s))))))
 
 
(define (addition x y)
  (call/cc (lambda (exit)
            (do ((x x (cdr x))
                 (y y (cdr y))
                 (s '() (cons
                         (let ((z (+ (car x)(car y))))
                           (cond ((> z 1) (exit #f))
                                 (#t z)))
                         s)))
                ((null? x) (reverse s))))))
 
(define (calc x y)
  (cond ((> (car x) 0) (subtract x y))
       (#t (addition x y))))
 
(define move-pattern '((1 0 0 0)(1 1 0 0)(1 0 1 0)(1 0 0 1)))
 
(define (err-pattern? x)
  (cond ((equal? x #f) #t)
       ((equal? x '(0 1 1 0)) #t)
       ((equal? x '(1 0 0 1)) #t)
       ((equal? x '(0 0 1 1)) #t)
       ((equal? x '(1 1 0 0)) #t)
       (#t #f)))
 
(define (extend path)
  (map (lambda (new-node)(cons new-node path))
       (remove-if (lambda (neighbor)(member neighbor path))
                 (remove-if (lambda (x) (err-pattern? x))
                            (map (lambda (e)(calc (car path) e))
                                 move-pattern)))))
 
(define (depth-first start finish)
  (let loop ((queue (list (list start))))
    (cond ((null? queue) '())
         ((equal? finish (caar queue))
          (cons (reverse (car queue))
                (loop (cdr queue))))
         (#t (loop (append (extend (car queue))(cdr queue)))))))
↑

「宣教師と土人」の問題 †

(define (subtract x y)
  (do ((x x (cdr x))
       (y y (cdr y))
       (s '() (cons (- (car x)(car y)) s)))
      ((null? x) (reverse s))))
 
(define (add x y)
  (do ((x x (cdr x))
       (y y (cdr y))
       (s '() (cons (+ (car x)(car y)) s)))
      ((null? x) (reverse s))))
 
(define (calc x y)
  (cond ((> (car x) 0) (subtract x y))
       (#t (add x y))))
 
(define move-pattern '((1 1 0)
                      (1 0 1)
                      (1 2 0)
                      (1 0 2)
                      (1 1 1)))
 
(define (another-bank x)
  (list (if (= (car x) 0) 1 0)
       (- 3 (cadr x))
       (- 3 (caddr x))))
 
(define (range-ok? x)
  (let ((y (cadr x))(z (caddr x)))
    (and (>= y 0)(<= y 3)
        (>= z 0)(<= z 3))))
 
(define (err-pattern1? x)
  (cond ((< (cadr x) 1) #f)
       ((> (caddr x) (cadr x)) #t)
       (#t #f)))
 
(define (err-pattern? x)
  (or (err-pattern1? x) (err-pattern1? (another-bank x))
      (not (range-ok? x))))
 
(define (extend path)
  (map (lambda (new-node)(cons new-node path))
       (remove-if (lambda (neighbor)(member neighbor path))
                 (remove-if (lambda (x) (err-pattern? x))
                            (map (lambda (e)(calc (car path) e))
                                 move-pattern)))))
 
(define (depth-first start finish)
  (let loop ((queue (list (list start))))
    (cond ((null? queue) '())
         ((equal? finish (caar queue))
          (cons (reverse (car queue))
                (loop (cdr queue))))
         (#t (loop (append (extend (car queue))(cdr queue)))))))
↑

「残酷な家族」の問題 †

(define (subtract x y)
  (do ((x x (cdr x))
       (y y (cdr y))
       (s '() (cons (- (car x)(car y)) s)))
      ((null? x) (reverse s))))
 
(define (add x y)
  (do ((x x (cdr x))
       (y y (cdr y))
       (s '() (cons (+ (car x)(car y)) s)))
      ((null? x) (reverse s))))
 
(define (calc x y)
  (cond ((> (car x) 0) (subtract x y))
       (#t (add x y))))
 
(define move-pattern '((1 1 0 0 0 0 0) ;;父
                      (1 1 1 0 0 0 0)
                      (1 1 0 1 0 0 0)
                      (1 1 0 0 0 1 0)
                      (1 0 1 0 0 0 0) ;;母
                      (1 0 1 0 1 0 0)
                      (1 0 1 0 0 1 0)
                      (1 0 0 0 0 1 0) ;;召使い
                      (1 0 0 1 0 1 0)
                      (1 0 0 0 1 1 0)
                      (1 0 0 0 0 1 1)))
 
(define (father x)(cadr x))
(define (mother x)(caddr x))
(define (sons x)(cadddr x))
(define (daughters x)(car (cddddr x)))
(define (servant x)(cadr (cddddr x)))
(define (dog x)(caddr (cddddr x)))
 
(define (another-bank x)
  (list (if (= (car x) 0) 1 0)
       (- 1 (father x))
       (- 1 (mother x))
       (- 2 (sons x))
       (- 2 (daughters x))
       (- 1 (servant x))
       (- 1 (dog x))))
 
(define (range-ok? x)
    (and (>= (father x) 0)(<= (father x) 1)
        (>= (mother x) 0)(<= (mother x) 1)
        (>= (sons x) 0)(<= (sons x) 2)
        (>= (daughters x) 0)(<= (daughters x) 2)
        (>= (servant x) 0)(<= (servant x) 1)
        (>= (dog x) 0)(<= (dog x) 1)))
 
(define (err-pattern1? x)
  (cond ((and (= (father x) 1)(= (mother x) 0)(>= (daughters x) 1)) #t)
       ((and (= (mother x) 1)(= (father x) 0)(>= (sons x) 1)) #t)
       ((and (= (dog x) 1)(= (servant x) 0)
             (or (= (father x) 1)
                 (= (mother x) 1)
                 (>= (sons x) 1)
                 (>= (daughters x) 1)))
        #t)
       (#t #f)))
 
(define (err-pattern? x)
  (or (err-pattern1? x) (err-pattern1? (another-bank x))
      (not (range-ok? x))))
 
(define (extend path)
  (map (lambda (new-node)(cons new-node path))
       (remove-if (lambda (neighbor)(member neighbor path))
                 (remove-if (lambda (x) (err-pattern? x))
                            (map (lambda (e)(calc (car path) e))
                                 move-pattern)))))
 
(define (depth-first start finish)
  (let loop ((queue (list (list start))))
    (cond ((null? queue) '())
         ((equal? finish (caar queue))
          (cons (reverse (car queue))
                (loop (cdr queue))))
         (#t (loop (append (extend (car queue))(cdr queue)))))))

2006/1/27 (金)

(define (add-binding pattern-variable-expression datum bindings)
  (cond ((eq? '_ (extract-variable pattern-variable-expression)) bindings)
       (#t (cons
            (make-binding (extract-variable pattern-variable-expression)
                          datum)
            bindings))))
(define (extract-variable pattern-variable-expression)
  (cadr pattern-variable-expression))
(define (make-binding variable datum)
  (list variable datum))
                                                                               
(define (find-binding pattern-variable-expression binding)
  (cond  ((eq? '_ (extract-variable pattern-variable-expression)) #f)
        (#t (assq (extract-variable pattern-variable-expression) binding))))
                                                                               
(define (extract-key binding)
  (car binding))
                                                                               
(define (extract-value binding)
  (cadr binding))
                                                                               
(define (match-atoms p d bindings)
  (cond ((equal? p d) bindings)
       (#t 'fail)))
                                                                               
(define (match-variable p d bindings)
  (let ((binding (find-binding p bindings)))
    (cond ((binding (match (extract-value binding) d bindings)))
         (#t (add-binding p d bindings)))))
                                                                               
(define (match-pieces p d bindings)
  (let ((result (match (car p) (car d) bindings)))
    (cond ((eq? 'fail result) 'fail)
         (#t (match (cdr p) (cdr d) result)))))
                                                                               
(define (elements? p d)
  (and (not (pair? p))
       (not (pair? d))))
 
(define (variable? p)
  (and (list? p)
       (eq? '? (car p))))
 
(define (recursive? p d)
  (and (list? p)
       (list? d)))
 
(define (match p d . bindings)
  (cond ((elements? p d) (match-atoms p d bindings))
       ((variable? p) (match-variable p d bindings))
       ((recursive? p d) (match-pieces p d bindings))
       (#t 'fail)))

2005/12/16 (金)

安東基範/Diary

(define (weight operator)
	 (cond ((eq? operator '=) 0)
	       ((eq? operator '+) 1)
	       ((eq? operator '-) 1)
	       ((eq? operator '*) 2)
	       ((eq? operator '/) 2)
	       ((eq? operator '\\) 2)
	       ((eq? operator '^) 3)
	       (#t operator)))
(define (opcode operator)
	 (cond ((eq? operator '=) 'set!)
	       ((eq? operator '+) '+)
	       ((eq? operator '-) '-)
	       ((eq? operator '*) '*)
	       ((eq? operator '/) '/)
	       ((eq? operator '\\) 'rem)
	       ((eq? operator '^) 'expt)
	       (#t operator)))
(define (inf-to-pre ae)
	 (cond ((not (pair? ae)) ae)
	       (#t (inf-aux ae '() '()))))
(define (inf-aux ae operators operands)
	 (inf-iter (cdr ae)
		   operators
		   (cons (inf-to-pre (car ae)) operands)))
(define (inf-iter ae operators operands)
	 (cond ((and (null? ae) (null? operators)) (car operands))
	       ((and (not (null? ae))
		     (or (null? operators)
			 (> (weight (car ae)) (weight (car operators)))))
		(inf-aux (cdr ae) (cons (car ae) operators) operands))
	       (#t (inf-iter ae
			     (cdr operators)
			     (cons (list (opcode (car operators))
					 (cadr operands)
					 (car operands))
				   (cdr (cdr operands)))))))

2005/12/9 (金)

equal? †

↑

cond式 †

(define (equal? x y)
	 (cond ((not (pair? x)) (eq? x y))
	       ((not (pair? y)) #f)
	       ((equal? (car x) (car y)) (equal? (cdr x) (cdr y)))
	       (#t #f)))
↑

and と or †

(define (equal? x y)
	 (or (eq? x y)
	     (and (pair? x)
		  (pair? y)
		  (equal? (car x) (car y))
		  (equal? (cdr x) (cdr y)))))
↑

ハノイの塔 †

(define (printline . x)
	 (map display x)
	 (newline))
(define (moveto n a b)
	 (printline "move the disk#" n " from " a " to " b))
(define (hanoi n a b c)
	 (cond ((= n 1) (moveto n a b))
	       (#t (hanoi (1- n) a c b)
		   (moveto n a b)
		   (hanoi (1- n) c b a))))

2004/12/12 (日)

安東基範/Diary

PukiWikiの使い方/操作方法は一応完成？ PDF版は手付かず。「画像を取り込んで〜」が面倒くさい。質問とかもないようだし、気が向いた時にでもやるか。

HTMLコンテンツの充実はコツコツやるしかない。一応少し更新しておいたが。しかし魅力のある内容には程遠い。センスないかも。

Blogは日々更新中。でも日記というよりはメモか独り言ばっかり。今まで日記なんてほとんど書いたことないし。まあ、気楽に投稿していくか。

2004/12/1 (水)

安東基範/Diary

初めて Blog というものを触ってみた。 CSS のカスタムもできるので、自由度はかなり高いようである。ただ、内容の変更はログインしてから行うので、書き込むのが少し面倒ではあるが。一応 CSS をカスタムして preタグ にスタイルを設定しておいた。これでソースなどの表示が楽になるだろう。

2004/11/30 (火)

安東基範/Diary

正規表現メモ：

popularプラグインで FrontPage, MenuBar, トップの SubMenu, 各階層の SubMenu だけを表示しないようにするにはどうすればよいか？次のサイトで調べてみた。

一通り調べ終わったので、実際にEmEditorの検索機能（オプション：正規表現を使用する）を使って、検索する文字列を

^(FrontPage|MenuBar|(.+/)?SubMenu)$

として、以下の文字列を検索してみた。

FrontPage
FrontPPage
FrontPagefuga
hogeFrontPage
hogeFrontPagefuga
FrontPage/fuga
hoge/FrontPage
hoge/FrontPage/fuga
MenuBar
MenuBBar
MenuBarfuga
hogeMenuBar
hogeMenuBarfuga
MenuBar/fuga
hoge/MenuBar
hoge/MenuBar/fuga
SubMenu
SubMMenu
SubMenufuga
hogeSubMenu
hogeSubMenufuga
/SubMenu
/SubMenufuga
/hogeSubMenu
/hogeSubMenufuga
hoge/SubMenu
hoge/SubMenufuga
hoge/hogeSubMenu
hoge/hogeSubMenufuga
hoge/SubMenu/
hoge/SubMenu/SubMenu
hoge/SubMenu/fuga
hoge/hogehoge/SubMenu
hoge/hogehoge/SubMenu/SubMenu
hoge/hogehoge/SubMenu/fuga

すると次の7行がマッチした。

FrontPage
MenuBar
SubMenu
hoge/SubMenu
hoge/SubMenu/SubMenu
hoge/hogehoge/SubMenu
hoge/hogehoge/SubMenu/SubMenu

全てのパターンを網羅しているわけではないが、これを見ると、 FrontPage, MenuBar, トップの SubMenu, 各階層の SubMenu だけを表示しない という目的と一致しているように思われる。

SandBoxでpopularプラグインを試してみた。

#popular(30)
#popular(30,^(FrontPage|MenuBar|(.+/)?SubMenu)$)

2つを見比べてみるとうまくいっている様に見えるが、トップのSubMenuは作成していないので完璧ではない。

次の7件>>
トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   ヘルプ   最終更新のRSS
Last-modified: 2008-10-03 (金) 06:37:08 (95d)