約 2,744,674 件

• Terragen - Lead-in Scare

  https://w.atwiki.jp/terragen/pages/96.html

  Lead-in Scare(リードイン・スケール) 「lead-in」オクターブは「feature scale」オクターブと同じ振幅を持っています。 "roughness"パラメータが全ての最も小さなスケールの「feature scale」以下のオクターブの減少を制御しますが、 「feature scale」より上のオクターブには影響しません。また、マルチフラクタルの中でもより少ないオクターブに 影響しますが、どんな法線のオクターブにも作用する同じ方法で影響します。 ところで、パワーフラクタル内のオクターブ（空隙性）の間の縮尺比率はベースとなるオクターブ数（1.92）に準じて 計算しています。 log( leadinScale / smallestScale ) / log(1.92) フラクタルパラメーターを変更する時は、リアルタイムで変更点を見出すために"Show HUD in Preview"オプションを アルファビルドにして下さい。 HUDは色ではなく、ディスプレースメントのために作用します。 「Lead-in」の作用についての資料 各バーは1オクターブを表します。 書くバーの高さはオクターブ（すなわち、そのスケールへのオクターブの振幅の比率）の勾配です。 書くバーの下の小さな三角印は同じものを表しています。 最も高いバーは"Feature scale"のオクターブで、そこから左にあるバーは、より大きなスケールを持つ "Lead-in scale"のオクターブです。反対に右へ向かうバーは小さなスケールを持つオクターブです。 一番右端のバーは"Smallest scale"のオクターブです。 この例では Lead-in scale = 200,000 Feature scale = 5,000 Smallest scale = 0.1 で設定しました。 左から最初の"Lead-in scale"の5つのバーからなる23のオクターブを生み出しています。 "Lead-in scale"はすべて同じ振幅を持っていますが、多様性なスケールをも持ち合わせています。 従って縮尺するための振幅比率はスケールに反比例します。最初のオクターブは最も大きいスケールと 最も小さい縮尺するための振幅比率を持っています。 "Feature scale"から右へのオクターブ("Feature scale"より小さい)は、"Displacement roughness"に よって影響を受けます。この例では、"Displacement roughness"の値が0.875であり、"Feature scale"の オクターブは縮尺するための振幅比率によって徐々に減少するよう的確に引き起こしています。 "Displacement roughness"の値が1の場合、振幅がスケールに比例するので"Feature scale"の右側の全ての バーは"Feature scale"に等しい高さになります。 "Displacement roughness"の値が1より大きい場合、縮尺するための振幅比率は右に向かって増加するでしょう。 参照フォーラム power fractal "lead-in scale" question (again)

• sicpstudygroup @ ウィキ - naga:2-17/2-52

  https://w.atwiki.jp/sicpstudygroup/pages/51.html

  naga Todo 2.19 Exercise 2.17 (define (last-pair list) (if (null? (cdr list)) list (last-pair (cdr list)))) ;;gosh (last-pair (list 23 72 149 34)) ;;(34) Exercise 2.18 (define (reverse_r l) (if (null? l) '() (append (reverse_r (cdr l)) (list (car l))))) (define (reverse_i l) (define (reverse_iter l rl) (if (null? l) rl (reverse_iter (cdr l) (cons (car l) rl)))) (reverse_iter l ())) ;;gosh (define a (list 1 4 9 16 24)) ;;a ;;gosh (reverse_r a) ;;(24 16 9 4 1) ;;gosh (reverse_i a) ;;(24 16 9 4 1) Exercise 2.19 後日 Exercise 2.20 (define (same-parity-r x . y) (let ((even/odd? (if (even? x) even? odd?)) (items (cons x y))) (define (rec l) (cond ((null? l) l) ((even/odd? (car l)) (cons (car l) (rec (cdr l)))) (else (rec (cdr l))))) (rec items))) (define (same-parity-i x . y) (let ((even/odd? (if (even? x) even? odd?))) (define (iter y l) (cond ((null? y) (cons x (reverse l))) ((even/odd? (car y)) (iter (cdr y) (cons (car y) l))) (else (iter (cdr y) l)))) (iter y '()))) ;;gosh (same-parity-i 1 2 3 4 5 6 7) ;;(1 3 5 7) ;;gosh (same-parity-i 2 3 4 5 6 7) ;;(2 4 6) ;;gosh (same-parity-r 1 2 3 4 5 6 7) ;;(1 3 5 7) ;;gosh (same-parity-r 2 3 4 5 6 7) ;;(2 4 6) Exercise 2.21 (define (square-list-r l) (if (null? l) '() (cons (square (car l)) (square-list-r (cdr l))))) (define (square-list-m l) (map square l)) ;;gosh (square-list-r (list 1 2 3 4)) ;;(1 4 9 16) ;;gosh (square-list-m (list 1 2 3 4)) ;;(1 4 9 16) Exercise 2.22 ;; square-list-1ではanswerにはthingsの最初の項が最後に、thingsの次の項が最後から2番目にとlistされるため。 (define (square-list-1 items) (define (iter things answer) (if (null? things) answer (iter (cdr things) (cons (square (car things)) answer)))) (iter items '())) ;; square-list-2ではanswerのcar部にこれまでの結果が、cdr部にsquareのドットペアを生成している。 (define (square-list-2 items) (define (iter things answer) (if (null? things) answer (iter (cdr things) (cons answer (square (car things)))))) (iter items '())) ;; 素直に (define (square-list-3 items) (define (iter things answer) (if (null? things) (reverse answer) (iter (cdr things) (cons (square (car things)) answer)))) (iter items '())) ;;gosh (square-list-1 (list 1 2 3 4)) ;;(16 9 4 1) ;;gosh (square-list-2 (list 1 2 3 4)) ;;((((() . 1) . 4) . 9) . 16) ;;gosh (square-list-3 (list 1 2 3 4)) ;;(1 4 9 16) Exercise 2.23 (define (for-each proc items) (if (null? items) #t (begin (proc (car items)) (for-each proc (cdr items))))) ;;gosh (for-each (lambda (x) (newline) (display x)) '(57 321 88)) ;; ;;57 ;;321 ;;88#t Exercise 2.24 ;; (1 (2 (3 4))) ;; / nilのつもり ;; [1 ]- [ / ] ;; | ;; [2 ]- [ / ] ;; | ;; [3 ]- [4 / ] ;; treeは省略 ;;gosh (list 1 (list 2 (list 3 4))) ;;(1 (2 (3 4))) Exercise 2.25 ;;gosh (car (cdr (car (cdr (cdr '(1 3 (5 7) 9)))))) ;;7 ;;gosh (car (car '((7)))) ;;7 ;;gosh (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr '(1 (2 (3 (4 (5 (6 7)))))))))))))))))) ;;7 Exercise 2.26 ;; (append x y) - (1 2 3 4 5 6) ;; (cons x y) - ((1 2 3) 4 5 6) ;; (list x y) - ((1 2 3) (4 5 6)) ;;gosh (define x '(1 2 3)) ;;x ;;gosh (define y '(4 5 6)) ;;y ;;gosh (append x y) ;;(1 2 3 4 5 6) ;;gosh (cons x y) ;;((1 2 3) 4 5 6) ;;gosh (list x y) ;;((1 2 3) (4 5 6)) Exercise 2.27 (define (deep-reverse l) (if (null? l) '() (append (deep-reverse (cdr l)) (list (if (pair? (car l)) (deep-reverse (car l)) (car l)))))) ;;gosh (define x '(( 1 (1 2)) ((3 4) 4))) ;;x ;;gosh x ;;((1 (1 2)) ((3 4) 4)) ;;gosh (deep-reverse x) ;;((4 (4 3)) ((2 1) 1)) kacchi氏の解答のほうがきれい。 Exercise 2.28 (define (fringe tree) (cond ((null? tree) '()) ((pair? tree) (append (fringe (car tree)) (fringe (cdr tree)))) (else (list tree)))) ;;gosh x ;;((1 (1 2)) ((3 4) 4)) ;;gosh (fringe x) ;;(1 1 2 3 4 4) ;;gosh (fringe (list x x)) ;;(1 1 2 3 4 4 1 1 2 3 4 4) Exercise 2.29 ;; constructor (define (make-mobile left right) (list left right)) (define (make-branch length structure) (list length structure)) ;; a. seletor (define (left-branch m) (car m)) (define (right-branch m) (cadr m)) (define (branch-length b) (car b)) (define (branch-structure b) (cadr b)) ;; b. total-weight (define (total-weight m) (let ((left-s (branch-structure (left-branch m))) (right-s (branch-structure (right-branch m)))) (+ (if (number? left-s) left-s (total-weight left-s)) (if (number? right-s) right-s (total-weight right-s))))) ;; c. balanced? (define (balanced? m) (define (rec m) (let ((left (branch-structure (left-branch m))) (right (branch-structure (right-branch m)))) (let ((left-w (if (number? left) left (rec left))) (right-w (if (number? right) right (rec right))) (left-l (branch-length (left-branch m))) (right-l (branch-length (right-branch m)))) (if (and (number? left-w) (number? right-w) (= (* left-w left-l) (* right-w right-l))) (+ left-w right-w) #f)))) (number? (rec m))) ;; d. ;; constructor (define (d) ;-----以下のconstructorとselectorを使う時はコメントアウトする。 (define (make-mobile left right) (cons left right)) (define (make-branch length structure) (cons length structure)) ;; seletor (define (left-branch m) (car m)) (define (right-branch m) (cdr m)) (define (branch-length b) (car b)) (define (branch-structure b) (cdr b)) ) ;------ ;; test data -- 長さ １ 数字 ： 錘 ;; --+------ ;; | | ;; ----+-- 2 ;; | | ;; 2 4 (define bl2w2 (make-branch 2 2)) (define bl1w4 (make-branch 1 4)) (define mbl2w2bl1w4 (make-mobile bl2w2 bl1w4)) (define bl3w2 (make-branch 3 2)) (define bl1mbl2w2bl1w4 (make-branch 1 mbl2w2bl1w4)) (define m-top (make-mobile bl1mbl2w2bl1w4 bl3w2)) (define bl2w3 (make-branch 2 3)) (define mbl2w3bl1w4 (make-mobile bl2w3 bl1w4)) (define bl1mbl2w3bl1w4 (make-branch 1 mbl2w3bl1w4)) (define m-top-x (make-mobile bl1mbl2w3bl1w4 bl3w2)) ;;gosh (total-weight m-top) ;;8 ;;gosh (total-weight m-top-x) ;;9 ;;gosh (balanced? m-top) ;;#t ;;gosh (balanced? m-top-x) ;;#f Exercise 2.30 (define (square-tree-d t) (cond ((null? t) '()) ((number? t) (square t)) (else (cons (square-tree-d (car t)) (square-tree-d (cdr t)))))) (define (square-tree-m t) (map (lambda (st) (if (pair? st) (square-tree-m st) (square st))) t)) ;;gosh tree ;;(1 (2 (3 4) 5) (6 7)) ;;gosh (square-tree-d tree) ;;(1 (4 (9 16) 25) (36 49)) ;;gosh (square-tree-m tree) ;;(1 (4 (9 16) 25) (36 49)) Exercise 2.31 (define (tree-map f t) (map (lambda (st) (if (pair? st) (tree-map f st) (f st))) t)) ;;gosh (define tree (list 1 (list 2 (list 3 4) 5) (list 6 7))) ;;tree ;;gosh (define (square-tree tree) (tree-map square tree)) ;;square-tree ;;gosh (square-tree tree) ;;(1 (4 (9 16) 25) (36 49)) Exercise 2.32 (define (subsets s) (if (null? s) (list '()) (let ((rest (subsets (cdr s)))) (append rest (map (lambda (x) (cons (car s) x)) rest))))) ;;gosh (display (subsets '(1 2 3))) ;;(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))# undef ;;letの変数の値を求める処理が引数のcdrをとる再帰となっているので、 ;; sの値 restの値 mapの結果 subsetsの値 ;; 1. '() - - (()) ;; 2. (3) (()) (3) (() (3)) ;; 3. (2 3) (() (3)) ((2) (2 3)) (() (3) (2) (2 3)) ;; 4. (1 2 3) (() (3) (2) (2 3)) ((1) (1 3) (1 2) (1 2 3)) (() (3) (2) (2 3) (1) (1 3) ;; (1 2) (1 2 3) Exercise 2.33 (define (map-n p sequence) (accumulate (lambda (x y) (cons (p x) y)) '() sequence)) (define (append-n seq1 seq2) (accumulate cons seq2 seq1)) (define (length-n sequence) (accumulate (lambda (x y) (+ 1 y)) 0 sequence)) ;;gosh (map-n cadr '((a b) (d e) (g h))) ;;(b e h) ;;gosh (append-n '(a (b)) '((c))) ;;(a (b) (c)) ;;gosh (length-n '(a (b) (c d e))) ;;3 Exercise 2.34 (define (horner-eval x coefficient-sequence) (accumulate (lambda (this-coeff higher-term) (+ this-coeff (* x higher-term))) 0 coefficient-sequence)) ;;gosh (horner-eval 2 (list 1 3 0 5 0 1)) ;;79 Exercise 2.35 (define (count-leaves-a t) (accumulate + 0 (map (lambda (x) (if (pair? x) (count-leaves-a x) 1)) t))) ;;gosh (define x (cons (list 1 2) (list 3 4))) ;;x ;;gosh x ;;((1 2) 3 4) ;;gosh (count-leaves-a x) ;;4 ;;gosh (count-leaves-a (list x x)) ;;8 Exercise 2.36 (define (accumulate-n op init seqs) (if (null? (car seqs)) '() (cons (accumulate op init (map car seqs)) (accumulate-n op init (map cdr seqs))))) ;;gosh (accumulate-n + 0 s) ;;(22 26 30) Exercise 2.37 (define (dot-product v w) (accumulate + 0 (map * v w))) (define (matrix-*-vector m v) (map (lambda (w) (dot-product v w)) m)) (define (transpose mat) (accumulate-n cons '() mat)) (define (matrix-*-matrix m n) (let ((cols (transpose n))) (map (lambda (v) (map (lambda (w) (dot-product v w)) cols)) m))) ;;gosh m ;;((1 2 3 4) (4 5 6 6) (6 7 8 9)) ;;gosh v ;;(2 3 4 5) ;;gosh (matrix-*-vector m v) ;;(40 77 110) ;;gosh (transpose m) ;;((1 4 6) (2 5 7) (3 6 8) (4 6 9)) ;;gosh (matrix-*-matrix m (transpose m)) ;;((30 56 80) (56 113 161) (80 161 230)) Exercise 2.38 (define (fold-right op init seq) (accumulate op init seq)) (define (fold-left op init seq) (define (iter result rest) (if (null? rest) result (iter (op result (car rest)) (cdr rest)))) (iter init seq)) ;; 交換則が成り立つかな？ ;;gosh (fold-right / 1 (list 1 2 3)) ;;3/2 ;;gosh (fold-left / 1 (list 1 2 3)) ;;1/6 ;;gosh (fold-right list '() (list 1 2 3)) ;;(1 (2 (3 ()))) ;;gosh (fold-left list '() (list 1 2 3)) ;;(((() 1) 2) 3) ;;gosh (fold-right + 0 (list 1 2 3)) ;;6 ;;gosh (fold-left + 0 (list 1 2 3)) ;;6 Exercise 2.39 (define (reverse-r seq) (fold-right (lambda (x y) (append y (list x))) '() seq)) (define (reverse-l seq) (fold-left (lambda (x y) (cons y x)) '() seq)) ;;gosh (define seq '(1 2 3 4)) ;;seq ;;gosh (reverse-r seq) ;;(4 3 2 1) ;;gosh (reverse-l seq) ;;(4 3 2 1) Exercise 2.40 (define (uniqe-pairs n) (flatmap (lambda (i) (map (lambda (j) (list i j)) (enumerate-interval 1 (- i 1)))) (enumerate-interval 1 n))) (define (prime-sum-pairs n) (map make-pair-sum (filter prime-sum? (uniqe-pairs n)))) (define (make-pair-sum pair) (list (car pair) (cadr pair) (+ (car pair) (cadr pair)))) (define (prime-sum? pair) (prime? (+ (car pair) (cadr pair)))) ;;gosh (uniqe-pairs 5) ;;((2 1) (3 1) (3 2) (4 1) (4 2) (4 3) (5 1) (5 2) (5 3) (5 4)) ;;gosh (prime-sum-pairs 6) ;;((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7) (6 1 7) (6 5 11)) Exercise 2.41 (define (ordered-triples-sum n s) (filter (lambda (triples) (let ((i (car triples)) (j (cadr triples)) (k (caddr triples))) (if (= (+ i j k) s) #t #f))) (flatmap (lambda (k) (flatmap (lambda (j) (map (lambda (i) (list i j k)) (enumerate-interval 1 j))) (enumerate-interval 1 k))) (enumerate-interval 1 n)))) ;;gosh (ordered-triples-sum 6 8) ;;((2 3 3) (2 2 4) (1 3 4) (1 2 5) (1 1 6)) ;;だと思っていたら、distinctを理解していなかった。 (define (ordered-triples-sum n s) (filter (lambda (triples) (let ((i (car triples)) (j (cadr triples)) (k (caddr triples))) (if (and ( i j k) (= (+ i j k) s)) #t #f))) (flatmap (lambda (k) (flatmap (lambda (j) (map (lambda (i) (list i j k)) (enumerate-interval 1 j))) (enumerate-interval 1 k))) (enumerate-interval 1 n)))) ;;gosh (ordered-triples-sum 6 8) ;;((1 3 4) (1 2 5)) Exercise 2.42 (define empty-board '()) (define (safe? k positions) (let ((qk (car positions))) (define (safe-colum? i rest-of-colums) (cond ((null? rest-of-colums) #t) (else (let ((qi (car rest-of-colums))) (cond ((or (= qk qi) (= (+ qk i) qi) (= (- qk i) qi)) #f) (else (safe-colum? (+ i 1) (cdr rest-of-colums)))))))) ;; (display positions) (display (safe-colum? 1 (cdr positions)))(newline) (safe-colum? 1 (cdr positions)))) (define (adjoin-position new-row k rest-of-queens) (cons new-row rest-of-queens)) (define (queens board-size) (define (queen-cols k) (if (= k 0) (list empty-board) (filter (lambda (positions) (safe? k positions)) (flatmap (lambda (rest-of-queens) (map (lambda (new-row) (adjoin-position new-row k rest-of-queens)) (enumerate-interval 1 board-size))) (queen-cols (- k 1)))))) (queen-cols board-size)) ;;gosh (queens 4) ;;((3 1 4 2) (2 4 1 3)) ;;gosh (write (queens 5)) ;;((4 2 5 3 1) (3 5 2 4 1) (5 3 1 4 2) (4 1 3 5 2) (5 2 4 1 3) (1 4 2 5 3) (2 5 3 1 4) (1 3 5 2 4) (3 1 4 2 5) (2 4 1 3 5))# undef ;;gosh (length (queens 8)) ;;92 kが使えてない！ 対称形の考慮など奥深そうな問題だけど・・・ Exercise 2.43 ;; queen-colsの呼ばれる回数は、board-sizeをnとすると ;; queens-a ： カラムに対して一度 - 1+n ;; queens-b ： カラムの各ロウに対して再帰的にカラム数だけ - ;; 1+n^1+n^2+n^3+...+n^n ;; 時間の推定は？？？ (define (queens-a board-size) (let ((cc 0) (sc 0)) (define (queen-cols k) (set! cc (+ cc 1)) ;;(display "queens-cols ") (display k) (display " ") (if (= k 0) (list empty-board) (filter (lambda (positions) (set! sc (+ sc 1)) (safe? k positions)) (flatmap (lambda (rest-of-queens) (map (lambda (new-row) (adjoin-position new-row k rest-of-queens)) (enumerate-interval 1 board-size))) (queen-cols (- k 1)))))) (queen-cols board-size) (display cc) (display " ") (display sc) (display " ") (display (* 1.0 (/ sc cc))))) (define (queens-b board-size) (let ((cc 0) (sc 0)) (define (queen-cols k) (set! cc (+ cc 1)) ;; (display "queens-cols ") (display k) (display " ") (if (= k 0) (list empty-board) (filter (lambda (positions) (set! sc (+ sc 1)) (safe? k positions)) (flatmap (lambda (new-row) (map (lambda (rest-of-queens) (adjoin-position new-row k rest-of-queens)) (queen-cols (- k 1)))) (enumerate-interval 1 board-size))))) (queen-cols board-size) (display cc) (display " ") (display sc)(display " ") (display (* 1.0 (/ sc cc))))) ;;gosh (queens-a 3) ;;4 18# undef ;;gosh (queens-b 3) ;;40 60# undef ;;gosh (queens-a 4) ;;5 60# undef ;;gosh (queens-b 4) ;;341 624# undef ;;gosh (queens-a 5) ;;6 220# undef ;;gosh (queens-b 5) ;;3906 8160# undef ;;gosh (queens-a 6) ;;7 894# undef ;;gosh (queens-b 6) ;;55987 128904# undef Exercise 2.44 (define (up-split painter n) (if (= n 0) painter (let ((smaller (up-split painter (- n 1)))) (below painter (beside smaller smaller))))) Exercise 2.45 (define (split op1 op2) (lambda (painter n) (if (= n 0) painter (let ((smaller ((split op1 op2) painter (- n 1)))) (op1 painter (op2 smaller smaller)))))) (define right-split (split beside below)) (define up-split (split below beside)) ;;(plot (corner-split wave 4)) Exercise 2.46 ;; constructor (define (make-vect x y) (cons x y)) ;; selectors (define (xcor-vect v) (car v)) (define (ycor-vect v) (cdr v)) ;; operations (define (add-vect v1 v2) (make-vect (+ (xcor-vect v1) (xcor-vect v2)) (+ (ycor-vect v1) (ycor-vect v2)))) (define (sub-vect v1 v2) (add-vect v1 (scale-vect -1 v2))) (define (scale-vect s v) (make-vect (* s (xcor-vect v)) (* s (ycor-vect v)))) ;;gosh (define v21 (make-vect 2 1)) ;;v21 ;;gosh v21 ;;(2 . 1) ;;gosh (xcor-vect v21) ;;2 ;;gosh (ycor-vect v21) ;;1 ;;gosh (define v-24 (make-vect -2 4)) ;;v-24 ;;gosh (add-vect v21 v-24) ;;(0 . 5) ;;gosh (sub-vect v21 v-24) ;;(4 . -3) ;;gosh (scale-vect 2 v21) ;;(4 . 2) Exercise 2.47 ;; constructor (define (make-frame origin edge1 edge2) (list origin edge1 edge2)) ;; selectors (define (origin-frame f) (car f)) (define (edge1-frame f) (cadr f)) (define (edge2-frame f) (caddr f)) ;; constructor-2 (define (make-frame-p origin edge1 edge2) (cons origin (cons edge1 edge2))) ;; selectors (define (origin-frame-p f) (car f)) (define (edge1-frame-p f) (cadr f)) (define (edge2-frame-p f) (cddr f)) ;;gosh (define origin (make-vect 1 1)) ;;origin ;;gosh (define edge1 (make-vect 2 2)) ;;edge1 ;;gosh (define edge2 (make-vect 3 3)) ;;edge2 ;;gosh (define frame (make-frame origin edge1 edge2)) ;;frame ;;gosh (origin-frame frame) ;;(1 . 1) ;;gosh (edge1-frame frame) ;;(2 . 2) ;;gosh (edge2-frame frame) ;;(3 . 3) ;;gosh (define frame-p (make-frame-p origin edge1 edge2)) ;;frame-p ;;gosh (origin-frame-p frame-p) ;;(1 . 1) ;;gosh (edge1-frame-p frame-p) ;;(2 . 2) ;;gosh (edge2-frame-p frame-p) ;;(3 . 3) Exercise 2.48 ;; constructor (define (make-segment sv ev) (cons sv ev)) ;; selectors (define (start-segment s) (car s)) (define (end-segment s) (cdr s)) Exercise 2.49 ;; a (define frame-painter (segments- painter (list (make-segment (make-vect 0 0) (make-vect 1 0)) (make-segment (make-vect 1 0) (make-vect 1 1)) (make-segment (make-vect 1 1) (make-vect 0 1)) (make-segment (make-vect 0 1) (make-vect 0 0))))) ;; b (define X-painter (segments- painter (list (make-segment (make-vect 0.0 0.0) (make-vect 1.0 1.0)) (make-segment (make-vect 1.0 0.0) (make-vect 0.0 1.0))))) ;; c (define diamond-painter (segments- painter (list (make-segment (make-vect 0.0 0.5) (make-vect 0.5 0.0)) (make-segment (make-vect 0.5 0.0) (make-vect 1.0 0.5)) (make-segment (make-vect 1.0 0.5) (make-vect 0.5 1.0)) (make-segment (make-vect 0.5 1.0) (make-vect 0.0 0.5))))) ;; d naoya_t氏に感謝 (define wave (segments- painter (append (make-path (make-vect 0.0 0.86) (make-vect 0.16 0.60) (make-vect 0.28 0.65) (make-vect 0.42 0.65) (make-vect 0.35 0.86) (make-vect 0.42 1.0)) (make-path (make-vect 0.58 1.0) (make-vect 0.65 0.86) (make-vect 0.58 0.65) (make-vect 0.76 0.65) (make-vect 1.0 0.35)) (make-path (make-vect 1.0 0.14) (make-vect 0.60 0.46) (make-vect 0.76 0.0)) (make-path (make-vect 0.58 0.0) (make-vect 0.50 0.17) (make-vect 0.42 0.0)) (make-path (make-vect 0.24 0.0) (make-vect 0.35 0.51) (make-vect 0.30 0.59) (make-vect 0.16 0.41) (make-vect 0.0 0.65)) ))) ;;(plot wave) Exercise 2.50 (define (flip-horiz painter) (transform-painter painter (make-vect 1.0 0.0) (make-vect 0.0 0.0) (make-vect 1.0 1.0))) (define (rotate180 painter) (flip-horiz (flip-vert painter))) (define (rotate270 painter) (rotate90 (rotate180 painter))) ;;(plot (rotate180 wave)) ;;(plot (rotate270 wave)) Exercise 2.51 (define (below p1 p2) (let ((split-point (make-vect 0.0 0.5))) (let ((paint-lower (transform-painter p1 (make-vect 0.0 0.0) (make-vect 1.0 0.0) split-point)) (paint-upper (transform-painter p2 split-point (make-vect 1.0 0.5) (make-vect 0.0 1.0)))) (lambda (frame) (paint-lower frame) (paint-upper frame))))) (define (below1 p1 p2) (rotate90 (beside (rotate270 p1) (rotate270 p2)))) ;;(plot (below wave wave)) Exercise 2.51 ;; a (define wave2 (segments- painter (append (make-path (make-vect 0.0 0.86) (make-vect 0.16 0.60) (make-vect 0.28 0.65) (make-vect 0.42 0.65) (make-vect 0.35 0.86) (make-vect 0.42 1.0)) (make-path (make-vect 0.58 1.0) (make-vect 0.65 0.86) (make-vect 0.58 0.65) (make-vect 0.76 0.65) (make-vect 1.0 0.35)) (make-path (make-vect 1.0 0.14) (make-vect 0.60 0.46) (make-vect 0.76 0.0)) (make-path (make-vect 0.58 0.0) (make-vect 0.50 0.17) (make-vect 0.42 0.0)) (make-path (make-vect 0.24 0.0) (make-vect 0.35 0.51) (make-vect 0.30 0.59) (make-vect 0.16 0.41) (make-vect 0.0 0.65)) (make-path (make-vect 0.45 0.73) (make-vect 0.50 0.75) (make-vect 0.55 0.73)) ))) ;;(plot wave2) ;; b (define (corner-split painter n) (if (= n 0) painter (let ((up (up-split painter (- n 1))) (right (right-split painter (- n 1))) (corner (corner-split painter (- n 1)))) (beside (below painter up) (below right corner))))) ;;(plot (corner-split wave2 4)) ;; c (define (square-limit painter n) (let ((combine4 (square-of-four flip-horiz identity rotate180 flip-vert))) (combine4 (corner-split (flip-horiz painter) n)))) ;;(plot (square-limit wave2 0))

• sicpstudygroup @ ウィキ - naga:4-1/4-24

  https://w.atwiki.jp/sicpstudygroup/pages/83.html

  naga Todo 4.10 4.16 Exercise 4.1 (define (list-of-value-l exps env) (if (no-operands? exps) () (let ((val (Eval (first-operand exps) env))) (cons val (list-of-values-l (rest-operands exps) env))))) (define (list-of-values-r exps env) (reverse (list-of-values-l (reverse exps) env))) ;;(define list-of-values list-of-vaules-l) ;;(define list-of-values list-of-values-r) ;; list と display と newline を primitive-procedures に登録して ;; list-of-values を list-of-values-l に変更すると ;;;M-Eval input (define (show x) (display x) (newline) x) ;;;M-Eval value ok ;;;M-Eval input (define exps (list (show 1) (show 2) (show 3))) 1 2 3 ;;;M-Eval value ok ;; list-of-values を list-of-values-r に変更すると ;;;M-Eval input (define exps (list (show 1) (show 2) (show 3))) 3 2 1 ;;;M-Eval value ok Exercise 4.2 ;;a. application?の判定を(pair? exp)で行っているため(define x 3)もapplicationと判定される。 ;;b. application?の判定と処理をassignment?の前に移動 ;; application?, operator, operandsを次のように変更 (define (application? exp) (tagged-list? exp call)) (define (operator exp) (cadr exp)) (define (operands exp) (cddr exp)) ;; + を primitive-procedures に登録して ;;;M-Eval input (call + 1 2) ;;;M-Eval value 3 Exercise 4.3 (define (get tag) ((operation-table lookup-proc) *eval* tag)) (define (put tag act) ((operation-table insert-proc!) *eval* tag act)) (define (tag exp) (car exp)) (define (Evalx exp env) ;;(display exp)(newline) (cond ((self-evaluating? exp) exp) ;ok ((variable? exp) (lookup-variable-value exp env)) ;ok ((get (tag exp)) ((get (tag exp)) exp env)) ((application? exp) ;ok (Apply (Eval (operator exp) env) (list-of-values (operands exp) env))) (else #| (error "Unknowen expression type -- EVAL" exp) |# (display "Unknowen expression type -- EVAL ") (display exp) (newline) ))) (define Eval Evalx) ;; Evalx を Eval にする。 (define (text-of-quotationx exp env) (cadr exp)) (put quote text-of-quotationx) (put set! eval-assignment) (put define eval-definition) (put if eval-if) (define (eval-lambda exp env) (make-procedure (lambda-parameters exp) (lambda-body exp) env)) (put lambda eval-lambda) (define (eval-begin exp env) (eval-sequence (begin-actions exp) env)) (put begin eval-begin) (define (eval-cond exp env) (Eval (cond- if exp) env)) (put cond eval-cond) ;;;M-Eval input (1 2 3) ;;;M-Eval value (1 2 3) ;;;M-Eval input (define a 1) ;;;M-Eval value ok ;;;M-Eval input a ;;;M-Eval value 1 ;;;M-Eval input (set! a 2) ;;;M-Eval value ok ;;;M-Eval input a ;;;M-Eval value 2 ;;;M-Eval input (if #t 1 2) ;;;M-Eval value 1 ;;;M-Eval input ((lambda (x) (+ x 2)) 4) ;;;M-Eval value 6 ;;;M-Eval input (begin (display 1) (display 2)) 12;;;M-Eval value # undef ;;;M-Eval input (cond ((eq? a 1) one) ((eq? a 2) two) (else ?)) ;;;M-Eval value two Exercise 4.4 ;; syntax procedures evaluation procedures ;; Evalのcond?の判定の次に、次の2つを追加 ((and? exp) (eval-and exp env)) ((or? exp) (eval-or exp env)) ;; (define (and? exp) (tagged-list? exp and)) (define (or? exp) (tagged-list? exp or)) (define (tests exp) (cdr exp)) (define (first-test tests) (car tests)) (define (rest-tests tests) (cdr tests)) (define (eval-and exp env) (if (null? (tests exp)) true (eval-logical and (tests exp) env))) (define (eval-or exp env) (if (null? (tests exp)) false (eval-logical or (tests exp) env))) (define (eval-logical op tests env) (let ((val (Eval (first-test tests) env))) (cond ((null? (rest-tests tests)) val) ((or (and (eq? op and) (not (eq? val false))) (and (eq? op or) (eq? val false))) (eval-logical op (rest-tests tests) env)) (else val)))) ;;;M-Eval input (and) ;;;M-Eval value #t ;;;M-Eval input (and 1 2 3) ;;;M-Eval value 3 ;;;M-Eval input (and 1 false 3) ;;;M-Eval value #f ;;;M-Eval input (or) ;;;M-Eval value #f ;;;M-Eval input (or 1 2 3) ;;;M-Eval value 1 ;;;M-Eval input (or false 1) ;;;M-Eval value 1 ;;;M-Eval input (or false false) ;;;M-Eval value #f ;; derived expressions ;; Evalのcond?の判定の次に、次の2つを追加。上のtests, first-test, rest-testsも使用 ((and? exp) (Eval (and- if (tests exp)) env)) ((or? exp) (Eval (or- if (tests exp)) env)) ;; (define (and- if tests) (cond ((null? tests) true) ((null? (rest-tests tests)) (first-test tests)) (else (make-if (first-test tests) (and- if (rest-tests test)) false)))) (define (or- if tests) (cond ((null? tests) false) ((null? (rest-tests tests)) (first-test tests)) (else (cons (make-lambda (list result-test) (list (make-if result-test result-test (or- if (rest-tests tests))))) (list (first-test tests)))))) ;;;M-Eval input (and) ;;;M-Eval value #t ;;;M-Eval input (and 1 2 3) ;;;M-Eval value 3 ;;;M-Eval input (and 1 false 3) ;;;M-Eval value #f ;;;M-Eval input (or) ;;;M-Eval value #f ;;;M-Eval input (or 1 2 3) ;;;M-Eval value 1 ;;;M-Eval input (or false 1) ;;;M-Eval value 1 ;;;M-Eval input (or false false) ;;;M-Eval value #f Exercise 4.5 ;; expand-clauses の make-if の前に (if (eq? (cond-actions first) = ) (cons (make-lambda (list testr) (list (make-if testr (list (cadr (cond-actions first)) testr) (expand-clauses rest)))) (list (cond-predicate first))) ;; を追加 ;;;M-Eval input (cond ((assoc b ((a 1) (b 2))) = cadr) (else false)) ;;;M-Eval value 2 Exercise 4.6 ;; Eval の cond? の判定の次に、次の判定を追加 ((let? exp) (Eval (let- combination exp) env)) ;; (define (let? exp) (tagged-list? exp let)) (define (let-bindings exp) (cadr exp)) (define (let-body exp) (cddr exp)) (define (let- combination exp) (let ((bindings (let-bindings exp))) (cons (make-lambda (map car bindings) (let-body exp)) (map cadr bindings)))) ;;;M-Eval input (let ((x 2) (y 3)) (+ x y)) ;;;M-Eval value 5 Exercise 4.7 ;; (let* (( var1 exp1 ) ( var2 exp2 ) ... ( varn expn )) body ) ;; = (let (( var1 exp1 )) (let (( var2 exp2)) ( ... ;; (let (( varn expn )) body ) ... ))) ;; Eval の let? の次に、次の判定を追加 ((let*? exp) (Eval (let*- nested-lets exp) env)) ;; (define (let*? exp) (tagged-list? exp let*)) (define (make-let bindings letbody) (cons let (cons bindings letbody))) (define (let*- nested-lets exp) (define (rec bindings) (if (eq? (length bindings) 1) (make-let bindings (let-body exp)) (let ((first (car bindings)) (rest (cdr bindings))) (make-let (list first) (list (rec rest)))))) (rec (let-bindings exp))) ;;;M-Eval input (let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z)) ;;;M-Eval value 39 Exercise 4.8 ;; (let var (( var1 exp1 ) ... ( varn expn)) body ) ;; = ((lambda () (define ( var var1 ... varn ) body ) ;; ( var exp1 ... expn ))) ;; selector の追加 (define (nlet-bindings exp) (caddr exp)) (define (nlet-body exp) (cdddr exp)) (define (nlet-name exp) (cadr exp)) ;; let- combination の変更 (define (let- combination exp) (if (pair? (cadr exp)) ;; normal-let (let ((bindings (let-bindings exp))) (cons (make-lambda (map car bindings) (let-body exp)) (map cadr bindings))) ;; named-let (let ((bindings (nlet-bindings exp)) (name (nlet-name exp))) (list (make-lambda () (list (cons define (cons (cons name (map car bindings)) (nlet-body exp))) (cons name (map cadr bindings)))) )) )) ;;;M-Eval input (define (fib n) (let fib-iter ((a 1) (b 0) (count n)) (if (= count 0) b (fib-iter (+ a b) a (- count 1))))) ;;;M-Eval value ok ;;;M-Eval input (fib 6) ;;;M-Eval value 8 Exercise 4.9 ;; (do (( ver1 ini1 step1 ) ... ( vern inin stepn )) ;; ( test exp1 ... expn ) ;; cmd1 ... cmdn ) ;;= (let iter (( ver1 ini1 ) ... ( vern inin )) ;; (if test ;; (begin exp1 ... expn ) ;; (begine cmd1 ... cmdn (iter step1 ... stepn )))) ;; Eval に次を追加 ((do? exp) (Eval (do- nlet exp) env)) ;; (define (make-nlet name bindings exps) (list let name bindings exps)) (define (do? exp) (tagged-list? exp do)) (define (do-bindings exp) (cadr exp)) (define (do-test-c exp) (caddr exp)) (define (do-cmds exp) (cdddr exp)) (define (do- nlet exp) (make-nlet iter (map (lambda (x) (list (car x) (cadr x))) (do-bindings exp)) (make-if (car (do-test-c exp)) (make-begin (cdr (do-test-c exp))) (make-begin (append (do-cmds exp) (list (cons iter (map (lambda (x) (if (eq? (cddr x) ()) (car x) (caddr x))) (do-bindings exp))))))))) ;; primitive-procedures に make-vector と vector-set! を登録して ;;;M-Eval input (do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i)) ;;;M-Eval value #(0 1 2 3 4) ;;;M-Eval input (let ((x (1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))) ;;;M-Eval value 25 Exercise 4.10 Exercise 4.11 ;; 4.1.3 の encloseing-environment から define-variable! を以下で置換え (define (enclosing-environment env) (cdr env)) (define (first-frame env) (car env)) (define the-empty-environment ()) (define (make-frame variables values) (map cons variables values)) (define (add-binding-to-frame! var val frame) (set-cdr! frame (cons (car frame) (cdr frame))) (set-car! frame (cons var val))) (define (extend-environment vars vals base-env) (if (= (length vars) (length vals)) (cons (make-frame vars vals) base-env) (if ( (length vars) (length vals)) (error "Too many arguments supplied" vars vals) (error "Too few arguments supplied" vars vals)))) ;; frame を var で scan し、あれば部分リストを返す。 (define (scan-frame var frame) (cond ((null? frame) #f) ((eq? var (caar frame)) frame) (else (scan-frame var (cdr frame))))) (define (scan-env var env) (if (eq? env the-empty-environment) #f (let ((frame (scan-frame var (first-frame env)))) (if (eq? frame #f) (scan-env var (enclosing-environment env)) frame)))) (define (lookup-variable var env) (let ((frame (scan-env var env))) (if (eq? frame #f) (error "Unbound variable" var) (cdar frame)))) (define (set-variable-value! var val env) (let ((frame (scan-env var env))) (if (eq? frame #f) (error "Unbound variable -- SET!" val) (set-cdr! (car frame) val)))) (define (define-variable! var val env) (let ((frame (scan-frame var (first-frame env)))) (if (eq? frame #f) (add-binding-to-frame! var val (first-frame env)) (set-cdr! (car frame) val)))) ;; ;; (define env1 (extend-environment (a b c) (1 2 3) the-empty-environment)) (define env (extend-environment (e f g a) (4 5 6 7) env1)) ;;gosh (lookup-variable a env) ;;7 ;;gosh (lookup-variable e env) ;;4 ;;gosh (lookup-variable b env) ;;2 ;;gosh (set-variable-value! b 8 env) ;;# undef ;;gosh (set-variable-value! e 9 env) ;;# undef ;;gosh (lookup-variable b env) ;;8 ;;gosh (lookup-variable e env) ;;9 ;;gosh (define-variable! c 10 env) ;;# undef ;;gosh (define-variable! e 11 env) ;;# undef ;;gosh env ;;(((c . 10) (e . 11) (f . 5) (g . 6) (a . 7)) ((a . 1) (b . 8) (c . 3))) Exercise 4.12 ;; 4.1.3 の encloseing-environment から define-variable! を以下で置換え (define (enclosing-environment env) (cdr env)) (define (first-frame env) (car env)) (define the-empty-environment ()) ;; for variable-list value-list (define (first-var frame) (caar frame)) (define (first-val frame) (cadr frame)) (define (set-first-val! frame val) (set-car! (cdr frame) val)) (define (rest-frame frame) (cons (cdar frame) (cddr frame))) (define (empty-frame? frame) (equal? frame (cons () ()))) (define (make-frame variables values) (cons variables values)) (define (add-binding-to-frame! var val frame) (set-car! frame (cons var (car frame))) (set-cdr! frame (cons val (cdr frame)))) #| ;; for valiable value pair-list (define (first-var frame) (caar frame)) (define (first-val frame) (cdar frame)) (define (set-first-val! frame val) (set-cdr! (car frame) val)) (define (rest-frame frame) (cdr frame)) (define (empty-frame? frame) (eq? frame ())) (define (make-frame variables values) (map cons variables values)) (define (add-binding-to-frame! var val frame) (set-cdr! frame (cons (car frame) (cdr frame))) (set-car! frame (cons var val))) |# (define (extend-environment vars vals base-env) (if (= (length vars) (length vals)) (cons (make-frame vars vals) base-env) (if ( (length vars) (length vals)) (error "Too many arguments supplied" vars vals) (error "Too few arguments supplied" vars vals)))) ;; frame を var で scan し、あれば部分リストを返す。 (define (scan-frame var frame) (cond ((empty-frame? frame) #f) ((eq? var (first-var frame)) frame) (else (scan-frame var (rest-frame frame))))) (define (scan-env var env) (if (eq? env the-empty-environment) #f (let ((frame (scan-frame var (first-frame env)))) (if (eq? frame #f) (scan-env var (enclosing-environment env)) frame)))) (define (lookup-variable var env) (let ((frame (scan-env var env))) (if (eq? frame #f) (error "Unbound variable" var) (first-val frame)))) (define (set-variable-value! var val env) (let ((frame (scan-env var env))) (if (eq? frame #f) (error "Unbound variable -- SET!" val) (set-first-val! frame val)))) (define (define-variable! var val env) (let ((frame (scan-frame var (first-frame env)))) (if (eq? frame #f) (add-binding-to-frame! var val (first-frame env)) (set-first-val! frame val)))) ;; ;; (define env1 (extend-environment (a b c) (1 2 3) the-empty-environment)) (define env (extend-environment (e f g a) (4 5 6 7) env1)) ;;gosh (lookup-variable a env) ;;7 ;;gosh (lookup-variable e env) ;;4 ;;gosh (lookup-variable b env) ;;2 ;;gosh (set-variable-value! b 8 env) ;;# undef ;;gosh (set-variable-value! e 9 env) ;;# undef ;;gosh (lookup-variable b env) ;;8 ;;gosh (lookup-variable e env) ;;9 ;;gosh (define-variable! c 10 env) ;;# undef ;;gosh (define-variable! e 11 env) ;;# undef ;;gosh env ;;(((c e f g a) 10 11 5 6 7) ((a b c) 1 8 3)) ;;(((e . 11) (c . 10) (e . 9) (f . 5) (g . 6) (a . 7)) ((a . 1) (b . 8) (c . 3))) Exercise 4.13 ;; (make-unbound! var ) ;; a make-unboud! を呼び出したブロックで var が定義されていたら、その定義を ;; 削除しその値を返す。var が定義されていなければ、#f を返す。 ;; b make-unboud! を呼び出したスコープで var が定義されていたら、その最初の ;; 定義を削除しその値を返す。var が定義されていなければ、#fを返す。 ;; 他人に使ってもらうなら、安全性の観点から ａ だけど、何の役に立つのか??? ;; ;; Eval の ((definition? exp) (eval-definition exp env)) の次に以下を追加 ((unbound? exp) (eval-unbound exp env)) ;; (define (unbound? exp) (tagged-list? exp make-unbound!)) (define (unboud-variable exp) (cadr exp)) (define (eval-unbound exp env) (make-unbound! (unboud-variable exp) env)) (define (make-unbound!a var env) (let* ((frame (first-frame env)) (bind (scan-frame var frame))) (if (eq? bind #f) #f (begin (set-car! (car bind) *undef*) (cadr bind))))) (define (make-unbound!b var env) (let ((bind (scan-env var env))) (if (eq? bind #f) #f (begin (set-car! (car bind) *undef*) (cadr bind))))) (define make-unbound! make-unboud!a) ;; var を frame 内で scan し、あれば部分リスト(frame)を返す。 (define (scan-frame var frame) (cond ((null? frame) #f) ((eq? var (caar frame)) frame) (else (scan-frame var (cdr frame))))) ;; var を env 内で scan し、あれば部分リスト(frame)を返す。 (define (scan-env var env) (if (eq? env the-empty-environment) #f (let ((frame (scan-frame var (first-frame env)))) (if (eq? frame #f) (scan-env var (enclosing-environment env)) frame)))) ;; a ;;;M-Eval input (define a 1) ;;;M-Eval value ok ;;;M-Eval input (define (p) (define a 2) (display a) (display (make-unbound! a)) (display a) (display (make-unbound! a)) (display a) (display (make-unbound! a)) (display a)) ;;;M-Eval value ok ;;;M-Eval input (p) 221#f1#f1;;;M-Eval value # undef ;;;M-Eval input (make-unbound! b) ;;;M-Eval value #f ;; b ;;;M-Eval input (define a 1) ;;;M-Eval value ok ;;;M-Eval input (define (p) (define a 2) (display a) (display (make-unbound! a)) (display a) (display (make-unbound! a)) (display a) (display (make-unbound! a)) (display a)) ;;;M-Eval value ok ;;;M-Eval input (p) 2211 #!# Error Unbound variable a ;;;M-Eval input Exercise 4.14 ;; map は手続きを引数にとる。 ;; ベースシステムの map は手続きもベースシステムの形式であることを期待していると思われるが、 ;; mapをprimitive-proceduresに登録した場合は、与えられる手続きはSICP-schemeの形式であるため、 ;; 正常に動作できない。 ;;;M-Eval input (map car ((1 2) (3 4))) *** ERROR invalid application ((primitive # subr car ) (1 2)) ;;;M-Eval input (map (lambda (x) x) (1 2 3)) *** ERROR invalid application ((procedure (x) (x) (((false true car cdr cons null? eq? list cadr + - * = = assoc make-vector vector-set! display newline map) #f #t (primitive # subr car ) (primitive # subr cdr ) (primitive # subr cons ) (primitive # subr null? ) (primitive # subr eq? ) (primitive # subr list ) (primitive # subr cadr ) (primitive # subr + ) (primitive # subr - ) (primitive # subr * ) (primitive # subr = ) (primitive # subr = ) (primitive # subr assoc ) (primitive # subr make-vector ) (primitive # subr vector-set! ) (primitive # subr display ) (primitive # subr newline ) (primitive # subr map )))) 1) Exercise 4.15 ;;halt? が定義できるとすると ;;(try try) を実行すると、 ;;オブジェクト try を引数とした手続き try が halt（値を返す）なら ;;(run-forever)、すなわち永久にループし ;;haltでない（エラーまたは永久にループする）なら、’halted を返す ;;をいう矛盾した結果となる手続き try が定義できる。 ;;従って、 どのような 手続きとオブジェクトの組合せにも 正しく動作 ;;する halt? は定義できない。 Exercise 4.16 Exercise 4.17 #| (lambda vars (define u e1 ) (define v e2 ) e3 ) の e3 評価時の環境は g.e.[ ] ↑ [ vars ????] |u e1 | env→ [v e2 ] (lambda vars (let ((u *unassigned*) (v *unassigned*)) (set! u e1 ) (set! v e2 ) e3 )) の e3 評価時の環境は g.e.[ ] ↑ [ vars ????] ↑ [u e1 ] env→ [v e2 ] define は現在の環境(フレーム)に新たな binding を追加するが、 letは新たなフレームを作成しそこに bindingを追加するため2つの環境は異なる。 しかし look-up-value は現在の環境から g.e. に向かってリストをたどりながら var を探すために結果に差がでない。 新たなフレームを作らずに"simultaneous"scop rule を満足させるには (lambda vars (define u *unassigned*) (define v *unassigend*) (set! u e1 ) (set! v e2 ) e3 ) とする。 |# Exercise 4.18 (define (solve-a f y0 dt) (define y (integral (delay dy) y0 dt)) (define dy (stream-map f y)) y) ;; exercise方式 (define (solve-b f y0 dt) (let ((y *unassigned*) (dy *unassigned*)) (let ((*sysval1* (integral (delay dy) y0 dt)) (*sysval2* (stream-map f y))) ;← (set! y *sysval1*) (set! dy *sysval2*) y))) ;;←の部分でｙの評価が必要になりsymbolにcarを作用させようとして正しく動作しない。 ;; text方式 (define (solve-c f y0 dt) (let ((y *unassigned*) (dy *unassigned*)) (set! y (integral (delay dy) y0 dt)) (set! dy (stream-map f y)) y)) ;;正しく動作する。 (define (solve-d f y0 dt) (define dy (stream-map f y)) (define y (integral (delay dy) y0 dt)) y) ;;gosh (stream-ref (solve-a (lambda (y) y) 1 0.001) 1000) ;;*** ERROR pair required, but got # undef ;;Stack Trace ;;_______________________________________ ;; 0 (map stream-car argstreams) ;; At line 562 of ".//SICP3.scm" ;; 1 (stream-map f y) ;; At line 4 of "f /cygwin/home/xxxxx/SICP/3/w.scm" ;; 2 (solve-a (lambda (y) y) 1 0.001) ;; At line 34 of "(stdin)" ;;gosh (stream-ref (solve-b (lambda (y) y) 1 0.001) 1000) ;;*** ERROR pair required, but got *unassigned* ;;Stack Trace ;;_______________________________________ ;; 0 (map stream-car argstreams) ;; At line 562 of ".//SICP3.scm" ;; 1 (stream-map f y) ;; At line 11 of "f /cygwin/home/xxxxx/SICP/3/w.scm" ;; 2 (solve-b (lambda (y) y) 1 0.001) ;; At line 35 of "(stdin)" ;;gosh (stream-ref (solve-c (lambda (y) y) 1 0.001) 1000) ;;2.716923932235896 ;;gosh (stream-ref (solve-d (lambda (y) y) 1 0.001) 1000) ;;2.716923932235896 Exercise 4.19 ;; 脚注に答えが・・・ Exercise 4.20 ; a ;; (letrec (( var1 exp1 ) ( var2 exp2 ) ... ( varn expn )) body ) ;; = (let (( var1 *unassigned*) ( var2 *unassigned*) ... ( varn *unassigned*)) ;; (set! var1 exp1 ) (set! var2 exp2 ) ... (set! varn expn ) ;; body ) ;; Eval の let*? の次に、次の判定を追加 ((letrec? exp) (Eval (letrec- let exp) env)) ;; (define (letrec? exp) (tagged-list? exp letrec)) (define (letrec- let exp) (let ((bindings (map (lambda (x) (list (car x) *unassigned*)) (let-bindings exp))) (set!s (map (lambda (x) (make-set! (car x) (cadr x))) (let-bindings exp)))) (make-let bindings (append set!s (let-body exp))))) ;;;M-Eval input (letrec ((even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (odd? (lambda (n) (if (= n 0) false (even? (- n 1)))))) (even? 3) ;;;M-Eval value #f ; b (define (f x) (let ((evenx? (lambda (n) (if (= n 0) true (oddx? (- n 1))))) (oddx? (lambda (n) (if (= n 0) false (evenx? (- n 1)))))) (evenx? x))) ;;;; | 手続きを表す。 パラメタ・本体へのポインタ|環境へのポインタ ;;letrec の場合の (f 3) 実行時の環境 ;;g.e. [f ] ;; ↑ ;; [x 3 ] ;; ↑ ;; [enenx? +]→ ↓|← ;; | | p n ;; | | b (if (= n O) ... (oddx? (- n 1))))) ;;env [oddx? +]→ ↓|← ;; p n ;; b (if (= n 0) ... (evenx? (-n 1))))) ;; ;;let の場合の (f 3) 実行時の環境 ;;g.e. [f ] ;; ↑ ;; [x 3 ] ;; ↑ ↑ ↑ ;; [enenx? +]→ ↓ |+ | ;; | | p n | ;; | | b (if (= n O) ... (oddx? (- n 1))))) ;;env [oddx? +]→ ↓ | + ;; p n ;; b (if (= n 0) ... (evenx? (-n 1))))) ;; ;;letrec を let とした時の evenx?、oddx? それぞれに設定される手続きの環境は ;;let の変数の初期値は let と同じ環境で評価されるため、 ;;、引数 x に 3 が設定された環境（とグローバル環境）となる。 ;;そこには、evenx?、oddx?は束縛されていない。 ;;一方、letrec の場合は、evenx?、oddx? それぞれに設定される手続きの環境は ;;evenx?、oddx?に *unassigned* が（set!後は手続きに）格納されている環境と ;;なる。従って、letrec では変数の評価をしないような定義の仕方であれば、相互 ;;再帰的に定義できる。 ;;答えになっているか??? Exercise 4.21 ;; a ;;;M-Eval input ((lambda (n) ((lambda (fib) (fib fib n)) (lambda (fb k) (if (or (= k 1) (= k 2)) 1 (+ (fb fb (- k 1)) (fb fb (- k 2))))))) 10) ;;;M-Eval value 55 ;; b (define (f x) ((lambda (even? odd?) (even? even? odd? x)) (lambda (ev? od? n) (if (= n 0) true (od? ev? od? (- n 1)))) (lambda (ev? od? n) (if (= n 0) false (ev? ev? od? (- n 1)))))) ;;;M-Eval input (f 1) ;;;M-Eval value #f ;;;M-Eval input (f 2) ;;;M-Eval value #t Exercise 4.22 ;; analyze の cond に 以下を加える ((let? exp) (analyze (let- combination exp))) ;;;A-Eval input (let ((x 3) (y 4)) (display (+ x y)) (newline) (* x y)) 7 ;;;A-Eval value 12 Exercise 4.23 ;;exp を解析(analyze)したものを a_exp とすると (eval exp env) は (a_exp env) で得ることができる。(定義そのまま) ;; exp を ;; a (begin (exp1)) b (begin (exp1) (exp2)) c (begin (exp1) (exp2) (exp3)) ;; とすれば a_exp は ;; text-version では ;; a a_exp1 b (lambda (env) (a_exp1 env) (a_exp2 env)) ;; c (lambda (env) ((lambda (env) (a_exp1 env) (a_exp2 env)) env) (a_exp3 env)) ;; となり、 ;; Alyssa-version ではどれも (lambda (env) (execute-sequence procs env)) であり、 ;; procsが a (a_exp1) b (a_exp1 a_exp2) c (a_exp1 a_exp2 a_exp3) ;; となる。 ;; 従って (a_exp env) の評価では text-version では lambda による各手続きの実行、Alyssa-version では execute-sequence の制御の元での各手続きの1つ１つの順次実行となり、text-versionのほうが実行時間が短いと推測できる。 Exercise 4.24 ;;;M-Eval input (time (fib 1000)) # real -time 0.393 # user -time 0.391 # system-time 0.0 ;;;M-Eval value 43466557686937456435688527675040625802564660517371780402481729089536555417949051890403879840079255169295922593080322634775209689623239873322471161642996440906533187938298969649928516003704476137795166849228875 ;;;A-Eval input (time (fib 1000)) # real -time 0.22 # user -time 0.21999999999999975 # system-time 0.0 ;;;A-Eval value 43466557686937456435688527675040625802564660517371780402481729089536555417949051890403879840079255169295922593080322634775209689623239873322471161642996440906533187938298969649928516003704476137795166849228875 ;;50%弱が構文解析に使われている？

• sicpstudygroup @ ウィキ - naga:5-1/5-6

  https://w.atwiki.jp/sicpstudygroup/pages/38.html

  SICP naga Exercise 5.1 Exercise 5.2 (controller (assign product (const 1)) (assign counter (const 1)) test-counter (test (op ) (reg counter) (reg n)) (branch (label fact-done)) (assign product (op *) (reg product) (reg counter)) (assign counter (op +) (reg counter) (const 1)) (goto (label test-counter)) fact-done) Exercise 5.3 ;;; good-enough? improve are primitives (controller (assign guess (const 1.0)) test-guess (test (op good-enough?) (reg guess) (reg x)) (branch (label sqrt-done)) (assign guess (op improve) (reg guess) (reg x)) (goto (label test-guess)) sqrt-done) ;;; improve is primitive (controller (assign guess (const 1.0)) test-guess ;;(test (op good-enough?) (reg guess) (reg x)) (assign gw (op *) (reg guess) (reg guess)) (assign gw (op -) (reg gw) (reg x)) (assign gw (op abs) (reg gw)) (test (op ) (reg gw) (const 0.001)) (branch (label sqrt-done)) (assign guess (op improve) (reg guess) (reg x)) (goto (label test-guess)) sqrt-done) ;;; controller (controller (assign guess (const 1.0)) test-guess ;;(test (op good-enough?) (reg guess) (reg x)) (assign gw (op *) (reg guess) (reg guess)) (assign gw (op -) (reg gw) (reg x)) (assign gw (op abs) (reg gw)) (test (op ) (reg gw) (const 0.001)) (branch (label sqrt-done)) ;;(assign guess (op improve) (reg guess) (reg x)) (assign iw (op /) (reg guess) (reg x)) (assign guess (op average) (reg guess) (reg iw)) (goto (label test-guess)) sqrt-done) Exercise 5.4 a ;;(define (expt b n) ;; (if (= n 0) ;; 1 ;; (* b (expt b (- n 1))))) (controller (assign continue (label expt-done)) expt-loop (test (op =) (reg n) (const 0)) (branch (label immediate-answer)) (save continue) (assign continue (label afterexpt)) (assign n (op -) (reg n) (const 1)) (goto (label expt-loop)) afterexpt (restore continue) (assign val (op *) (reg b) (reg val)) (goto (reg continue)) immediate-answer (assign val (const 1)) (goto (reg continue)) expt-done) b ;;(define (expt b n) ;; (define (expt-iter counter product) ;; (if (= counter 0) ;; product ;; (expt-iter (- coutner 1) (* b product)))) ;; (expt-iter n 1)) (controller (assign counter (reg n)) (assign product (const 1)) expt-loop (test (op =) (reg counter) (const 0)) (branch (label expt-done)) (assign counter (op -) (reg counter) (const 1)) (assign product (op *) (reg b) (reg product)) (goto (label expt-loop)) expt-done) Exercise 5.5 ;;; factorial (controller (assign continue (label fact-done)) ; set up final return address fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) ;; Set up for the recursive call by saving n and continue. ;; Set up continue so that the computation will continue ;; at after-fact when the subroutine returns. a) (save continue) b) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact c) (restore n) d) (restore continue) e) (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)! (goto (reg continue)) ; return to caller base-case f) (assign val (const 1)) ; base case 1! = 1 (goto (reg continue)) ; return to caller fact-done) ;;; n=3 時の a),b),c),d),e),f) の stack と val の様子 a) ((label fact-done)) (?) b) (3 (label fact-done)) (?) a) ((label fact-after) 3 (label fact-done)) (?) b) (2 (label fact-after) 3 (label fact-done)) (?) f) (2 (label fact-after) 3 (label fact-done)) (1) c) ((label fact-after) 3 (label fact-done)) (1) d) (3 (label fact-done)) (1) e) (3 (label fact-done)) (2) c) ((label fact-done)) (2) d) () (2) e) () (6) ;;; fibonacci (controller (assign continue (label fib-done)) fib-loop (test (op ) (reg n) (const 2)) (branch (label immediate-answer)) ;; set up to compute Fib(n - 1) a) (save continue) (assign continue (label afterfib-n-1)) b) (save n) ; save old value of n c) (assign n (op -) (reg n) (const 1)); clobber n to n - 1 (goto (label fib-loop)) ; perform recursive call afterfib-n-1 ; upon return, val contains Fib(n - 1) d) (restore n) e) (restore continue) ;; set up to compute Fib(n - 2) f) (assign n (op -) (reg n) (const 2)) g) (save continue) (assign continue (label afterfib-n-2)) h) (save val) ; save Fib(n - 1) (goto (label fib-loop)) afterfib-n-2 ; upon return, val contains Fib(n - 2) i) (assign n (reg val)) ; n now contains Fib(n - 2) j) (restore val) ; val now contains Fib(n - 1) k) (restore continue) l) (assign val ; Fib(n - 1) + Fib(n - 2) (op +) (reg val) (reg n)) (goto (reg continue)) ; return to caller, answer is in val immediate-answer m) (assign val (reg n)) ; base case Fib(n) = n (goto (reg continue)) fib-done) ;;; n=3 時の a),b),c),d),e),f),g),h),i),j),k),l),m) の stack val と n の様子 a) ((label fib-done)) (?) (3) b) (3 (label fib-done)) (?) (3) c) ((3) (label fib-done)) (?) (2) a) ((label afterfib-n-1) 3 (label fib-done)) (?) (2) b) (2 (label afterfib-n-1) 3 (label fib-done)) (?) (2) c) (2 (label afterfib-n-1) 3 (label fib-done)) (?) (1) m) (2 (label afterfib-n-1) 3 (label fib-done)) (1) (1) d) ((label afterfib-n-1) 3 (label fib-done)) (1) (2) e) (3 (label fib-done)) (1) (2) f) (3 (label fib-done)) (1) (0) g) ((label afterfib-n-1) 3 (label fib-done)) (1) (0) h) (1 (label afterfib-n-1) 3 (label fib-done)) (1) (0) m) (1 (label afterfib-n-1) 3 (label fib-done)) (0) (0) i) (1 (label afterfib-n-1) 3 (label fib-done)) (0) (0) j) ((label afterfib-n-1) 3 (label fib-done)) (1) (0) k) (3 (label fib-done)) (1) (0) l) (3 (label fib-done)) (1) (0) d) ((label fib-done)) (1) (3) e) () (1) (3) f) () (1) (1) g) ((label fib-done)) (1) (1) h) (1 (label fib-done)) (1) (1) m) (1 (label fib-done)) (1) (1) i) (1 (label fib-done)) (1) (1) j) ((label fib-done)) (1) (1) k) () (1) (1) l) () (2) (1) Exercise 5.6 ;;; 下の←の２ヶ所 (controller (assign continue (label fib-done)) fib-loop (test (op ) (reg n) (const 2)) (branch (label immediate-answer)) ;; set up to compute Fib(n - 1) (save continue) (assign continue (label afterfib-n-1)) (save n) ; save old value of n (assign n (op -) (reg n) (const 1)); clobber n to n - 1 (goto (label fib-loop)) ; perform recursive call afterfib-n-1 ; upon return, val contains Fib(n - 1) (restore n) (restore continue) ; ← これと ;; set up to compute Fib(n - 2) (assign n (op -) (reg n) (const 2)) (save continue) ; ← これ (assign continue (label afterfib-n-2)) (save val) ; save Fib(n - 1) (goto (label fib-loop)) afterfib-n-2 ; upon return, val contains Fib(n - 2) (assign n (reg val)) ; n now contains Fib(n - 2) (restore val) ; val now contains Fib(n - 1) (restore continue) (assign val ; Fib(n - 1) + Fib(n - 2) (op +) (reg val) (reg n)) (goto (reg continue)) ; return to caller, answer is in val immediate-answer (assign val (reg n)) ; base case Fib(n) = n (goto (reg continue)) fib-done)

• 痛車プラモデル@wiki - GSRキャラクターカスタマイズシリーズ　1/24scale用デカール011～020

  https://w.atwiki.jp/itapura/pages/60.html

  011　装甲悪鬼　村正 http //www.goodsmileracing.com/products/gsr_ccs/011_124scale.html(2010/02/16登録) http //www.goodsmile.info/product/ja/2804/(同) 2010/03/29発売。 moeyo.com お台場に痛空母！？ アオシマ「フェイト FD3S RX-7」グッスマ「初音ミク デカール」等 痛車プラモの作例ズラリ！ 【第2回 痛Gふぇすた】(2009/10/05) 012　Racingミク http //www.goodsmileracing.com/products/gsr_ccs/012124scale.html(2010/04/23登録) http //www.goodsmile.info/product/ja/2853/(同) 2010/05/19発売。 従来のオフセット印刷から、今回以降シルクスクリーン印刷に。よって透けの問題が改善。 それまでGSRにおいて痛車模型関係を中心に主導権を振るっていた、専属カーモデラーであるPANTHER★PINKが、当商品を最後に退社。退社理由、並びに013と014が欠番(後に015・016と入れ違いで発売)になった事との関連は不明。 moeyo.com 4月24日のあみあみ予約開始情報(2010/04/24) 013　とある科学の超電磁砲 レールガン http //www.goodsmileracing.com/products/gsr_ccs/013124scale_1.html(2010/10/14登録) http //www.goodsmile.info/product/ja/2989/(同) 2010/12/21発売。当初の11月から延期。 　グッドスマイルカンパニー取り扱い11月発売予定商品　出荷予定日および発売月変更のご案内(2010/11/22) 　グッドスマイルカンパニー取り扱い12月発売予定商品　出荷予定日および発売月変更のご案内(2010/12/08) 014と共に、015・016とは順序が入れ違いで案内・発売。 御坂美琴と白井黒子中心。 バイナルグラフィックスは、御坂美琴の電撃をイメージした青白い稲光風であり、蛍光インクを使用して暗闇で浮かび上がる。 GSRや痛Gのロゴはないが、その代わりパロディステッカー風のデカールが豊富。 アオシマの「1/24痛車シリーズNo.SP　とある科学の超電磁砲＜レールガン＞　200系ハイエース スーパーGL 07カスタム」、フジミの「きゃら・de・CAR～る!! 22　とある科学の超電磁砲＜レールガン＞　スバル インプレッサ WRX STi」に続いての同一作品からの商品化であり、初の3社競合商品となる。 014　BEYONETTA http //www.goodsmileracing.com/products/gsr_ccs/014bayonetta124scale.html(2010/10/14登録) http //www.goodsmile.info/product/ja/2990/(同) 2010/12/15発売。上記「GSRキャラクターカスタマイズシリーズ013　とある科学の超電磁砲 レールガン 」と同時発表。 　グッドスマイルカンパニー取り扱い12月発売予定商品　出荷予定日および発売月変更のご案内(2010/12/08) 015や016とは順序が入れ違いで案内・発売。 015　魔法少女リリカルなのは The MOVIE 1st　高町なのは http //www.goodsmile.info/product/ja/2969/(2010/09/21登録) http //www.goodsmileracing.com/products/gsr_ccs/post_1.html(2010/09/24登録) 2010/11/17発売。当初の10月から延期。 　グッドスマイルカンパニー取り扱い10月発売予定商品出荷予定日および発売月変更のご案内(2010/10/22) 　グッドスマイルカンパニー取り扱い11月発売予定商品出荷予定日および発売月変更のご案内(2010/11/01) 当商品以降は、GSRと予てから交流のあった50 Miles Overによるデザイン。これが氏の商業初デヴュー作。 　　旧ウェブサイト「Misshapen Tuners」(旧ハンドルネームである「u-poko」名義。現在は放置状態だが、ごく稀に画像掲示板の業者広告スパムを削除する場合あり) 　　新ウェブサイト「STUDIO MOONBASE」、外部ウェブログ「ひ(仮)」(2009/12/11開設、「dodge69」名義) 　　みんカラ「Ride on Air」(50 Miles Over名義) 　　ツイッター(2010/07/02) 　2010/10/11未明に、みんカラとmixiを退会、ツイッターも名義を変更、行方を晦ます。理由は過去も度々あった、仲間内での問題行動に起因する不和と思われるが、詳細は不明。だがその度に、引退宣言をしながらもこっそりハンドルネームを変えて復帰してはよりを戻しており、現に翌月には復帰。従来の交友関係とよりを戻すのも時間の問題と思われる。 　　閉鎖予定のお知らせ(ひ(仮)、2010/10/13) アオシマの「1/24痛車シリーズNo.17　魔法少女リリカルなのは The MOVIE 1st 高町なのは　ランサーエボリューションⅩ(テン)」と同一作品・同一キャラクターで、且つ非常に近い発売時期。 　大きな違いは、バイナルグラフィックスはレイジングハート・カノンモードを図案化した硬質なデザインであり、タイトルやキャラクター名も硬質なデザインであり、代わりに魔方陣が殆どなく、変身途中と思しき全裸のなのはがあり、パロディステッカーを想定したデカールも豊富。 バイナルグラフィックスは中途半端なサイズであり、1/24に対してはどんなに切り詰めてもまだ大きく、1/32のバスやトラックに対してはやや小さい。色使いもなのはのバリアジャケットに準じているので、肝心のなのはを埋没させてしまう。従来には豊富にあったパロディステッカーや台詞デカールが少なくなり、余白も増えた。劇場版からの商品化であるにも係わらず、魔方陣はTV版。何より、隠蔽力の高いシルクスクリーン印刷を謳っている割に、従来ない程に下地が透ける。 GSRレポート 今月の新製品情報(2010/09/21) Ride on Air 晒しプレイ(ﾟ∀ﾟ)(2010/09/21) 016　魔法少女リリカルなのは The MOVIE 1st　フェイト・テスタロッサ http //www.goodsmile.info/product/ja/2970/(2010/09/21登録) http //www.goodsmileracing.com/products/gsr_ccs/016_the_movie_1st_124scale.html(2010/09/24登録) 2010/11/17発売。上記なのはと同時発売。 上記なのはデカールに方向性は準ずるが、バルディッシュを図案化したバイナルグラフィックスは、アオシマの「1/24痛車シリーズNo.12　魔法少女リリカルなのはStrikerS フェイト・T(テスタロッサ)・ハラオウン　FD3S RX-7 RE雨宮feat.ART FACTORY」の魔方陣バイナルグラフィックスを思わせる、ミューラル風デザインに。 017　Racingミク vol.2 http //www.goodsmile.info/product/ja/3015/(2010/11/11登録) http //www.goodsmileracing.com/products/gsr_ccs/017racing_vol2_124scale.html 2011/02/発売。 018　ブラック★ロックシューター http //www.goodsmile.info/product/ja/3071/(2011/01/12登録) http //www.goodsmileracing.com/products/gsr_ccs/018_124scale.html 2011/02/28発売。 アニメ版のイラストもあり。 「BRACKROCK(元ネタはBRIDGESTONE)」「BRS(同じくBBS)」等のパロディステッカーもあり。 グッドスマイルカンパニー取り扱い2011年2月発売予定商品出荷予定日および発売月変更のご案内(2011/02/16) 019　スーパーそに子 http //www.goodsmile.info/product/ja/3093/(2011/02/15登録) http //www.goodsmileracing.com/products/gsr_ccs/019_124scale.html(同) 2011/03/29発売。 　グッドスマイルカンパニー取り扱い2011年3月発売予定商品出荷予定日　および発売月変更のご案内(2011/03/17) グッドスマイルカンパニーとも付き合いの長いニトロプラスの、マスコットキャラクター。 020　侵略! イカ娘 http //www.goodsmile.info/product/ja/3094/(2011/02/15登録) http //www.goodsmileracing.com/products/gsr_ccs/020_124scale.html(同) 2011/03/29発売。 　グッドスマイルカンパニー取り扱い2011年3月発売予定商品出荷予定日　および発売月変更のご案内(2011/03/17) イカ娘と一体化した、浮世絵の波の様なバイナルグラフィック。位置関係を好きに動かす事も出来ず、貼る事の出来る場所もスケールも限られるが、重ね貼りによる下地の透けが気になるユーザーへの配慮と思われる。 「GESSO(元ネタはESSO)」「I.K.A.(同じくH.K.S.)」「烏賊改(同じく柿本改)」等のパロディデカールもあり。 名前 コメント - -

• todo314 @ ウィキ - Scalable Influence Maximization for Prevalent Viral Marketing in Large-Scale ...

  https://w.atwiki.jp/todo314/pages/36.html

  Scalable Influence Maximization for Prevalent Viral Marketing in Large-Scale Social Networks Wei Chen, Chi Wang, Yajun Wang In KDD 2010 概要 MIAモデルというのを使ってinfluence maximizationを高速化 アルゴリズム maximum influence paths (MIP) v- uへの伝搬は最短経路だけを考える しきい値θ以下の伝搬は無視する Dijkstraの途中で打ち切る maximum influence arborescence model influence spreadを以下で近似 $$ \sigma_M(S) = \sum_{v \in V}ap(v,S,MIIA(v,\theta)) $$ MIIA(v,θ) vからの最短経路木、ただしθ以下の確率は打ち切ってある ap(,,) Sがvをactivateする確率を最短経路木に沿って求める関数 再計算とかに工夫を入れて高速化 実験 グラフ NetHEPT,DBLP,Epinions,Amazon |V|=15K~655K,|E|=31K~2M 伝播モデル weighted cascade trivalency 結果 良い、割りと速い メモリ使用量（最短経路木の大きさ） O(√1/θ)っぽい 実行時間 O(1/θ)っぽい 結論 並列化 まとめ なんかすごそう感あるアルゴリズムだったが、最短経路木だけでいいのか？と思い始めた

• wyvernrpg@ ウィキ - Naga(ナーガ)

  https://w.atwiki.jp/wyvernrpg/pages/24.html

  概要 ナーガは古来の種族であり、知的なサーペントです。彼らは魔法の能力を持ち、別の姿形に変身する力を持っています。高いレベルではドラゴンに変身することができ、その他の強力な生物の姿を取ることさえできます。−公式より翻訳 変身能力、そして変身形に由来する高い素手格闘能力に長けた種族。 変身できる姿はレベルごとに種類が増えていき、"shift ○○○(変身対象)"と打つことによってその姿へシェイプシフトすることができる。 変身した姿は概ね強力で、特にレベル20を越えて使用可能になるヒドラはなんと噛み付きによる6連撃が可能であり、近接戦闘職の花形であるが、シェイプごとに使用可能な装備、サイズが変わることは、即ちレベルアップに伴い装備を何度も整え直す必要があることを意味する。 また、多数の連撃ができるということはそれだけ敵のバリアによる反動を強く受けるということであり、装備もまともに整わないまま不用意にショゴスやモノポッドに攻撃を仕掛ければ手痛い反撃を受けてしまう。レベル20以降は酸耐性の確保が急務となるだろう。 レベル25から使用できるカリデーモンとなると、それまで非人系のフォームだったところがいきなり半人型となるのも悩みどころ。 何れにしてもWyvernの種族の中でも最もクセの強い部類のため、この種族を選ぶにしてもある程度ゲームへの理解を深めた後にするのが良い。 なお、初期スキルからしてPolearm(竿状武器)が得意のようだが、現状で竿状武器に特化したギルドは存在せず誤った育成をしかねないため、この点でも初心者泣かせの存在である。 ステータス ステータス 値 初期HP 40 増加HP/Lv 4 初期SP 60 増加SP/Lv 6 初期ちから 90 獲得スキルpt/Lv 3 スキル レベル Pole Weapons 2 Meditation 1 Water Magic 1 Fire Magic -1 変身可能フォーム レベル フォーム タイルサイズ 能力 装備スロット HP補正 コマンド 1 カエル 1x1 Tiny 跳躍、水泳 アミュレット、頭、クローク、靴x2 x0.2 shift frog 1 毒ヘビ 1x1 Tiny 毒攻撃、水泳 アミュレット、頭、尻尾 x0.75 shift viper 4 コブラ 1x1 Normal 毒攻撃、毒吐き、水泳、加速、毒免疫 アミュレット、頭、尻尾 x1 shift cobra 8 ワニ 1x2 Normal 重防御(+0全身防護)、強力な噛み付き、水泳、恐怖免疫 アミュレット、頭、尻尾 x1.5 shift croc 12 翼サーペント 2x2 Giant 毒噛み付き、重防御(+15全身防護)、飛行、水中呼吸、毒/恐怖免疫、死耐性(45%?) アミィレット、頭(大)、尻尾 x2 shift serpent 16 ドラゴン 2x2 Giant 強力な噛み付き、毒ブレス、飛行、水中呼吸 アミュレット、頭(大)、指輪x3、ブレーサー、ベルト、盾、クローク、尻尾 x2.8 shift dragon 20 ヒドラ 2x2 Giant 6回攻撃、毒/恐怖免疫、水中呼吸 アミュレットx5、頭(大)x5、ベルト、尻尾 x2.5 shift hydra 24 カリデーモン 1x1 Normal 6回攻撃、毒免疫、水中呼吸 アミュレット、指輪x6、ブレーサーx3、頭、クローク、ベルト、尻尾 x1.5 shift kalidemon 30 T-レックス 2x3 Giant ? ? ? shift trex コメント 名前 コメント

• todo314 @ ウィキ - Importance Sketching of Influence Dynamics in Billion-scale Networks

  https://w.atwiki.jp/todo314/pages/451.html

  Importance Sketching of Influence Dynamics in Billion-scale Networks Hung T. Nguyen, Tri P. Nguyen, NhatHai Phan, Thang N. Dinh ICDM 2017 概要 RR集合のImportance sampling版を作った 既存のRISベースの手法に適用できますよ とても速いです 動機づけ 単一頂点からなるカスケードが良く発生する メモリ消費✘処理時間✘推定効率✘ 独立カスケードの場合 WCなら30%くらい、TRIなら90%くらいはsingular 枠組み$$\mathsf{SKIS}$$ と Importance Influence Sampling ($$\mathsf{IIS}$$) ぶっちゃけ SIGMETRICS 17 Outward Influence and Cascade Size Estimation in Billion-scale Networks と同じ 影響力推定はちょっとだけ補正する (IISでの被覆)*(どれか成功する確率)+(単一点で終わる確率の総和) Γ=(普通にやったときにどれか成功する確率)とすると、 Γが小さいほうが得する；普通のサンプリングに比べて$$ \Theta(\frac{\Gamma}{n}) $$倍得する ただのCoverageなので、貪欲をそのまますればOK そのままIMMとかD-SSAに適用できる 線形閾値、連続時間にもかんたんに拡張できるよ 実験 比較手法：RIS、SKIM、PMC、IMM、D-SSA、D-SSA+SKIS 辺確率：WCとTRI 影響力推定 RIS、SKIMより平均相対誤差がとても良くなったよ！ 分布を見ても安定しているよ！ 影響最大化 D-SSA+SKISはD-SSAより何倍か良い 何かD-SSA速くない？ PMCとIMMは、WCではIMM、TRIではPMCが速い（それはそう） まとめ 実質importance samplingをIC用に提案しただけだなぁ…。 ICDM 影響拡散 影響最大化 2017/10/02

• sicpstudygroup @ ウィキ - naga:4-25/4-34

  https://w.atwiki.jp/sicpstudygroup/pages/84.html

  naga Todo 4.26 4.30 4.32 Exercise 4.25 ;; applicative-order では (factorial 5) の評価時に unless の３つの引数 ;; (= n 1) (* n (factorial (- n 1))) 1 を予め評価しようとし、2番目の引数 ;; の評価のために再度 (factorial 4) を評価するというループに入り、 n が ;; 負となっても評価のループをし続ける。 ;; normal-order では (= n 1) の結果により (* n (factorial (- n 1))) を評価 ;; するかどうか決めるので、期待通りに動作する。 Exercise 4.27 ;;;L-Eval input (define count 0) ;;;L-Eval value ok ;;;L-Eval input (define (id x) (set! count (+ count 1)) x) ;;;L-Eval value ok ;;;L-Eval input (define w (id (id 10))) ;; ここで、 外側の id の実行で x に (thunk (id 10) env) が対応付けられ、 ;; count に 1 が格納され、 ;; id の値として x の値が返されるので、 ;; w に (thunk (id 10) env) が格納される。 ;;;L-Eval value ok ;;;L-Eval input count ;;;L-Eval value 1 ;;;L-Eval input w ;; ここで、w の値の評価で ;; count に 2 が格納され、 ;; 10 が返される。 ;;;L-Eval value 10 ;;;L-Eval input count ;;;L-Eval value 2 Exercise 4.28 ;;;;;L-Eval input ;;(define (calc f m n) ;; (f m n)) ;;;;;L-Eval value ;;ok ;;;;;L-Eval input ;;(calc + 4 6) ;f - (thunk + env) m - (thunk 4 env) n - (thunk 6 env) ;;;;;L-Eval value ;と格納されるので actual-value を使って ;;10 ;operator を得る必要がある。 Exercise 4.29 ;;gosh (Lscheme) ;;memoization on ;;;;;L-Eval input ;;(load "id") ;;;;;L-Eval value ;;ok ;;;;;L-Eval input ;;(define (square x) (* x x)) ;;;;;L-Eval value ;;ok ;;;;;L-Eval input ;;(square (id 10)) ;x に (thunk id 10) が格納され、 (* x x) の評価が始まり、 ;;;;;L-Eval value ;x の actual-value を得る段階で count が 1 になる。 ;;100 ;memoization が on の時は、もう1つの x の値は今求めた値を ;;;;;L-Eval input ;使うので、 count は 1 のまま。 ;;count ;memoization が off の時は、再度 x の actual-value を求める ;;;;;L-Eval value ;ので count が 2 となる。 ;;1 ;;;;;L-Eval input ;;(exit) ;;bye ;;gosh (Lscheme without-memo) ;;memoization off ;;;;;L-Eval input ;;(load "id") ;;;;;L-Eval value ;;ok ;;;;;L-Eval input ;;(define (square x) (* x x)) ;;;;;L-Eval value ;;ok ;;;;;L-Eval input ;;(square (id 10)) ;;;;;L-Eval value ;;100 ;;;;;L-Eval input ;;count ;;;;;L-Eval value ;;2 Exercise 4.30 Exercise 4.31 ;; 方針 ;; 1. define は変更しない。lazy、lazy-memo のパラメータオプションはそのまま ;; 仮引数の中に入れたままで procedure に記憶する。 ;; 2. Apply の 環境の拡張時に パラメータの有無にしたがって、delay / actual- ;; value を実引数に作用させてから拡張を行う。 ;; 3. Lazy Evaluation で行った変更はすべて採用し、それに以下を追加する。 ;; 4. force-it で memo 化をおこなう。 ;; thunk は (lazy exp env) (lazy-memo exp env) (evaluated-thunk exp-value ()) ;; の 3 種類。 ;; Eval の application? を変更 ;;((application? exp) ;; (Apply (actuall-value (operator exp) env) ;; (operands exp) ;; env)) (define (Apply procedure arguments env) (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure (list-of-arg-values arguments env))) ((compound-procedure? procedure) (eval-sequence (procedure-body procedure) (extend-environment-with-delay (procedure-parameters procedure) arguments (procedure-environment procedure)))) (else (Error "Unknown procedure type -- APPLY" procedure)))) (define (extend-environment-with-delay vars vals env) (define (iter vars vals rvars rvals) (if (null? vars) (cons (make-frame (reverse rvars) (reverse rvals)) env) (iter (cdr vars) (cdr vals) (cons (if (not (pair? (car vars))) (car vars) (caar vars)) rvars) (cons (delay-or-actual-value (car vars) (car vals) env) rvals)))) ; (if (not (= (length vars) (length vals))) (if ( (length vars) (length vals)) (Error "Too many arguments supplied" vars vals) (Error "Too few arguments supplied" vars vals))) (iter vars vals () ())) (define (delay-or-actual-value var val env) (cond ((not (pair? var)) (actual-value val env)) ((or (eq? (cadr var) lazy) (eq? (cadr var) lazy-memo)) (list (cadr var) val env)) (else (Error "Unknown parameter option" (cadr var))))) ;driver-loop のactual-value (define (lazy-memo? obj) (tagged-list? obj lazy-memo)) (define (lazy? obj) (tagged-list obj? lazy)) (define (force-it obj) (cond ((lazy-memo? obj) (let ((result (actual-value (thunk-exp obj) (thunk-env obj)))) (set-car! obj evaluated-thunk) (set-car! (cdr obj) result) (set-cdr! (cdr obj) ()) ; forget unneeded env result)) ((evaluated-thunk? obj) (thunk-value obj)) ((lazy? obj) (actual-value (thunk-exp obj) (thunk-env obj))) (else obj))) ;;;;;M-Eval input ;;(define (square (x lazy)) (* x x )) ;;;;;M-Eval value ;;ok ;;;;;M-Eval input ;;(square (id 10)) ;;;;;M-Eval value ;;100 ;;;;;M-Eval input ;;count ;;;;;M-Eval value ;;2 ;;;;;M-Eval input ;;(set! count 0) ;;;;;M-Eval value ;;ok ;;;;;M-Eval input ;;(define (square (x lazy-memo)) (* x x )) ;;;;;M-Eval value ;;ok ;;;;;M-Eval input ;;(square (id 10)) ;;;;;M-Eval value ;;100 ;;;;;M-Eval input ;;count ;;;;;M-Eval value ;;1 Exercise 4.32 Exercise 4.33 (define (Cons x y) (lambda (m) (m x y))) (define (Car z) (if (Pair? z) (z (lambda (p q) p)) (Error "pair required, but got " z))) (define (Cdr z) (if (Pair? z) (z (lambda (p q) q)) (Error "pair required, but got " z))) ;; ex4_33 - ;; LazyList用の car、cdr、cons をそれぞれ Car、Cdr、Cons としてLazy Evaluatorの ;; 手続きとして実装したので、list から lazylist への変換も手続きとして用意する。 (define (list- lazylist exp) (define (make-lazylist l) (if (null? l) () (Cons (car l) (make-lazylist (cdr l))))) (if (not (pair? exp)) exp (make-lazylist exp))) ;; - ex4_33 ;;;;;L-Eval input ;;(define nums (list- lazylist (2 4 6))) ;;;;;L-Eval value ;;ok ;;;;;L-Eval input ;;(Car nums) ;;;;;L-Eval value ;;2 ;;;;;L-Eval input ;;(Car (Cdr nums)) ;;;;;L-Eval value ;;4 Exercise 4.34 (define (Cons x y) (lambda (m) (m x y))) (define (Car z) (if (Pair? z) (z (lambda (p q) p)) (Error "pair required, but got " z))) (define (Cdr z) (if (Pair? z) (z (lambda (p q) q)) (Error "pair required, but got " z))) (define Pair (Cons x y)) (define (Pair? p) (and (pair? p) ( (length p) 3) (equal? (car p) (car Pair)) (equal? (cadr p) (cadr Pair)) (equal? (caddr p) (caddr Pair)))) ;; ex4_34 - ;; display-lazylist を Lazy Evaluator の手続きとして用意する。 ;; lazylist は Cons によってしか作成できないという制限を付加する。つまり、 ;; Cons の定義が (define (Cons x y) (lambda (m) (m x y))) で仮引数が x と y ;; であることとを利用する。 (define (display-lazylist exp) (define refs ()) (define (ref? pair) (if (memq pair refs) (- (length (memq pair refs)) 1) #f)) (define (ref! pair) (set! refs (cons pair refs))) (define refeds ()) (define (refed? pair) (if (memq pair refeds) (length refs) #f)) (define (refed! pair) (set! refeds (cons pair refeds))) (define marks ()) (define (mark? pair) (memq pair marks)) (define (mark! pair) (set! marks (cons pair marks))) ; ; リスト中の多重参照されているセルを refeds に登録 (define (recm l) (cond ((not (Pair? l)) end) ((mark? l) (refed! l) end) (else (mark! l) (recm (Car l)) (recm (Cdr l))))) ; ; セルが多重参照されているかどうかを refeds で確認し、参照されている ; なら参照可（#n=）としセルを refs に登録。セルの car、cdr が多重参照 ; を参照しているかを ref で確認し、参照しているなら参照 (#n#) とする。 (define (recd l pf) (cond ((not (Pair? l)) (display l)) (else (let ((n (refed? l))) (cond (n (cond ((not pf) (display " . ") (set! pf #t))) (display "#") (display n) (display "=") (display "(") (ref! l)) (else (if pf (display "(") (display " ")))) (let ((ncar (ref? (Car l))) (ncdr (ref? (Cdr l)))) (cond (ncar (display "#") (display ncar) (display "#")) (else (recd (Car l) #t))) (cond (ncdr (display " . #") (display ncdr) (display "#")) ((null? (Cdr l)) (display "")) ((Pair? (Cdr l)) (recd (Cdr l) #f)) (else (display " . ") (recd (Cdr l) #f)))) (if pf (display ")")))))) ; (recm exp) (recd exp #t)) ;; - ex4_34 ;;(define a (Cons 1 b)) ;;(define b (Cons d c)) ;;(define c (Cons a ())) ;;(define d (Cons b c)) ;;;;;L-Eval input ;;(display-lazylist a) ;;#0=(1 . #1=((#1# . #2=(#0#)) . #2#));;;L-Eval value ;;# undef

• sicpstudygroup @ ウィキ - naga:3-1/3-37

  https://w.atwiki.jp/sicpstudygroup/pages/70.html

  naga Todo 3.8 3.9 3.10 3.11 3.20 3.26 3.27 3.30 3.31 3.32 3.33 3.34 3.35 3.36 3.37 Exercise 3.1 (define (make-accumulator sum) (lambda (num) (set! sum (+ sum num)) sum)) ;;gosh (define A (make-accumulator 5)) ;;A ;;gosh (A 10) ;;15 ;;gosh (A 10) ;;25 Exercise 3.2 (define (make-monitored f) (let ((count 0)) (lambda (x) (cond ((eq? x how-many-calls?) count) ((eq? x reset-count) (set! count 0)) (else (begin (set! count (+ count 1)) (f x))))))) ;;gosh (define s (make-monitored sqrt)) ;;s ;;gosh (s 100) ;;10.0 ;;gosh (s how-many-calls?) ;;1 ;;gosh (s reset-count) ;;0 ;;gosh (s how-many-calls?) ;;0 Exercise 3.3 (define (make-account balance password) (define (withdraw amount) (if ( = balance amount) (begin (set! balance (- balance amount)) balance) "Insufficient funds")) (define (deposit amount) (set! balance (+ balance amount)) balance) (define (dispatch p m) (cond ((pass-error? p) (lambda (m))) ((eq? m withdraw) withdraw) ((eq? m deposit) deposit) (else (error "Unknown request -- MAKE-ACCOUNT" m))) ) (define (pass-error? p) (if (eq? p password) #f (error "Incorrect password"))) dispatch) ;;gosh (define acc (make-account 100 secret-password)) ;;acc ;;gosh ((acc secret-password withdraw) 40) ;;60 ;;gosh ((acc some-other-password deposit) 50) ;;*** ERROR Incorrect password Exercise 3.4 ;; 7回連続ではテストが面倒なので4回連続で (define (make-account balance password) (let ((ipc 0)) (define (withdraw amount) (if ( = balance amount) (begin (set! balance (- balance amount)) balance) "Insufficient funds")) (define (deposit amount) (set! balance (+ balance amount)) balance) (define (dispatch p m) (cond ((pass-error? p) (lambda (m))) ((eq? m withdraw) withdraw) ((eq? m deposit) deposit) (else (error "Unknown request -- MAKE-ACCOUNT" m))) ) (define (pass-error? p) (if (eq? p password) (begin (set! ipc 0) #f) (begin (display "Incorrect password")(newline) (set! ipc (+ ipc 1)) (if ( ipc 3) (display "call-the-cops") ) #t))) dispatch)) ;;gosh (define a (make-account 100 a)) ;;a ;;gosh ((a b withdraw) 20) ;;Incorrect password ;;# undef ;;gosh ((a b withdraw) 20) ;;Incorrect password ;;# undef ;;gosh ((a b withdraw) 20) ;;Incorrect password ;;# undef ;;gosh ((a b withdraw) 20) ;;Incorrect password ;;call-the-cops# undef Exercise 3.5 (use srfi-27) (define (estimate-integral p x1 x2 y1 y2 trials) (let ((xl (if ( x1 x2) x1 x2)) (xh (if ( x1 x2) x2 x1)) (yl (if ( y1 y2) y1 y2)) (yh (if ( y1 y2) y2 y1))) (define (experiment) (let ((x (random-in-range xl xh)) (y (random-in-range yl yh))) (p x y))) (define (random-in-range low high) (let ((range (- high low))) (+ low (* (random-real) range)))) (abs (* (- x1 x2) (- y1 y2) (monte-carlo trials experiment))))) ;; (define (p x y) ( = (+ (expt (- x 5.0) 2) (expt (- y 7.0) 2)) 9.0)) ;;gosh (/ (estimate-integral p 2 8 4 10 100000) 9.0) ;;3.1396800000000002 ;;gosh (/ (estimate-integral p 2 8 4 10 1000000) 9.0) ;;3.142024 Exercise 3.6 (define rand (let ((x 0)) (define (rand-update x) (remainder (+ (* x 93) 5) 128)) (define reset (lambda (nv) (set! x nv))) (define generate (lambda () (set! x (rand-update x)) x)) (define (dispatch m) (cond ((eq? m generate) generate) ((eq? m reset) reset) (else (error "Unknown request -- RAND" m)))) dispatch)) ;;gosh ((rand generate)) ;;5 ;;gosh ((rand generate)) ;;86 ;;gosh ((rand generate)) ;;67 ;;gosh ((rand reset) 0) ;;0 ;;gosh ((rand generate)) ;;5 ;;gosh ((rand generate)) ;;86 ;;gosh ((rand generate)) ;;67 Exercise 3.7 (define (make-account balance password) (define (withdraw amount) (if ( = balance amount) (begin (set! balance (- balance amount)) balance) "Insufficient funds")) (define (deposit amount) (set! balance (+ balance amount)) balance) (define (dispatch p m) (cond ((pass-error? p) (lambda (m))) ((eq? m withdraw) withdraw) ((eq? m deposit) deposit) (else (error "Unknown request -- MAKE-ACCOUNT" m))) ) (define (pass-error? p) (if (eq? p password) #f (error "Incorrect password"))) dispatch) ;; 正しい新しいpasswordなら本来のpasswordでaccountにアクセスする (define (make-joint account password new-password) (define (joint p m) (cond ((pass-error? p) (lambda (m))) (else (account password m)) )) (define (pass-error? p) (if (eq? p new-password) #f (error "Incorrect password"))) joint) ;;gosh (define peter-acc (make-account 150 open-sesame)) ;;peter-acc ;;gosh (define paul-acc (make-joint peter-acc open-sesame rosebud)) ;;paul-acc ;;gosh ((paul-acc rosebud deposit) 20) ;;170 ;;gosh ((paul-acc rosebud withdraw) 70) ;;100 ;;gosh ((paul-acc xxxxx deposit) 100) ;;*** ERROR Incorrect password ;;gosh (define john-acc (make-joint peter-acc close-sesame xyzzz)) ;;john-acc ;;gosh ((john-acc xyzzz withdraw) 30) ;;*** ERROR Incorrect password Exercise 3.12 (define (append! x y) (set-cdr! (last-pair x) y) x) (define x (list a b)) (define y (list c d)) (define z (append x y)) z ;(a b c d) ;; x- [ | ]- [ |/] ;; a b (cdr x) ;(b) (define w (append! x y)) ;; y- [ | ]- [ |/] ;; c d ;; x↓ ;; w- [ | ]- [ | ]- [ | ]- [ |/] ;; a b c d w ;(a b c d)g (cdr x) ;(b c d) Exercise 3.13 (define (make-cycle x) (set-cdr! (last-pair x) x) x) (define z (make-cycle (list a b c)) ;; +---------------+ ;; ↓ ↑ ;; z- [ | ]- [ | ]- [ | ] ;; a b c ;(last-pair z) →loop(こういう状態のことをどう表現するのがいいのだろう？ hang upはちょっと違う気がするし。 Exercise 3.14 (define (mystery x) (define (loop x y) (if (null? x) y (let ((temp (cdr x))) (set-cdr! x y) (loop temp x)))) (loop x ())) ;; may be reverse! (define v (list a b c d)) ;v- [ | ]- [ | ]- [ | ]- [ |/] ; a b c d (define w (mystery v)) ;v-----------------------↓ ;w- [ | ]- [ | ]- [ | ]- [ |/] ; d c b a Exercise 3.15 (define (set-to-wow! x) (set-car! (car x) wow) x) (define x (list a b)) (define z1 (cons x x)) ;z1- [ | ] ; ↓ ↓ ;x - [ | ]- [ |/]) ; ↓ ↓ ; a b (set-to-wow! z1) ; ((wow b) wow b) ;z1- [ | ] ; ↓ ↓ ;x - [ | ]- [ |/]) ; ↓ ↓ ; wow b (define z2 (cons (list a b) (list a b))) ;z2- [ | ]- [ | ]- [ |/]) ; | ↓ ↓ ; | a b ; | ↑ ↑ ; ----- [ | ]- [ |/]) (set-to-wow! z2) ; ((wow b) a b) ;z2- [ | ]- [ | ]- [ |/] ; | ↓ ↓ ; | a b ; | ↑ ; ----- [ | ]- [ |/] ; ↓ ; wow Exercise 3.16 (define (count-pairs x) (if (not (pair? x)) 0 (+ (count-pairs (car x)) (count-pairs (cdr x)) 1))) (define c3 (a b c)) ;; (count-pairs c3) ;; 3 ; c3- [ | ]- [ | ]- [ |/] (define c4 (let ((x (a b c))) (set-car! x (cddr x)) x)) ;; (cout-pairs c4) ;; 4 ; c4- [ | ]- [ | ]- [ |/] ; ↓-----------↑ (define c7 (let ((x (a b c))) (set-car! x (cdr x)) (set-car! (cdr x) (cddr x)) x)) ;; (count-pairs c7) ;; 7 ; ↑-----↓ ; c7- [ | ]- [ | ]- [ |/] ; ↓-----↑ (define cl (let ((x (a b c))) (set-cdr! (cddr x) x) x)) ;; (count-pairs cl) ;; ; cl- [ | ]- [ | ]- [ | ] ; ↑--------------↓ Exercise 3.17 ;; c3, c4, c7, cl は Exercise 3.16 のものを使用 (define (count-pairs x) (let ((marked ())) (define (count-with-mark x) (if (or (not (pair? x)) (memq x marked)) 0 (begin (set! marked (cons x marked)) (+ (count-with-mark (car x)) (count-with-mark (cdr x)) 1)))) (count-with-mark x))) ;;gosh (count-pairs c3) ;;3 ;;gosh (count-pairs c4) ;;3 ;;gosh (count-pairs c7) ;;3 ;;gosh (count-pairs cl) ;;3 Exercise 3.18 (define (cycle? x) (let ((marked ())) (define (suc x) (let ((save ())) (cond ((memq x marked) #t) ;; cycle (else (set! marked (cons x marked)) (cond ((pair? (car x)) (set! save marked) ;; save current marked list (cond ((suc (car x)) #t) ;; cycle in car part (else (set! marked save) (suc (cdr x))))) ((or (null? (cdr x)) (not (pair? (cdr x)))) #f) (else (suc (cdr x)))))))) (if (pair? x) (suc x) (error "CYCLE? gets not pair" x)))) (define c3 (list a b C)) (define c4 (let ((x (a b c))) (set-car! (cdr x) (cddr x)) x)) (define cycle1 (let ((x (a b c))) (set-cdr! (cddr x) x) x)) (define cycle2 (let ((x (a b c))) (set-car! (cddr x) x) x)) (define cycle3 (let ((x (a b c))) (set-cdr! x x) x)) (define cycle4 (let ((x (a b c))) (set-car! x x) x)) ;;gosh (cycle? c3) ;;#f ;;gosh (cycle? c4) ;;#f ;;gosh (cycle? cycle1) ;;#t ;;gosh (cycle? cycle2) ;;#t ;;gosh (cycle? cycle3) ;;#t ;;gosh (cycle? cycle4) ;;#t Exercise 3.19 ;; このpairはlistの中で何番目のpairのはずというのを確認することでloopを検出する。 ;; 一応題意は満足していると思う。carでのloopには対応できない。 (define (cycle? x) (define (index? k lst) (define (iter lst count) (if (eq? k lst) count (iter (cdr lst) (+ count 1)))) (iter lst 1)) (define (iter p num) (cond ((not (pair? (cdr p))) #f) ((= (index? p x) num) (iter (cdr p) (+ num 1))) (else #t))) (if (pair? x) (iter x 1) (error "CYCLE? gets not pair" x))) (define c3 (list a b C)) (define cycle1 (let ((x (a b c))) (set-cdr! (cddr x) x) x)) (define cycle3 (let ((x (a b c))) (set-cdr! x x) x)) ;;gosh (cycle? c3) ;;#f ;;gosh (cycle? c4) ;;#f ;;gosh (cycle? cycle1) ;;#t ;;gosh (cycle? cycle2) ;;#t ;;gosh (cycle? cycle3) ;;#t ;;gosh (cycle? cycle4) ;;#t Exercise 3.20 Exercise 3.21 (define (print-queue queue) (front-ptr queue)) ;;gosh (define q (make-queue)) ;;q ;;gosh (print-queue q) ;;() ;;gosh (insert-queue! q a) ;;(#0=(a) . #0#) ;;gosh (print-queue q) ;;(a) ;;gosh (insert-queue! q b) ;;((a . #0=(b)) . #0#) ;;gosh (print-queue q) ;;(a b) ;;gosh (delete-queue! q) ;;(#0=(b) . #0#) ;;gosh (print-queue q) ;;(b) ;;gosh (delete-queue! q) ;;(() b) ;;gosh (print-queue q) ;;() Exercise 3.22 (define (make-queue) (let ((front-ptr ()) (rear-ptr ())) (define (empty-queue?) (null? front-ptr)) (define (front-queue) (if (empty-queue?) (error "FRONT called with an empty queue") (car front-ptr))) (define (insert-queue! item) (let ((new-pair (cons item ()))) (cond ((empty-queue?) (set! front-ptr new-pair) (set! rear-ptr new-pair)) (else (set-cdr! rear-ptr new-pair) (set! rear-ptr new-pair) front-ptr)))) (define (delete-queue!) (cond ((empty-queue?) (error "DELETE called with an empty queue")) (else (set! front-ptr (cdr front-ptr))))) (define (dispatch . l) (let ((m (car l))) (cond ((eq? m front-queue) (front-queue)) ((eq? m empty-queue?) (empty-queue?)) ((eq? m insert-queue!) (insert-queue! (cadr l))) ((eq? m delete-queue!) (delete-queue!)) (else (error "Undefined operation -- QUEUE"))))) dispatch)) ;;gosh (define q (make-queue)) ;;q ;;gosh (q empty-queue?) ;;#t ;;gosh (q insert-queue! a) ;;(a) ;;gosh (q empty-queue?) ;;#f ;;gosh (q insert-queue! b) ;;(a b) ;;gosh (q insert-queue! c) ;;(a b c) ;;gosh (q delete-queue!) ;;(b c) ;;gosh (q front-queue) ;;b Exercise 3.23 ;; deque- [ ]-----------+ ;; | | ;; +- [ ]+- [ ]- [ /] cdr が次の entry への pointer ;; | | +---|------|-+ ;; +---|-------|-+ | | ;; [ /] [ ] [ ] cdr が前の entry への pointer ;; | | | ;; item1 item2 item3 (define (make-deque) (cons () ())) (define (empty-deque? deque) (null? (car deque))) (define (front-deque deque) (if (empty-deque? deque) (error "FRONT called with an empty deque" (dq-print (dq-pr)int deque)) (dq-item (front-ptr deque)))) (define (rear-deque deque) (if (empty-deque? deque) (error "REAR called with an empty deque" (dq-print deque)) (dq-item (rear-ptr deque)))) (define (front-insert-deque! deque item) (let ((new-entry (make-dq-entry item))) (cond ((empty-deque? deque) (set-front-ptr! deque new-entry) (set-rear-ptr! deque new-entry) (dq-print deque)) (else (dq-set-np! new-entry (front-ptr deque)) (dq-set-pp! (front-ptr deque) new-entry) (set-front-ptr! deque new-entry) (dq-print deque))))) (define (rear-insert-deque! deque item) (let ((new-entry (make-dq-entry item))) (cond ((empty-deque? deque) (set-front-ptr! deque new-entry) (set-rear-ptr! deque new-entry) (dq-print deque)) (else (dq-set-pp! new-entry (rear-ptr deque)) (dq-set-np! (rear-ptr deque) new-entry) (set-rear-ptr! deque new-entry) (dq-print deque))))) (define (front-delete-deque! deque) (cond ((empty-deque? deque) (error "FRONT-DELETE called with an empty deque" (dq-print deque))) ((null? (dq-np (front-ptr deque))) (set-front-ptr! deque ()) (dq-print deque)) (else (dq-set-pp! (dq-np (front-ptr deque)) ()) (set-front-ptr! deque (dq-np (front-ptr deque))) (dq-print deque)))) (define (rear-delete-deque! deque) (cond ((empty-deque? deque) (error "REAR-DELETE called with an empty deque" (dq-print deque))) ((null? (dq-np (front-ptr deque))) (set-front-ptr! deque ()) (dq-print deque)) (else (dq-set-np! (dq-pp (rear-ptr deque)) ()) (set-rear-ptr! deque (dq-pp (rear-ptr deque))) (dq-print deque)))) (define (make-dq-entry item) (cons (cons item ()) ())) (define (dq-item dq-entry) (caar dq-entry)) (define (dq-np dq-entry) (cdr dq-entry)) (define (dq-pp dq-entry) (cdar dq-entry)) (define (dq-set-np! dq-entry ptr) (set-cdr! dq-entry ptr)) (define (dq-set-pp! dq-entry ptr) (set-cdr! (car dq-entry) ptr)) (define (dq-print deque) (define (iter ep) (cond ((null? ep) (display ")") (newline)) (else (display (dq-item ep)) (if (not (null? (dq-np ep))) (display " ") #t) (iter (dq-np ep))))) (define (iterr ep) (cond ((null? ep) (display "]") (newline)) (else (display (dq-item ep)) (if (not (null? (dq-pp ep))) (display " ") #t) (iterr (dq-pp ep))))) (display "(") (iter (front-ptr deque)) (display "[") (iterr (dequee))) ;;gosh (define dq (make-deque)) ;;dq ;;gosh (front-insert-deque! dq a) ;;(a) ;;[a] ;;# undef ;;gosh (rear-insert-deque! dq c) ;;(a c) ;;[c a] ;;# undef ;;gosh (front-delete-deque! dq) ;;(c) ;;[c] ;;# undef ;;gosh (rear-delete-deque! dq) ;;() ;;[c] ;;# undef Exercise 3.24 (define (make-table same-key?) (let ((local-table (list *table*))) (define (assoc key alist) (cond ((null? alist) #f) ((same-key? key (caar alist)) (car alist)) (else (assoc key (cdr alist))))) (define (lookup key-1 key-2) (let ((subtable (assoc key-1 (cdr local-table)))) (if subtable (let ((record (assoc key-2 (cdr subtable)))) (if record (cdr record) #f))))) (define (insert! key-1 key-2 value) (let ((subtable (assoc key-1 (cdr local-table)))) (if subtable (let ((record (assoc key-2 (cdr subtable)))) (if record (set-cdr! record value) (set-cdr! subtable (cons (cons key-2 value) (cdr subtable))))) (set-cdr! local-table (cons (list key-1 (cons key-2 value)) (cdr local-table)))) ok)) (define (dispatch m) (cond ((eq? m lookup-proc) lookup) ((eq? m insert-proc!) insert!) (else (error "Unknown operation -- TABLE" m)))) dispatch)) (define operation-table (make-table same-key?)) (define get (operation-table lookup-proc)) (define put (operation-table insert-proc!)) ;; 整数部分での比較 (define (same-key? key val) (equal? (floor key) (floor val))) (put 1.5 1.5 1*1) (put 2.5 2.5 2*2) ;;gosh (get 2.2 2.2) ;;|2*2| ;;gosh (get 1.2 1.2) ;;|1*1| ;;gosh (get 2.2 1.2) ;;#f Exercise 3.25 ;; キー数を内部的に1stキーとする。 (define (make-table) (let ((local-table (list *table*))) (define (lookup key-list) (define (iter keys subtable) (let ((tr (assoc (car keys) (cdr subtable)))) (cond ((not tr) #f) ((and tr (null? (cdr keys))) (cdr tr)) (else (iter (cdr keys) tr))))) (iter (cons (length key-list) key-list) local-table)) (define (insert! key-list value) (define (iter keys subtable) (let ((tr (assoc (car keys) (cdr subtable)))) (cond ((and tr (null? (cdr keys))) (set-cdr! tr value)) (tr (iter (cdr keys) tr)) ((null? (cdr keys)) (set-cdr! subtable (cons (cons (car keys) value) (cdr subtable)))) (else (set-cdr! subtable (cons (cons (car keys) ()) (cdr subtable))) (iter (cdr keys) (cadr subtable)))))) (iter (cons (length key-list) key-list) local-table) ;;(print local-table)(newline) ok) (define (dispatch m) (cond ((eq? m lookup-proc) lookup) ((eq? m insert-proc!) insert!) (else (error "Unknown operation -- TABLE" m)))) dispatch)) (define operation-table (make-table)) (define get (operation-table lookup-proc)) (define put (operation-table insert-proc!)) (put (1 2 3) a) (put (1 2 4) b) (put (1 3 3) c) (put (1 2 3 4) d) ;;gosh (get (1 2)) ;;#f ;;gosh (get (1 2 3)) ;;a ;;gosh (get (1 2 3 4)) ;;d ;;gosh (get (1 2 3 4 5)) ;;#f ;;gosh (get (1 3 3)) ;;c Exercise 3.26 Exercise 3.27 Exercise 3.28 (define (or-gate o1 o2 output) (define (or-action-procedure) (let ((new-value (logical-or (get-signal o1) (get-signal o2)))) (after-delay or-gate-delay (lambda () (set-signal! output new-value))))) (add-action! o1 or-action-procedure) (add-action! o2 or-action-procedure) ok) (define (logical-or o1 o2) (if (and (or (= o1 0) (= o1 1)) (or (= o2 0) (= o2 1))) (cond ((and (= o1 0) (= o2 0)) 0) (else 1)) (error "invalid signal" o1 o2))) (define a (make-wire)) (define b (make-wire)) (define o (make-wire)) (or-gate a b o) (probe a a) (probe b b) (probe o o) ;;a 0 New-value =0 ;;b 0 New-value =0 ;;o 0 New-value =0 ;;#t ;;gosh (set-signal! a 1) ;;a 0 New-value =1 ;;done ;;gosh (propagate) ;;o 5 New-value =1 ;;done ;;gosh (set-signal! b 1) ;;b 5 New-value =1 ;;done ;;gosh (propagate) ;;done ;;gosh (set-signal! b 0) ;;b 10 New-value =0 ;;done ;;gosh (propagate) ;;done ;;gosh (set-signal! a 0) ;;a 15 New-value =0 ;;done ;;gosh (propagate) ;;o 20 New-value =0 ;;done Exercise 3.29 (define (or-gatex o1 o2 output) (let ((a1 (make-wire)) (a2 (make-wire)) (a3 (make-wire))) (inverter o1 a1) (inverter o2 a2) (and-gate a1 a2 a3) (inverter a3 output))) ;;2 inverter-delay(=2) + 1 and-gate-delay(=3) (define a (make-wire)) (define b (make-wire)) (define o (make-wire)) (or-gatex a b o) (probe a a) (probe b b) (probe o o) ;;a 0 New-value =0 ;;b 0 New-value =0 ;;o 0 New-value =0 ;;#t ;;gosh (set-signal! a 1) ;;a 0 New-value =1 ;;done ;;gosh (propagate) ;;o 2 New-value =1 ;;o 7 New-value =0 ;;o 7 New-value =1 ;;done ;;gosh (set-signal! b 1) ;;b 7 New-value =1 ;;done ;;gosh (propagate) ;;done ;;gosh (set-signal! b 0) ;;b 12 New-value =0 ;;done ;;gosh (propagate) ;;done ;;gosh (set-signal! a 0) ;;a 17 New-value =0 ;;done ;;gosh (propagate) ;;o 24 New-value =0 ;;done