연습문제 풀이 04
4_01
;; file: 4_01.rkt
(#%require rackunit)
(#%require (prefix racket: racket))
(racket:require "../allcode/ch4-4.1.1-mceval.rkt")
;; 여기서의 cons는 left평가후 right를 평가한다.
(cons
(begin (display "1") (newline) 1)
(begin (display "2") (newline) 2))
;;>> 1
;;>> 2
;;=> (1 . 2)
;; cons의 구현과 상관없이, 순서를 강제하려면 cons에서 left/right를 계산하는게 아닌,
;; 미리 left/right를 계산해버리면 된다.
(let* ((left (begin (display "1") (newline) 1))
(right (begin (display "2") (newline) 2)))
(cons left right))
;;>> 1
;;>> 2
;;=> (1 . 2)
(let* ((right (begin (display "2") (newline) 2))
(left (begin (display "1") (newline) 1)))
(cons left right))
;;>> 2
;;>> 1
;;=> (1 . 2)
;; list-of-values 를 다시 작성하면
;; before
'(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (eval (first-operand exps) env)
(list-of-values (rest-operand exps) env))))
;; after
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(let* ((left (eval (first-operand exps) env))
(right (list-of-values (rest-operands exps) env)))
(cons left right))))
4_02
;; file: 4_02.rkt
(#%require rackunit)
(#%require (prefix racket: racket))
(#%require "../allcode/helper/my-util.rkt")
(racket:require "../allcode/ch4-4.1.1-mceval.rkt")
;; a) eval의 cond절에서
;; assignment 혹은 definition보다
;; ((assignment? exp) (eval-assignment exp env))
;; ((definition? exp) (eval-definition exp env))
;; application을
;; ((application? exp) (apply (eval (operator exp) env) (list-of-values (operands exp) env)))
;; 먼저 배치한다는 계획에서 잘못된 점은무엇인가?
;; - (귀띔 : 저 생각대로 (define x 3) 식을 처리하면 어떻게 될까?)
;;
;; 이런식으로 함수 호출이 먼저 된다면?
;;
;;(define (eval exp env)
;; (cond (
;; ...
;; ((variable? exp) ; symbol? 이면
;; (lookup-variable-value exp env))
;; ...
;; ((application? exp) ; pair? 이면 함수 호출
;; (apply (eval (operator exp) env) (list-of-values (operands exp) env)))
;; ...
;; ((assignment? exp) ; set! 으로 시작
;; (eval-assignment exp env))
;; ((definition? exp) ; define 으로 시작
;; (eval-definition exp env))
;; ...
;; )))
;;
;; - 간단히
; - '(define x 3)가 pair?를 만족함으로 application(함수 콜)을 처리하는 로직에 떨어지게 됨.
;; - 당연히 'define이라는 함수가 정의가 되지 않았으므로 에러 발생 예상.
;; - 자세히.
;; - ((application? '(define x 3)) ; pair? 이면 함수 호출
;; - (apply (eval 'define env) (list-of-values '(x 3) env)) 를 수행하게 되는데
;; - (eval 'define env) 에서 'define은 심볼이므로
;; - ((variable? 'define) (lookup-variable-value 'define env)) 로 떨어지게 됨
;; - lookup-variable-value은 아직 구현이 나와있지 않으나 'define이 env에 정의되지 않았을 거임 그래서 에러가 발생할꺼.(에러가 발생안한다면 잘못된 구현)
;; b)언어 문법을 바꾸어서 프로시저 적용 식이 언제나 call로 시작되게 하자.
;; - 보기를 들어， (factorial 3)은 (call factorial 3)으로， (+ 1 2)는 (call + 1 2)로 된다.
;;
;; eval함수에서 함수를 처리하는 부분은
;; ((application? exp) ; pair? 이면 함수 호출
;; (apply (eval (operator exp) env) (list-of-values (operands exp) env)))
;;
;; exp가 (factorial 3) 에서 (call factorial 3) 식으로 바뀌었으므로
;; application? / operator / operands 부분을 고쳐야함.
;; 단순 pair?로 체크하는걸 'call로 시작하는 리스트를 확인하는걸로 바꾸고
;(define (application? exp)
;; (pair? exp))
(define (application? exp)
(tagged-list? exp 'call))
;; rest로 첫번째 아이템('call)은 건너띄면 됨.
;;(define (operator exp)
;; (first exp))
;;(define (operands exp)
;; (rest exp))
(define (operator exp)
(first (rest exp)))
(define (operands exp)
(rest (rest exp)))
4_03
Exercise 2.73
;; file: 4_03.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require "../allcode/ch4-4.1.1-mceval.rkt")
(#%require "../allcode/ch3-3.3.3.rkt")
;; eval을 data-directed style 로 고쳐라
;; 그 후 Exercise 2.73 와 비교해보자
;;
;; 챕터 2.4.3에 data-directed style이 나온다.
;;
;; == basic style
;; (define (deriv exp var)
;; (cond ((number? exp) ...)
;; ((variable? exp) ...)
;; ((sum? exp) ...)
;; ((product? exp) ...)
;; (else ...)
;; ))
;; == data-directed style
;; (define (deriv exp var)
;; (cond ((number? exp) ...)
;; ((variable? exp) ...)
;; (else
;; ((get 'deriv (operator exp)) (operands exp) var))
;; ))
;;
;; eval에서 ***로 마크한 조건들이 data-directed style로 바뀌기 좋은 형태이다.
;;
;; (define (eval exp env)
;; (cond ((self-evaluating? exp) ; 숫자? / 문자열?
;; ((variable? exp) ; symbol? 이면
;; *** ((quoted? exp) ; quote 로 시작
;; *** ((assignment? exp) ; set! 으로 시작
;; *** ((definition? exp) ; define 으로 시작
;; *** ((if? exp) ; if 로 시작
;; *** ((lambda? exp) ; lambda 로 시작
;; *** ((begin? exp) ; begin 으로 시작
;; *** ((cond? exp) ; cond 로 시작
;; ((application? exp) ; pair? 이면 함수 호출
;; (else
;; ))
;;
;;
;; (define (eval exp env)
;; (cond ((self-evaluating? exp) ; 숫자? / 문자열?
;; ((variable? exp) ; symbol? 이면
;; *** ((started-with-builtin-tag? exp)
;; *** ((get-tagged-func exp) exp env))
;; ((application? exp) ; pair? 이면 함수 호출
;; (else
;; ))
;;
;; 그리고 각 함수들에 대해 (tagged-func-name> exp env) 이런 식으로 정규화를 시켜줘야 한다.
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((started-with-builtin-tag? exp)
((get-tagged-func exp) exp env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(define (started-with-builtin-tag? exp)
(if (not (pair? exp))
false
(not (null? (get-tagged-func exp)))))
(define (get-tagged-func exp)
(let ((tag (first exp)))
(get tag 'built-in)))
(define (tagged-func-quote exp env) (text-of-quotation exp))
(define (tagged-func-assign exp env) (eval-assignment exp env))
(define (tagged-func-define exp env) (eval-definition exp env))
(define (tagged-func-if exp env) (eval-if exp env))
(define (tagged-func-lambda exp env) (make-procedure (lambda-parameters exp) (lambda-body exp) env))
(define (tagged-func-begin exp env) (eval-sequence (begin-actions exp) env))
(define (tagged-func-cond exp env) (eval (cond->if exp) env))
(put 'quote 'built-in tagged-func-quote)
(put 'assign 'built-in tagged-func-assign)
(put 'define 'built-in tagged-func-define)
(put 'if 'built-in tagged-func-if)
(put 'lambda 'built-in tagged-func-lambda)
(put 'begin 'built-in tagged-func-begin)
(put 'cond 'built-in tagged-func-cond)
4_04
;; file: 4_04.rkt
(#%require rackunit)
(#%require (prefix racket: racket))
(#%require "../allcode/helper/my-util.rkt")
(#%require "../allcode/ch4-4.1.1-mceval.rkt")
;; Install and and or as new special forms
;;
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
;; 여기에 and/or 를 넣어주자.
((and? exp) (builtin-and exp env))
((or? exp) (builtin-or exp env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define (and? exp) (tagged-list? exp 'and))
(define (or? exp) (tagged-list? exp 'or))
(define (builtin-and exp env)
(define (iter env fst rst)
(if (false? (lookup-variable-value fst env))
false
(if (null? rst)
true
(iter env (first rst) (rest rst)))))
(let ((args (rest exp))) ; '(and 1 2 3) => '(1 2 3)
(iter env (first args) (rest args))))
(define (builtin-or exp env)
(define (iter env fst rst)
(if (true? (lookup-variable-value fst env))
true
(if (null? rst)
false
(iter env (first rst) (rest rst)))))
(let ((args (rest exp))) ; '(or 1 2 3) => '(1 2 3)
(iter env (first args) (rest args))))
(check-eq? (eval '(and true true true) (setup-environment)) true)
(check-eq? (eval '(and false true true) (setup-environment)) false)
(check-eq? (eval '(and true false true) (setup-environment)) false)
(check-eq? (eval '(and true true false) (setup-environment)) false)
(check-eq? (eval '(or false false false) (setup-environment)) false)
(check-eq? (eval '(or true false false) (setup-environment)) true)
(check-eq? (eval '(or false true false) (setup-environment)) true)
(check-eq? (eval '(or false false true) (setup-environment)) true)
(define env1 (setup-environment))
(define-variable! 'a true env1)
(check-eq? (eval '(or false false a) env1) true)
;; Derived expressions.
;; 4.1.2Representing Expressions
;; - Derived expressions
;; (cond ((> x 0) x)
;; ((= x 0) (display 'zero) 0)
;; (else (- x)))
;;
;; (if (> x 0)
;; x
;; (if (= x 0)
;; (begin (display 'zero) 0)
;; (- x)))
;;
;; - cond는 if로 변환하여 계산됨
;; -cond는 if로부터 파생된(derived) 표현식임)
;;
;; and / or 역시 if 로 변환하여 계산할 수 있음.
(define (expand-and clauses)
(if (null? clauses)
'true
(let ((fst (car clauses))
(rst (cdr clauses)))
(make-if fst
(expand-and rst)
'false))))
(define (expand-or clauses)
(if (null? clauses)
'false
(let ((fst (car clauses))
(rst (cdr clauses)))
(make-if fst
'true
(expand-or rst)))))
(define (builtin-and-derived exp env) (eval (expand-and (rest exp)) env))
(define (builtin-or-derived exp env) (eval (expand-or (rest exp)) env))
(set! builtin-and builtin-and-derived)
(set! builtin-or builtin-or-derived)
(check-equal? (expand-and '(1 2 3)) '(if 1 (if 2 (if 3 true false) false) false))
(check-equal? (expand-or '(1 2 3)) '(if 1 true (if 2 true (if 3 true false))))
(check-eq? (eval '(and true true true) (setup-environment)) true)
(check-eq? (eval '(and false true true) (setup-environment)) false)
(check-eq? (eval '(and true false true) (setup-environment)) false)
(check-eq? (eval '(and true true false) (setup-environment)) false)
(check-eq? (eval '(or false false false) (setup-environment)) false)
(check-eq? (eval '(or true false false) (setup-environment)) true)
(check-eq? (eval '(or false true false) (setup-environment)) true)
(check-eq? (eval '(or false false true) (setup-environment)) true)
(define env2 (setup-environment))
(define-variable! 'a true env2)
(check-eq? (eval '(or false false a) env2) true)
4_05
;; file: 4_05.rkt
(#%require rackunit)
(#%require (prefix racket: racket))
(#%require "../allcode/helper/my-util.rkt")
(#%require "../allcode/ch4-4.1.1-mceval.rkt")
;; expand-clauses의 (sequence->exp (cond-actions first)) 부분을 수정하면 된다.
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
;; Before:
;; (make-if (cond-predicate first)
;; (sequence->exp (cond-actions first))
;; (expand-clauses rest))
;; After:
(if (=>sequence? first)
(make-if (cond-predicate first)
(expend=>sequence first)
(expand-clauses rest))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest)))))))
(define (=>sequence? clause)
(eq? (second clause) '=>))
(define (expend=>sequence clause)
(list (third clause) (first clause)))
(check-equal? (expend=>sequence '((assoc 'b '((a 1) (b 2))) => cadr))
'(cadr (assoc 'b '((a 1) (b 2)))))
(check-equal? (cond->if '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
(else false)))
'(if (assoc 'b '((a 1) (b 2)))
(cadr (assoc 'b '((a 1) (b 2))))
false))
;;==== additional test
(check-equal? (cond->if '(cond ((= 1 1) true)
(else false)))
'(if (= 1 1)
true
false))
(check-equal? (cond->if '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
((assoc 'b '((a 1) (b 2))) => cadr)))
'(if (assoc 'b '((a 1) (b 2)))
(cadr (assoc 'b '((a 1) (b 2))))
(if (assoc 'b '((a 1) (b 2)))
(cadr (assoc 'b '((a 1) (b 2))))
false)))
;; eval test -----------------------
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(define-variable! 'assoc (list 'primitive assoc) env2)
(define-variable! 'cadr (list 'primitive cadr) env2)
(check-equal? (eval '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
(else false)) env2)
2)
4_06
;; file: 4_06.rkt
;; 4_07 / 4_08 / 4_09 / 4_16 / 4_17 / 4_18
;; 4_22
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.1.1-mceval.rkt" (_eval origin/eval)))
(racket:provide
let?
let->combination)
;; let->combination 구현 ------------------------------
;; 중첩 let을 생각안하면 4_07에서 오류를 맞이할거임.
(define (let->combination let-clause)
(let* ((bindings (second let-clause))
(vars (map first bindings))
(exps (map second bindings))
(body (rest (rest let-clause))))
(cons (make-lambda vars body)
exps)))
(check-equal? (let->combination '(let ((a 1) (b 2)) (+ a b)))
'((lambda (a b) (+ a b)) 1 2))
(check-equal? (let->combination '(let () 1))
'((lambda () 1))
"empty")
;; eval이 let구문을 처리할 수 있도록 수정 ---------------
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((let? exp) (eval (let->combination exp) env)) ;; <<--- 추가.
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define (let? exp) (tagged-list? exp 'let))
;; test -----------------------
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(check-equal? (eval '(let ((a 1) (b 2)) (+ a b)) env2) 3)
(override-eval! origin/eval)
4_07
;; file: 4_07.rkt
;; 4_06 cont
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.1.1-mceval.rkt" (_eval origin/eval)))
(racket:provide
make-let
let*?
let*->nested-lets)
;; 1-1. let*식이 여러개의 let식으로 변환될 수 있는지.
;;
;; (let* ((x 3)
;; (y (+ x 2))
;; (z (+ x y 5)))
;; (* x z)))
;;
;; (let ((x 3))
;; (let ((y (+ x 2)))
;; (let ((z (+ x y 5)))
;; (* x z)))))
;;
;; 1-2. let*->nested-lets 를 작성해라.
(define (make-let binding body)
;; (make-let '((a 1)) '(1 2 3))
;; => (let ((a 1)) 1 2 3)
(if (null? binding)
(append (list 'let '()) body)
(append (list 'let binding) body)))
(check-equal? (make-let '((b 1))
(list (make-let '((a 1))
'((display) (display)))))
'(let ((b 1))
(let ((a 1))
(display)
(display))))
(check-equal? (make-let '((b 1)) '('a 'b))
'(let ((b 1)) 'a 'b))
(define (let*->nested-lets expr)
(define (iter acc bs)
(if (null? bs)
acc
(iter (make-let (list (first bs)) (list acc)) (rest bs))))
(let* ((bindings (reverse (second expr)))
(body (rest (rest expr))))
(if (null? bindings)
(make-let '() body)
(iter (make-let (list (first bindings)) body) (rest bindings)))))
(define (let*? expr)
(tagged-list? expr 'let*))
(check-equal? (let*->nested-lets
'(let* ((x 3)
(y (+ x 2))
(z (+ x y 5)))
(* x z)))
'(let ((x 3))
(let ((y (+ x 2)))
(let ((z (+ x y 5)))
(* x z)))))
(check-equal? (let*->nested-lets
'(let* () 1))
'(let () 1))
(check-equal? (let*->nested-lets
'(let* ((x 3)
(y x))
'a
'b))
'(let ((x 3))
(let ((y x))
'a
'b)))
;; 2.1 eval에 (eval (let*->nested-lets exp) env)를 추가하면 동작할까?
;; 동작 한다.
(#%require "4_06.rkt")
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((let? exp) (eval (let->combination exp) env)) ; <<--- 저번 4_06에서 추가.
((let*? exp) (eval (let*->nested-lets exp) env)) ; <<--- 이번 4_07에서 추가.
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(define-variable! '* (list 'primitive *) env2)
(#%require (prefix r5rs: r5rs))
(define expression '(let* ((x 3)
(y (+ x 2))
(z (+ x y 5)))
(* x z)))
(#%require (prefix trace: racket/trace))
(check-equal? (eval expression env2)
(r5rs:eval expression (scheme-report-environment 5)))
(override-eval! origin/eval)
4_08
#;(#%require errortrace)
;; file: 4_08.rkt
;; 4_06 cont
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "4_06.rkt" (let->combination let->combination-normal)))
(racket:provide
make-define
let->combination)
;; 기존 let->combination
;;
;; (let ((a 1) (b 2)) (+ a b)) => ((lambda (a b) (+ a b)) 1 2)
;;
;; (let <var> <bindings> <body>) 형태를 지원할 수 있도록 수정하해야함.
;;
;; 간단한 named-let expression이 다음과 같다고 하면,
;;
;; (let hello ((a 1) (b 2))
;; (+ a b))
;;
;; a) lambda와 define사용.
;; ((lambda ()
;; (define (hello a b)
;; (+ a b))
;; (hello 1 2)))
;;
(define (make-define func-name args body)
(append (list 'define (append (list func-name) args)) body))
(check-equal? (make-define 'hello '(a b) '(1 2 3 4 5))
'(define (hello a b) 1 2 3 4 5))
(define (let-named->combination let-clause)
(let* ((bindings (third let-clause))
(func-name (second let-clause))
(vars (map first bindings))
(exps (map second bindings))
(body (rest (rest (rest let-clause)))))
(list (make-lambda '()
(list (make-define func-name vars body)
(append (list func-name) exps))))))
(define (let->combination let-clause)
(if (symbol? (second let-clause))
(let-named->combination let-clause)
(let->combination-normal let-clause)))
(check-equal? (let->combination '(let ((a 1) (b 2)) (+ a b)))
'((lambda (a b) (+ a b)) 1 2))
(check-equal? (let->combination '(let hello ((a 1) (b 2))
(+ a b)))
'((lambda ()
(define (hello a b)
(+ a b))
(hello 1 2))))
;; eval이 let구문을 처리할 수 있도록 수정 ---------------
(#%require "../allcode/ch4-4.1.1-mceval.rkt")
(define (let? exp) (tagged-list? exp 'let))
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((let? exp) (eval (let->combination exp) env)) ;; <<--- 추가.
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(define-variable! '- (list 'primitive -) env2)
(define-variable! '= (list 'primitive =) env2)
(check-equal? (eval '(let hello ((a 1) (b 2))
(+ a b))
env2)
3)
(check-equal? (eval '(define (fib n)
(let fib-iter ((a 1)
(b 0)
(count n))
(if (= count 0)
b
(fib-iter (+ a b)
a
(- count 1)))))
env2)
'ok)
(check-equal? (eval '(fib 10) env2) 55)
4_09
;; file: 4_09.rkt
;; 4_06 4_07 cont
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require (prefix racket: racket))
(#%require (prefix r5rs/ r5rs))
(racket:provide
do?
while?
until?
do->expand
while->do
until->do)
;; do / for / while / until 를 derived expression으로 구현해라
;; ref:
;; guile - do - https://www.gnu.org/software/guile/manual/html_node/while-do.html
;; common lisp - do - https://www.lispworks.com/documentation/HyperSpec/Body/m_do_do.htm
;; ruby - do for while until - https://www.geeksforgeeks.org/ruby/ruby-loops-for-while-do-while-until/
;; Derived expressions.
;; 4.1.2Representing Expressions
;; - Derived expressions
;; (cond ((> x 0) x)
;; ((= x 0) (display 'zero) 0)
;; (else (- x)))
;;
;; (if (> x 0)
;; x
;; (if (= x 0)
;; (begin (display 'zero) 0)
;; (- x)))
;;
;; - cond는 if로 변환하여 계산됨
;; -cond는 if로부터 파생된(derived) 표현식임)
(define (second-or-nil expr)
(let ((x (rest expr)))
(if (null? x)
nil
(first x))))
(define (third-or-nil expr)
(let ((x (rest (rest expr))))
(if (null? x)
nil
(first x))))
(define (make-define func-name args body)
(append (list 'define (append (list func-name) args)) body))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (comp f g h)
(lambda (x)
(h (f (g x)))))
(define (make-do vars assigns step-or-nils test ret body)
(list 'let* (map list vars assigns)
(make-define 'loop '()
(list (list 'if test
ret
(append (list 'begin)
body
(~>> (map (lambda (v x) (if (null? x) nil (list 'set! v x))) vars step-or-nils)
(filter (comp not null? identity) ))
'((loop))))))
'(loop)))
(define (do->expand expr)
(let* ((snd (second expr))
(trd (third expr))
(vars (map first snd))
(assigns (map second snd))
(step-or-nils (map third-or-nil snd))
(test (first trd))
(ret (second-or-nil trd))
(body (rest (rest (rest expr)))))
(make-do vars assigns step-or-nils test ret body)))
(check-equal? (do ((i 10 (dec i))
(j '()))
((< i 0) j)
(set! j (cons i j)))
'(0 1 2 3 4 5 6 7 8 9 10))
(check-equal? (do->expand '(do ((i 10 (dec i))
(j '()))
((< i 0) j)
(set! j (cons i j))))
'(let* ((i 10)
(j '()))
(define (loop)
(if (< i 0)
j
(begin
(set! j (cons i j))
(set! i (dec i))
(loop))))
(loop)))
(define (while->do expr)
(let ((vars '())
(assigns '())
(step-or-nils '())
(test (second expr))
(ret (quote '()))
(body (rest (rest expr))))
(make-do vars assigns step-or-nils (list 'not test) ret body)))
(check-equal? (while->do '(while (> i 0)
(set! i (dec i))))
'(let* ()
(define (loop)
(if (not (> i 0))
'()
(begin
(set! i (dec i))
(loop))))
(loop)))
(define (until->do expr)
(let ((vars '())
(assigns '())
(step-or-nils '())
(test (second expr))
(ret (quote '()))
(body (rest (rest expr))))
(make-do vars assigns step-or-nils test ret body)))
(check-equal? (until->do '(until (> i 5)
(set! i (inc i))))
'(let* ()
(define (loop)
(if (> i 5)
'()
(begin
(set! i (inc i))
(loop))))
(loop)))
;; eval이 let구문을 처리할 수 있도록 수정 ---------------
(#%require (all-except "../allcode/ch4-4.1.1-mceval.rkt" eval))
(#%require "4_06.rkt")
(#%require "4_07.rkt")
(define (do? exp) (tagged-list? exp 'do))
(define (while? exp) (tagged-list? exp 'while))
(define (until? exp) (tagged-list? exp 'until))
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((let? exp) (eval (let->combination exp) env)) ; <<--- 저번 4_06에서 추가.
((let*? exp) (eval (let*->nested-lets exp) env)) ; <<--- 저번 4_07에서 추가.
((do? exp) (eval (do->expand exp) env)) ;; <<--- 추가.
((while? exp) (eval (while->do exp) env))
((until? exp) (eval (until->do exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(define-variable! '- (list 'primitive -) env2)
(define-variable! '= (list 'primitive =) env2)
(define-variable! '< (list 'primitive <) env2)
(define-variable! '> (list 'primitive >) env2)
(define-variable! 'inc (list 'primitive inc) env2)
(define-variable! 'dec (list 'primitive dec) env2)
(define-variable! 'not (list 'primitive not) env2)
(check-equal? (eval '(do ((i 10 (dec i))
(j '()))
((< i 0) j)
(set! j (cons i j)))
env2)
'(0 1 2 3 4 5 6 7 8 9 10))
(check-equal? (eval '(let ((acc '())
(i 5))
(while (> i 0)
(set! acc (cons i acc))
(set! i (dec i)))
acc)
env2)
'(1 2 3 4 5))
(check-equal? (eval '(let ((acc '())
(i 1))
(until (> i 5)
(set! acc (cons i acc))
(set! i (inc i)))
acc)
env2)
'(5 4 3 2 1))
4_10
;; file: 4_10.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (all-except "../allcode/ch4-4.1.1-mceval.rkt" eval))
;; 기존 eval과 apply 코드는 그대로 두고 Scheme의 새로운 문법(syntax) 을 설계하고 구현하라.
;; define의 문법을 clojure 처럼 def / defn으로 변경.
;; -- scheme
;; (define x 10)
;; (define (foo a b c)
;; (* a b c))
;;
;; -- clojure
;; (def x 10)
;; (defn foo [a b c]
;; (* a b c))
(define (definition? exp)
(or
(tagged-list? exp 'def)
(tagged-list? exp 'defn)))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(check-equal? (definition-variable '(define (foo a b c)
(* a b c)))
'foo)
(define (definition-variable2 exp)
(if (tagged-list? exp 'def)
(second exp)
(second exp)))
(check-equal? (definition-variable '(defn foo [a b c]
(* a b c)))
'foo)
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(check-equal? (definition-value '(define (foo a b c)
(* a b c)))
'(lambda (a b c) (* a b c)))
(define (definition-value2 exp)
(if (tagged-list? exp 'def)
(caddr exp)
(make-lambda (third exp)
(rest (rest (rest exp))))))
(check-equal? (definition-value2 '(defn foo [a b c]
(* a b c)))
'(lambda (a b c) (* a b c)))
(define (eval-definition exp env)
(define-variable! (definition-variable2 exp)
(eval (definition-value2 exp) env)
env)
'ok)
;; racket모듈 특성상 동일한 코드를 다시 override할 필요가 있음.
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env2 (setup-environment))
(define-variable! '* (list 'primitive *) env2)
(check-equal? (eval '(defn foo [a b c]
(* a b c))
env2)
'ok)
(check-equal? (eval '(foo 2 3 4) env2)
24)
(check-equal? (eval '(def x 10) env2)
'ok)
(check-equal? (eval 'x env2)
10)
4_11
;; file: 4_11.rkt
(#%require rackunit)
(#%require threading)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix old: "../allcode/ch4-4.1.1-mceval.rkt"))
;; - 현재 frame형태
;; - '((symbol-a symbol-b ...) value-a (primitive func-b) ...)
;; - 바꾸고자 하는 frame형태
;; - '((symbol-a value-a) (symbol-b (primitive func-b)) ...)
;;
;; frame관련 함수들
;; - make-frame
;; - add-binding-to-frame!
;; - frame-variables
;; - frame-values
(define frame1 (old:make-frame '(a b) '(1 2)))
(check-equal? frame1
'((a b) 1 2))
(old:add-binding-to-frame! 'c 3 frame1)
(check-equal? frame1
'((c a b) 3 1 2))
(check-equal? (~> (old:make-frame '(a b) '(1 2))
(old:frame-variables))
'(a b))
(check-equal? (~> (old:make-frame '(a b) '(1 2))
(old:frame-values))
'(1 2))
(define (make-frame variables values)
(map list variables values))
(define (add-binding-to-frame! var val frame)
(let ((rst (rest frame))
(var-val (list var val)))
(set-cdr! frame (append rst (list var-val)))))
(define (frame-variables frame)
(map first frame))
(define (frame-values frame)
(map second frame))
(define frame2 (make-frame '(a b) '(1 2)))
(check-equal? frame2
'((a 1) (b 2)))
(add-binding-to-frame! 'c 3 frame2)
(check-equal? frame2
'((a 1) (b 2) (c 3)))
(check-equal? (~> (make-frame '(a b) '(1 2))
(frame-variables))
'(a b))
(check-equal? (~> (make-frame '(a b) '(1 2))
(frame-values))
'(1 2))
4_12
;; file: 4_12.rkt
;; 4_13
(#%require rackunit)
(#%require threading)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.1.1-mceval.rkt"
(define-variable! origin/define-variable!)
(set-variable-value! origin/set-variable-value!)
(lookup-variable-value origin/lookup-variable-value)))
(racket:provide
lookup-variable-values)
;; 주어진 함수들의 공통된 점을 묶어 추상화하고, 그 추상화를 이용하여 다시 정의하라.
;;
;; - define-variable!
;; - set-variable-value!
;; - lookup-variable-value
;;
;; 3함수 모두 env를 돌며, variable의 찾음 여부에 따라 다른 동작들을 수행한다.
;; 종료조건은 var를 찾거나, env(frame list)를 모두 순회한 경우이다.
;; (단 define-variable!인 경우 첫번째 frame만 검사함. env(frame list)를 전부 순회하지 않음.
;;
;; 기타. env 는 [frame1 frame2 ..] 이다.
;; =======================================
(define (lookup-variable-values var env)
;; 함수 모양이 맘에 안들지만, 일단 기존 코드 모양의 수정을 최소화하겠다.
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
vals) ; <<------------ 찾으면 vals를 반환한다.
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
nil ; <<------------ 못찾으면 nil을 반환한다.
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (lookup-variable-value var env)
(let ((vals (lookup-variable-values var env)))
(if (null? vals)
(error "Unbound variable" var)
(first vals))))
(define (set-variable-value! var val env)
(let ((vals (lookup-variable-values var env)))
(if (null? vals)
(error "Unbound variable -- SET!" var)
(set-car! vals val))))
(define (define-variable! var val env)
(let* ((frame (first-frame env))
(toplevel-env (extend-environment (frame-variables frame) (frame-values frame) the-empty-environment))
(vals (lookup-variable-values var toplevel-env)))
(if (null? vals)
(add-binding-to-frame! var val frame)
(set-car! vals val))))
;; testing =======================================
(define env1 (setup-environment))
(check-equal? (lookup-variable-value 'car env1)
(list 'primitive car))
(check-exn #rx"Unbound variable x"
(lambda () (lookup-variable-value 'x env1)))
(check-exn #rx"Unbound variable -- SET! x"
(lambda () (set-variable-value! 'x 1 env1)))
(define-variable! 'x 5 env1)
(check-equal? (lookup-variable-value 'x env1)
5)
(set-variable-value! 'x 1 env1)
(check-equal? (lookup-variable-value 'x env1)
1)
4_13
;; file: 4_13.rkt
;; 4_12
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require "../allcode/ch4-4.1.1-mceval.rkt")
;; scheme에서 define해서 정의한 변수를 지울 수 없음.
;;
;; 1-1. make-unbound! 함수를 만들어 env에서 지울 수 있도록 만들자.
;;
;; 1-2. first-frame에서만 지우면 되는가?
;;
;; - 현재 스코프(첫 프레임)내에서 선언 삭제가 됨으로, 직관적.
;; - 첫 번째 프레임만 뒤지면 되니 탐색이 빠르고 코드가 단순함.
;; - 상위 프레임에 중복된 이름은 살아있음.
;;
;; 앞선 define-variable!도 현재 스코프(첫 프레임)에서만 선언하고 있음.
;;
;; 초판 1985년: SICP
;; 초판 1991년: EOPL Essentials of Programming Languages by Daniel P. Friedman, Mitchell Wand, and Christopher T. Haynes.
;; 초판 1996년: PLP Programming Language Pragmatics by Michael L Scott - https://www.cs.rochester.edu/~scott/pragmatics/
;; 초판 2002년: TaPL Types and Programming Languages by Benjamin C. Pierce - https://www.cis.upenn.edu/~bcpierce/tapl/index.html
;; etc. https://softwarefoundations.cis.upenn.edu/
(define (lookup-variable-vars-vals var env)
;; 함수 모양이 맘에 안들지만, 일단 기존 코드 모양의 수정을 최소화하겠다.
;; values도 있으나, 그냥 list로 감싸겠다. - https://docs.racket-lang.org/reference/values.html
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(list vars vals)) ; <<------------ 찾으면 (vars vals)를 반환한다.
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(list nil nil) ; <<------------ 못찾으면 (nil nil)을 반환한다.
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (make-unbound! env var is-toplevel-only)
(define (which-env env is-toplevel-only)
(if (not is-toplevel-only)
env
(let* ((frame (first-frame env))
(search-env (extend-environment (frame-variables frame) (frame-values frame) the-empty-environment)))
search-env)))
(let* ((frame (first-frame env))
(search-env (which-env env is-toplevel-only))
(vars-vals (lookup-variable-vars-vals var search-env))
(vars (first vars-vals))
(vals (second vars-vals)))
(if (null? vals)
nil
(begin
(let ((rst (rest vars)))
(set-car! vars (first rst))
(set-cdr! vars (rest rst)))
(let ((rst (rest vals)))
(set-car! vals (first rst))
(set-cdr! vals (rest rst)))))))
#;(define env1 (setup-environment))
#;(let ((frame (first-frame env1)))
frame)
;; testing =======================================
(define env1 (setup-environment))
(check-equal? (lookup-variable-value 'car env1)
(list 'primitive car))
(check-exn #rx"Unbound variable x"
(lambda () (lookup-variable-value 'x env1)))
(check-exn #rx"Unbound variable -- SET! x"
(lambda () (set-variable-value! 'x 1 env1)))
(define-variable! 'x 5 env1)
(check-equal? (lookup-variable-value 'x env1)
5)
(set-variable-value! 'x 1 env1)
(check-equal? (lookup-variable-value 'x env1)
1)
(make-unbound! env1 'x #t)
(check-exn #rx"Unbound variable x"
(lambda () (lookup-variable-value 'x env1)))
(check-equal? env1 (setup-environment))
4_14
;; file: 4_14.rkt
(#%require rackunit)
(#%require threading)
(#%require (prefix racket: racket))
(#%require (prefix r5rs: r5rs))
(racket:require "../allcode/ch4-4.1.1-mceval.rkt")
;;
;; 1. Eva Lu Ator은 map의 정의를 직접 입력해서 평가하는 방식.
;; 2. Louis Reasoner는 map을 primitive-procedures에 넣어 버리는 방식.
;; Eva Lu Ator는 잘 동작하는데, Louis Reasoner는 동작하지 않는 이유는?
;;
;; env는
;; 1에서의 map은 (procedure (proc items) ((if (null? items) '() ...) 형태로 저장
;; 2에서의 map은 (primitive #<procedure:mcar>) 형태로 저장.
;; 작성한 eval&apply과정에서 사용하는 데이터가 r5rs에서의 과정과 사용하는 데이터가 맞지않음.
;; 1. Eva Lu Ator (aka, Evaluator) 방식
;;
(define env1 (setup-environment))
(check-equal? (eval '(define (map proc items)
(if (null? items)
'()
(cons (proc (car items))
(map proc (cdr items)))))
env1)
'ok)
(check-equal? (eval '(map car '((a 1) (b 2) (c 3))) env1)
'(a b c))
;; 2. Louis Reasoner (akka, loose reasoner)
;;
(define env2 (setup-environment))
(define-variable! 'map (list 'primitive map) env2) ; 아니면 primitive-procedures를 직접 수정.
(check-exn
racket:exn:fail?
(lambda ()
;; (r5rs:apply map (list (list 'primitive car) '((a 1) (b 2) (c 3)))) 와 같음.
;; application: not a procedure;
;; expected a procedure that can be applied to arguments
;; given: (primitive #<procedure:mcar>)
(eval '(map car '((a 1) (b 2) (c 3))) env2)))
4_15
;; file: 4_15.rkt
;;
;; 정지 문제:
;; - Halting Problem: https://en.wikipedia.org/wiki/Halting_problem
;; - SCOOPING THE LOOP SNOOPER - http://www.lel.ed.ac.uk/~gpullum/loopsnoop.html
;;
;; 가정:
;; 함수 p와 오브젝트 a가 있을시, (p a)를 호출하면 값을 반환하거나, 에러를 뱉거나, 끊임없이 동작한다고 가정하자.
;;
;; 문제:
;; 함수 p와 입력값 a에 대해, (p a)시 멈추는지 아닌지 판별하는 halts?라는 함수를 작성하는게 불가능 하다.
;; 이를 증명해보아라.
;;
;; 증명:
;; 귀류법: 해결방법이 있다라는 가정에서 모순이 발생한다는 것을 보임으로써 증명한다.
;;
;; 만일 halts?라는게 있다면 다음코드를 작성할 수 있을 것이며,
;;
;; (define (run-forever)
;; (run-forever))
;;
;; (define (try p)
;; (if (halts? p p)
;; (run-forever)
;; 'halted))
;;
;; 그런 다음, (try try)를 호출하면 결과가 어떻든(값을 반환하거나, 에러를 뱉거나, 끊임없이 동작),
;; halts?의 정의에 어긋남을 밝히면 된다.
;;
;; (halts? p a)는 (p a)시 멈춘다면 true반환할 것이다.
;; (try try)
;; => (halts? try try) - 만약 참이라면 (try try)시 멈춘다는 말이다. 하지만,
;; => 조건문을 만족시키면서 (run-forever)로 돌면서 (try try)는 멈추지 않고 끊임없이 동작할 것이다.
;; =>(halts? try try) - 만약 것짓이라면, (try try)시 멈추지 않는다는 말이다. 하지만,
;; => 조건문을 만족시키지 못하면서 'halted를 반환하면서 (try try)는 멈추게 된다.:
;; 이 모순된 상황은 halts?의 정의와는 맞지않다.
4_16
;; file: 4_16.rkt
;; 4_06 / 4_18 cont
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require (prefix trace: racket/trace))
(racket:require (racket:rename-in "../allcode/ch4-4.1.1-mceval.rkt"
(_lookup-variable-value origin/lookup-variable-value)
(_make-procedure origin/make-procedure)
(_procedure-body origin/procedure-body)))
(racket:require (racket:prefix-in ex4_06/ "4_06.rkt"))
(racket:provide
lookup-variable-value
scan-out-defines)
;;
;; 1. lookup-variable-value 함수를 고쳐서 변수의 값이 심볼 *unassigned* 면 오류를 내도록 한다.
;;
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
;; - before
;; (car vals)
;;
;; - after
(let ((found (car vals)))
(if (eq? found '*unassigned*)
(error "Unssigned variable" var)
found)))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(override-lookup-variable-value! lookup-variable-value)
(define env1 (setup-environment))
(check-exn #rx"Unbound variable x"
(lambda () (lookup-variable-value 'x env1)))
(check-equal? (eval '(define x '*unassigned*) env1)
'ok)
(check-exn #rx"Unssigned variable x"
(lambda () (lookup-variable-value 'x env1)))
;;
;; 2. procedure body를 받아(lambda로 시작하는) 앞에 본것처럼 내부에 define이 없도록 변환과정을 거쳐 반환하는 scan-out-defines를 작성해라.
;;
;; - before
;; (lambda <vars>
;; (define u <e1>)
;; (define v <e2>)
;; <e3>)
;;
;; - after
;; (lambda <vars>
;; (let ((u '*unassigned*)
;; (v '*unassigned*))
;; (set! u <e1>)
;; (set! v <e2>)
;; <e3>)))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence)
(filter predicate
(cdr sequence))))
(else (filter predicate
(cdr sequence)))))
(define (complement f)
(lambda (x)
(not (f x))))
(define (make-let bindings body)
;; (make-let '((a 1)) '((+ a 2)))
;; => (let ((a 1)) (+ a 2))
(append (list 'let bindings) body))
(define (scan-out-defines body)
(let ((defs (filter definition? body)))
(if (null? defs)
body
(let* ((body-without-defs (filter (complement definition?) body))
(vars (map definition-variable defs))
(vals (map definition-value defs))
(bindings (map (lambda (x) (list x ''*unassigned*)) vars))
(assigns (map (lambda (x y) (list 'set! x y)) vars vals)))
(list (make-let bindings
(append assigns body-without-defs)))))))
(check-equal? (scan-out-defines (lambda-body '(lambda (x)
(define u 1)
(define v 2)
(+ u v x))))
'((let ((u '*unassigned*)
(v '*unassigned*))
(set! u 1)
(set! v 2)
(+ u v x))))
;;
;; 3. scan-out-defines 을 인터프리터안에 넣는데,
;; - make-procedure 쪽이 좋을까 procedure-body 쪽이 좋을까?
;; make-procedure 쪽
;; - 그리고 그 이유는?
;; eval타임인가 apply타임인가 문제인데,
;; 인터프리터 구현체가 eval타임에서 구문을 확장하고 apply를 돌며 실제 scheme쪽 apply를 호출.
;; eval타임에서 구문을 확장해 나갈때 같이 확장해 놓는게 좋다.
;; === make-procedure
;; (define (make-procedure parameters body env)
;; (list 'procedure parameters body env))
;;
;; (define (eval exp env)
;; (cond (
;; ...
;; ((lambda? exp)
;; (make-procedure (lambda-parameters exp) ; <-----------------------
;; (lambda-body exp)
;; env))
;; ...
;; )))
;;
;; === procedure-body
;; (define (procedure-body p) (caddr p)) ;; third
;;
;; (define (apply procedure arguments)
;; (cond ((primitive-procedure? procedure)
;; (apply-primitive-procedure procedure arguments))
;; ((compound-procedure? procedure)
;; (eval-sequence
;; (procedure-body procedure) ; <-----------------------
;; (extend-environment
;; (procedure-parameters procedure)
;; arguments
;; (procedure-environment procedure))))
;; (else
;; (error
;; "Unknown procedure type -- APPLY" procedure))))
;; 수정한다면,
(define env2 (setup-environment))
(define env3 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(define-variable! '+ (list 'primitive +) env3)
(around
(begin
(define (make-procedure parameters body env)
;; 4_06에서 ((let? exp) (eval (let->combination exp) env)) 을
;; 추가 했다면.
;; (list 'procedure parameters (scan-out-defines body) env)
;;
;; 추가하지 않았다면,
(list 'procedure parameters
(map (lambda (x)
(if (ex4_06/let? x)
(ex4_06/let->combination x)
x))
(scan-out-defines body))
env))
(override-make-procedure! make-procedure)
(override-procedure-body! origin/procedure-body))
(test-case "make-procedure"
(check-equal? (eval '(define (hello x)
(define u 1)
(define v 2)
(+ u v x))
env2)
'ok)
;; hello body의 define이 lambda로 풀어진 상태로 저장되어 있다.
(check-equal? (third (lookup-variable-value 'hello env2))
'(((lambda (u v)
(set! u 1)
(set! v 2)
(+ u v x))
'*unassigned*
'*unassigned*)))
(check-equal? (eval '(hello 3) env2)
6)
)
(begin
(override-make-procedure! origin/make-procedure)
(override-procedure-body! origin/procedure-body)))
(around
(begin
(define (procedure-body p)
;; 4_06에서 ((let? exp) (eval (let->combination exp) env)) 을
;; 추가 했다면.
;; (scan-out-defines (third p))
;;
;; 추가하지 않았다면,
(map (lambda (x)
(if (ex4_06/let? x)
(ex4_06/let->combination x)
x))
(scan-out-defines (third p))))
(override-make-procedure! origin/make-procedure)
(override-procedure-body! procedure-body))
(test-case "procedure-body"
(check-equal? (eval '(define (hello x)
(define u 1)
(define v 2)
(+ u v x))
env3)
'ok)
;; hello body의 define이 lambda로 풀어지지 않은 상태로 저장되어 있다.
(check-equal? (third (lookup-variable-value 'hello env3))
'((define u 1)
(define v 2)
(+ u v x)))
;; application평가시에 scan-out-defines이 일어남
(check-equal? (eval '(hello 3) env3)
6)
)
(begin
(override-make-procedure! origin/make-procedure)
(override-procedure-body! origin/procedure-body)))
(override-lookup-variable-value! origin/lookup-variable-value)
4_17
;; file: 4_17.rkt
;; 4_06 cont
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require (prefix trace: racket/trace))
(racket:require (racket:rename-in "../allcode/ch4-4.1.1-mceval.rkt"
(_make-procedure origin/make-procedure)
(_procedure-body origin/procedure-body)))
(racket:require (racket:prefix-in ex4_06/ "4_06.rkt"))
;; 본문에 나온 <e3>을 평가할때의 environment를 다이어그램으로 그려라
;;
;; 첫번째 방식
;; (lambda (x)
;; (define u 1) ; 실행 시, 현재 프레임에 u를 만들고 값 1 할당
;; (define v 2) ; 실행 시, 현재 프레임에 v를 만들고 값 2 할당
;; (+ u v x))
;;
;; Global Env
;; |
;; v
;; +----------------+
;; | proc | --> [params: (x) body: ...] Env=Global
;; +----------------+
;; \
;; v
;; +------------------+
;; | Frame F1 | (procedure call frame)
;; +------------------+
;; | x = ARG |
;; | u = 1 |
;; | v = 2 |
;; +------------------+
;; |
;; e3: (+ u v x) ; lookup all in F1
;;
;; 두번째 방식(변환된 방식)
;; (lambda (x)
;; (let ((u '*unassigned*)
;; (v '*unassigned*))
;; (set! u 1)
;; (set! v 2)
;; (+ u v x)))
;;
;;
;; Global Env
;; |
;; v
;; +----------------+
;; | proc | --> [params: (x) body: let ...] Env=Global
;; +----------------+
;; \
;; v
;; +----------------+
;; | Frame F1 | (procedure call frame)
;; +----------------+
;; | x = ARG |
;; +----------------+
;; |
;; v
;; +------------------+
;; | Frame F2 | (let frame)
;; +------------------+
;; | u = *unassigned* |
;; | v = *unassigned* |
;; +------------------+
;; set! u 1
;; set! v 2
;; e3: (+ u v x) ; u,v in F2, x in F1
;;
;;
;; 변환된 프로그램에서 왜 추가 프레임(extra frame)이 생기는가?
;; => let이 lambda로 변환되면서 frame이 생성
;; 왜 이 차이가 동작에 영향을 주지 않는가?
;; => 값을 참조하는 시점에는 이미 초기화 되어있음.
;; 추가 프레임을 만들지 않고, 내부 정의에 대해 "동시(simultaneous)" 스코프 규칙을 인터프리터가 구현하도록 하는 방법을 설계하라.
;; simultaneous 발음
;; 미국식 ˌsaɪ.məlˈteɪ.niəs / 사이멀테이니어스
;; 영국식 ˌsɪm.əlˈteɪ.ni.əs / 시멀테이니어스
;;
;; simultaneous 방식( 두번째와 비슷하지만 추가 프레임 생성 안함.)
;; (lambda (x)
;; (define u '*unassigned*)
;; (define v '*unassigned*)
;; (set! u (+ v 1))
;; (set! v 2)
;; (+ u v x))
;;
;; Global Env
;; |
;; v
;; +----------------+
;; | proc | --> [params: (x) body: ...] Env=Global
;; +----------------+
;; \
;; v
;; +------------------+
;; | Frame F1 | (procedure call frame)
;; +------------------+
;; | x = ARG |
;; | u = *unassigned* |
;; | v = *unassigned* |
;; +------------------+
;; |
;; set! u 1
;; set! v 2
;; e3: (+ u v x) ; lookup all in F1
;;
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence)
(filter predicate
(cdr sequence))))
(else (filter predicate
(cdr sequence)))))
(define (complement f)
(lambda (x)
(not (f x))))
(define (scan-out-defines-simultaneous body)
(let ((defs (filter definition? body)))
(if (null? defs)
body
(let* ((vars (map definition-variable defs))
(vals (map definition-value defs))
(unassigns-defs (map (lambda (var) (list 'define var ''*unassigned*)) vars))
(assigns (map (lambda (x y) (list 'set! x y)) vars vals))
(body-without-defs (filter (complement definition?) body)))
;; 현재 프레임에 바인딩 추가만 하고 let은 안 씀
(append
unassigns-defs
assigns
body-without-defs)))))
(check-equal? (scan-out-defines-simultaneous (lambda-body '(lambda (x)
(define u (+ v 1))
(define v 2)
(+ u v x))))
'((define u '*unassigned*)
(define v '*unassigned*)
(set! u (+ v 1))
(set! v 2)
(+ u v x)))
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(around
(begin
(define (make-procedure parameters body env)
;; 4_06에서 ((let? exp) (eval (let->combination exp) env)) 을
;; 추가 했다면.
;; (list 'procedure parameters (scan-out-defines body) env)
;;
;; 추가하지 않았다면,
(list 'procedure parameters
(map (lambda (x)
(if (ex4_06/let? x)
(ex4_06/let->combination x)
x))
(scan-out-defines-simultaneous body))
env))
(override-make-procedure! make-procedure)
(override-procedure-body! origin/procedure-body))
(test-case "make-procedure"
(check-equal? (eval '(define (hello x)
(define u 1)
(define v 2)
(+ u v x))
env2)
'ok)
;; hello body의 define이 lambda로 풀어진 상태로 저장되어 있다.
(check-equal? (third (lookup-variable-value 'hello env2))
'((define u '*unassigned*)
(define v '*unassigned*)
(set! u 1)
(set! v 2)
(+ u v x)))
(check-equal? (eval '(hello 3) env2)
6)
)
(begin
(override-make-procedure! origin/make-procedure)
(override-procedure-body! origin/procedure-body)))
4_18
;; file: 4_18.rkt
;; 4_06 / 4_16 / 4_20 cont
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require (prefix trace: racket/trace))
(racket:require (racket:rename-in "../allcode/ch4-4.1.1-mceval.rkt"
(_make-procedure origin/make-procedure)
(_procedure-body origin/procedure-body)))
(racket:require (racket:prefix-in ex4_06/ "4_06.rkt"))
(racket:require (racket:prefix-in ex4_16/ "4_16.rkt"))
;; - before
;; (lambda <vars>
;; (define u <e1>)
;; (define v <e2>)
;; <e3>)
;;
;; - 본문방식
;; (lambda <vars>
;; (let ((u '*unassigned*)
;; (v '*unassigned*))
;; (set! u <e1>)
;; (set! v <e2>)
;; <e3>)))
;;
;; - 이번 문제 방식
;; - 여기서 a와 b는 인터프리터가 새로 생성한 변수명으로, 사용자의 원래 프로그램에는 등장하지 않는다.
;; (lambda <vars>
;; (let ((u '*unassigned*)
;; (v '*unassigned*))
;; (let ((a <e1>)
;; (b <e2>))
;; (set! u a)
;; (set! v b))
;; <e3>))
;;
;; 3.5.4의 solve는
;; (define (solve f y0 dt)
;; (define y (integral (delay dy) y0 dt))
;; (define dy (stream-map f y))
;; y)
;;
;; - 본문방식이면
;; (let ((y '*unassigned*)
;; (dy '*unassigned*))
;; (set! y (integral (delay dy) y0 dt))
;; (set! dy (stream-map f y)) ; <---- dy에 제대로 된 값이 저장된다.
;; (+ u v x)))
;;
;; - 이번 문제 방식에서는 이렇게 변환된다.
;; (let ((y '*unassigned*)
;; (dy '*unassigned*))
;; (let ((a (integral (delay dy) y0 dt))
;; (b (stream-map f y))) ; <---- b에 (stream-map f '*unassigned*)라는 올바르지 않은 값이 저장되고, 4_16을 구현했으면 y를 가져다 쓰는 순간 에러.
;; (set! y a)
;; (set! dy b)) ; <---- 최종적으로 dy에 제대로 되지않은 b값이 저장된다.
;; (+ u v x)))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence)
(filter predicate
(cdr sequence))))
(else (filter predicate
(cdr sequence)))))
(define (take n lst)
(define (iter n lst acc)
(cond
((or (<= n 0) (null? lst))
(reverse acc))
(else
(iter (- n 1) (cdr lst) (cons (car lst) acc)))))
(iter n lst '()))
(define (complement f)
(lambda (x)
(not (f x))))
(define (make-let bindings body)
;; (make-let '((a 1)) '((+ a 2)))
;; => (let ((a 1)) (+ a 2))
(append (list 'let bindings) body))
(define (scan-out-defines-4_18 body)
(let ((defs (filter definition? body)))
(if (null? defs)
body
(let* ((body-without-defs (filter (complement definition?) body))
(vars (map definition-variable defs))
(vals (map definition-value defs))
(len (length vars))
(var2 (take len '(a b c d e f g)))
(bindings (map (lambda (x) (list x ''*unassigned*)) vars))
(bindings2 (map (lambda (x y) (list x y)) var2 vals))
(assigns (map (lambda (x y) (list 'set! x y)) vars var2)))
(list (make-let bindings
(append (list (make-let bindings2
assigns))
body-without-defs)))))))
(check-equal? (scan-out-defines-4_18 (lambda-body '(lambda (x)
(define u 1)
(define v (+ 2 u))
(+ u v x))))
'((let ((u '*unassigned*)
(v '*unassigned*))
(let ((a 1)
(b (+ 2 u)))
(set! u a)
(set! v b))
(+ u v x))))
(define env2 (setup-environment))
(define env3 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(define-variable! '+ (list 'primitive +) env3)
(override-lookup-variable-value! ex4_16/lookup-variable-value)
(around
(begin
(define (make-procedure parameters body env)
;; 4_06에서 ((let? exp) (eval (let->combination exp) env)) 을
;; 추가 했다면.
;; (list 'procedure parameters (scan-out-defines-4_18 body) env)
;;
;; 추가하지 않았다면,
(list 'procedure parameters
(map (lambda (x)
(if (ex4_06/let? x)
(ex4_06/let->combination x)
x))
(scan-out-defines-4_18 body))
env))
(override-make-procedure! make-procedure)
(override-procedure-body! origin/procedure-body))
(test-case "make-procedure"
(check-equal? (eval '(define (hello x)
(define u 1)
(define v (+ 2 u))
(+ u v x))
env2)
'ok)
(check-exn #rx"Unssigned variable u"
(lambda ()
(eval '(hello 3) env2)))
)
(begin
(override-make-procedure! origin/make-procedure)
(override-procedure-body! origin/procedure-body)))
4_19
;; file: 4_19.rkt
;; (let ((a 1))
;; (define (f x)
;; (define b (+ a x))
;; (define a 5)
;; (+ a b))
;; (f 10))
;; Ben Bitdiddle 의견
;; 순차적 규칙(sequential rule) - c / python ...
;; a = 1 (let ((a 1))
;; x = 10 (f 10)
;; b = 11 (+ a x)
;; a = 5
;;
;; (+ a b) => 16
;; Alyssa P. Hacker 의견
;; 동시 범위(simultaneous scope) 규칙 - scheme
;; a = 1 (let ((a 1))
;; x = 10 (f 10)
;; b = *unassigned*
;; a = *unassigned*
;; b = 에러발생 (+ *unassigned* x)
;; Eva Lu Ator 의견
;; Layzy Evaluation - haskell / OCaml ...
;; a = 1 (let ((a 1))
;; x = 10 (f 10)
;; b = lazy(+ a x)
;; a = 5
;;
;; (+ a b) = 5 + lazy(+ a x)
;; = 5 + (+ 5 10)
;; = 20
;; 1. 세 가지 관점 중 어느 것(또는 어느 것도 아닌 것)을 지지하는가?
;; 살짝 정적 분석같은 기믹도 가미된 Alyssa P.
;;
;; 2. Eva Lu Ator 의견에 따라 동작하도록 구현할 수 있는가?
;; 정의부를 lambda식으로 감싸 실제 필요할때 평가도록 하면 될꺼같은데...
4_20
;; file: 4_20.rkt
;; 4_17 / 4_18 / 4_21
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.1.1-mceval.rkt" (_eval origin/eval)))
;; | 구문 | 바인딩 생성 방식 | 앞 변수 참조 | 상호/자기 참조 |
;; | -------- | ----------------------------------- | ------------ | -------------- |
;; | `let` | 모든 값 먼저 계산 후 한 번에 바인딩 | ❌ | ❌ |
;; | `let*` | 순차적으로 바인딩 생성 | ⭕ | ❌ |
;; | `letrec` | 이름만 먼저 바인딩 후 값 설정 | ⭕ | ⭕ |
;; letrec: let recursive
;;
;; a. letrec을 derived expression로 처리. 연습문제 4.18 처럼 변수는 let으로 생성, set!으로 설정하라.
;;
(#%require (only "4_06.rkt" let? let->combination))
(#%require (only "4_07.rkt" make-let ))
(define (letrec->let expr)
(let* ((bindings (second expr))
(body (rest (rest expr)))
(vars (map first bindings))
(new-bindings (map (lambda (x) (list x ''*unassigned*)) vars))
(vals (map second bindings))
(setter (map (lambda (x y) (list 'set! x y)) vars vals)))
(make-let new-bindings (append setter body))))
(check-equal? (letrec->let
'(letrec ((x 1))
(+ x 2)))
'(let ((x '*unassigned*))
(set! x 1)
(+ x 2)))
(check-equal? (letrec->let
'(letrec ((fact
(lambda (n)
(if (= n 1)
1
(* n (fact (- n 1)))))))
(fact 10)))
'(let ((fact '*unassigned*))
(set! fact
(lambda (n)
(if (= n 1)
1
(* n (fact (- n 1))))))
(fact 10)))
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((let? exp) (eval (let->combination exp) env))
((letrec? exp) (eval (letrec->let exp) env)) ;; <<--- 추가.
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(define-variable! '- (list 'primitive -) env2)
(define-variable! '* (list 'primitive *) env2)
(define-variable! '= (list 'primitive =) env2)
(check-equal? (eval '(letrec ((x 1))
(+ x 2))
env2)
3)
(check-eq? (eval '(letrec ((fact
(lambda (n)
(if (= n 1)
1
(* n (fact (- n 1)))))))
(fact 10))
env2)
3628800)
(check-eq? (letrec ((fact
(lambda (n)
(if (= n 1)
1
(* n (fact (- n 1)))))))
(fact 10))
3628800)
;;
;; b. (f 5)를 평가하는 동안 <rest of body of f>가 평가되는 환경(environment)을 나타내는
;; letrec버전 let버전에 대한 environment diagram을 그려라.
;; (odd?/even?은 이미 정의되어 있어, 오류를 확인하기 위해 odd?/even?을 new-odd?/new-even?으로 변경.)
;; let 버전
(define expr-v-let
'(define (f x)
;; (f 5)
;; f 호출 환경 (x = 5)
;; ┌─────────────────────────────┐
;; │ f-frame │
;; │ x → 5 │
;; └─────────────────────────────┘
;;
;; let-frame
;; ┌─────────────────────────────┐
;; │ new-even? → <lambda> │ << lambda를 정의시 new-odd?를 찾아보는데 정의가 되지않아 오류가 나타난다.
;; │ new-odd? |
;; └─────────────────────────────┘
(let ((new-even?
(lambda (n)
(if (= n 0)
true
(new-odd? (- n 1))))) ; new-odd?: unbound identifier in: new-odd?
(new-odd?
(lambda (n)
(if (= n 0)
false
(new-even? (- n 1))))))
"<rest of body of f>"
(new-even? x))))
(define env3 (setup-environment))
(define-variable! '+ (list 'primitive +) env3)
(define-variable! '- (list 'primitive -) env3)
(define-variable! '* (list 'primitive *) env3)
(define-variable! '= (list 'primitive =) env3)
(check-equal? (eval expr-v-let
env3)
'ok)
(check-exn #rx"Unbound variable new-odd?"
(lambda ()
(eval '(f 5) env3)))
;; letrec 버전
(define expr-v-letrec
'(define (f x)
;; (f 5)
;; f 호출 환경 (x = 5)
;; ┌─────────────────────────────┐
;; │ f-frame │
;; │ x → 5 │
;; └─────────────────────────────┘
;;
;; letrec-frame
;; ┌─────────────────────────────┐
;; │ new-even? → <unassigned> │
;; │ new-odd? → <unassigned> │
;; └─────────────────────────────┘
;; set! new-even? <lambda>
;; set! new-odd? <lambda>
(letrec ((new-even?
(lambda (n)
(if (= n 0)
true
(new-odd? (- n 1)))))
(new-odd?
(lambda (n)
(if (= n 0)
false
(new-even? (- n 1))))))
"<rest of body of f>"
(new-even? x))))
(define env4 (setup-environment))
(define-variable! '+ (list 'primitive +) env4)
(define-variable! '- (list 'primitive -) env4)
(define-variable! '* (list 'primitive *) env4)
(define-variable! '= (list 'primitive =) env4)
(check-equal? (eval expr-v-letrec
env4)
'ok)
(check-eq? (eval '(f 5) env4)
false)
(override-eval! origin/eval)
4_21
;; file: 4_21.rkt
(#%require rackunit)
(#%require (only racket λ))
;; Stoy 1977 for details on the λ-calculus,
;;Gabriel 1988 for an exposition of the Y operator in Scheme
;; lambda calculus 람다 대수.
;; - https://en.wikipedia.org/wiki/Lambda_calculus
;; - [Lambda Calculus - Fundamentals of Lambda Calculus & Functional Programming in JavaScript](https://www.youtube.com/watch?v=3VQ382QG-y4)
;; - 모든 기계적인 계산은 람다 대수로 표현할 수 있다
;; - turing completeness 만족.
;; - 어떤 프로그래밍 언어나 추상 기계가 튜링 기계와 동일한 계산 능력을 가진다는 의미
;;
;; Application
;; f x = (f x)
;; f x y = ((f x) y) = (f x) y
;; f (x y) = (f (x y))
;;
;; λ Lambda
;; λparameter.return
;; λx.a = (λ (x) a) | x => a
;; λx.a b = (λ (x) (a x)) | x => (a x)
;; λx.λy.a = (λ (x) (λ (y) a)) | x => y => a
;; (λx. a) b = ((λ (x) a) b) | (x => a)(b)
;;
;; α-equivalence 동치. 변수 이름이 다른 두 람다 표현식이 구조상 같을때.
;; λx.x 와 λy.y
;; (f (x) x) 와 (f (y) y)
;; α-conversion 변환. 변수 이름 바꾸기(이름 충돌 방지).
;; λx.(λx.x) => λx.(λy.y)
;; (f (x) (f (x) x)) => (f (x) (f (y) y))
;; β-reduction 축소. 함수 적용 후 변수 치환
;; ((λx.M) N) => M
;; ((λ (x) (+ x 1)) 3) => (+ 3 1) => 4
;; η-conversion 변환. 불필요한 래핑 제거
;; (Η η eta /ˈiːtə, ˈeɪtə/ 이터 / 에이터)
;; λx.(fx) => f
;; (λ (x) (f x)) => f
;;
;; Church encoding
;; https://en.wikipedia.org/wiki/Church_encoding
;;
;; TRUE = λt. λf. t = (λ (t) (λ (f) t)) // 첫 번째 인자만 고르는 함수
;; FALSE = λt. λf. f = (λ (t) (λ (f) f)) // 두 번째 인자만 고르는 함수
;; ...
;;
;; Combinator: free variable이 없는 함수.
;; (λ (x) x) : 함수이면서, free variable이 없어 combinator.
;; (λ (x) a) : 함수이지만, free variable a가 있어 combinator가 아님.
;;
;; Fixed-point combinator (고정점 결합자)
;; - https://en.wikipedia.org/wiki/Fixed-point_combinator
;; - 함수의 재귀적 자기 참조를 가능하게 하는 함수
;; - 함수 f의 고정점 x는 f(x) = x가 성립하는 x입니다.
;; (f x) = x
;; (f (f x)) = x
;; - Y Combinator, Z Combinator 등 다양한 형태가 가능
;;
;; Y Combinator.
;; - λ-계산에서는 함수에 자기 자신을 직접 호출 할 수 없음.
;; - 하지만 함수를 인자를 받아 활용하면 재귀적인 동작이 가능함.
;; - 이 재귀적인 동작을 가능케하는 함수가 바로 Y Combinator.
;; - 단일 인자 함수에 대해 재귀를 가능하게 함
;;
;; Y = λf.(λx.f(x x))(λx.f(x x))
;; = (λ (f)
;; ((λ (x) (f (x x)))
;; (λ (x) (f (x x)))))
;; (Y a) = (a (Y a))
;; 풀어쓰면 햇갈리니 두번째 (λ (x) (f (x x)))를 (λ (y) (f (y y))로 α-conversion
;; = ((λ (f)
;; ((λ (x) (f (x x)))
;; (λ (y) (f (y y)))))
;; a)
;; f에 a를 넣으면 (β-reduction)
;; = ((λ (x) (a (x x)))
;; (λ (y) (a (y y))))
;; x에 (λ (y) (a (y y)))를 넣으면 (β-reduction)
;; = (a ( (λ (y) (a (y y)))
;; (λ (y) (a (y y))) ) )
;; a를 다시 빼주면 ( α-conversion )
;; = (a ((λ (f)
;; ((λ (y) (f (y y)))
;; (λ (y) (f (y y))))) a))
;;다시 (λ (y) (f (y y)))를 (λ (x) (f (x x)))로 변경시켜주고 α-conversion
;; = (a ((λ (f)
;; ((λ (x) (f (x x)))
;; (λ (x) (f (x x))))) a))
;; Y = (λ (f) ((λ (x) (f (x x))) (λ (x) (f (x x))))) 이므로
;; = (a (Y a))
;; = (Y a)
;; 즉 Y에 a를 넣으면 a가 재귀적으로 계속 호출됨.
;;
;; Z Combinator
;; Z = λf.(λx.f(λv. xxv))(λx.f(λv. xxv))
;; = (λ (f)
;; ((λ (x)
;; (f (λ (v) ((x x) v))))
;; (λ (x)
;; (f (λ (v) ((x x) v))))))
;;
;; -ref: Lambda-Calculus and Combinators : An Introduction
;; letrec을 쓰지 않고도 재귀 프로시져를 만들 수 있음.
(define Y
(λ (f)
((λ (x)
(f (x x)))
(λ (x)
(f (x x))))))
(define Z
(λ (f)
((λ (x)
(f (λ (v) ((x x) v))))
(λ (x)
(f (λ (v) ((x x) v)))))))
(check-eq? ((Z
(lambda (fact)
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1)))))))
10)
3628800)
(check-eq? ((λ (n)
((λ (x)
(x x 0 n))
(λ (iter acc y)
(if (= y 0)
acc
(iter iter (+ acc y) (- y 1))))))
10)
55)
;; 1-1. 표현식을 평가하여 factorial이 돌아가는지 확인.
(check-eq? ((lambda (n)
((lambda (fact)
(fact fact n))
(lambda (ft k)
(if (= k 1)
1
(* k (ft ft (- k 1)))))))
10)
3628800)
;; 1-2. 피보나치 수를 구하는 함수 작성.
(check-eq? (let ()
(define (fib n)
(cond ((= n 0) 0)
((= n 1) 1)
(else
(+ (fib (- n 1))
(fib (- n 2))))))
(fib 10))
55)
(check-eq? ((lambda (n)
((lambda (fibo)
(fibo fibo n))
(lambda (fb n)
(cond ((= n 0) 0)
((= n 1) 1)
(else
(+ (fb fb (- n 1))
(fb fb (- n 2))))))))
10)
55)
(check-eq? ((Z
(lambda (fibo)
(lambda (n)
(cond ((= n 0) 0)
((= n 1) 1)
(else
(+ (fibo (- n 1))
(fibo (- n 2))))))))
10)
55)
;; 2. 빈칸을 체워서 다음과 같은 함수와 동일한 함수 작성.
;; (define (f x)
;; ((lambda (new-even? new-odd?)
;; (new-even? new-even? new-odd? x))
;; (lambda (ev? od? n)
;; (if (= n 0)
;; true
;; (od? <??> <??> <??>)))
;; (lambda (ev? od? n)
;; (if (= n 0)
;; false
;; (ev? <??> <??> <??>)))))
(define (f x)
(define (new-even? n)
(if (= n 0)
true
(new-odd? (- n 1))))
(define (new-odd? n)
(if (= n 0)
false
(new-even? (- n 1))))
(new-even? x))
(check-eq? (f 5) false)
(check-eq? (f 6) true)
(define (f2 x)
((lambda (new-even? new-odd?)
(new-even? new-even? new-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))))))
(check-eq? (f2 5) false)
(check-eq? (f2 6) true)
4_22
;; file: 4_22.rkt
(#%require (prefix racket: racket))
(#%require rackunit)
(racket:require "4_06.rkt")
(racket:require (racket:rename-in "../allcode/ch4-4.1.7-analyzingmceval.rkt" (_analyze origin/analyze)))
(racket:provide
analyze-let
)
;; 4_06 참고. let을 처리 할 수 있도록 확장.
(define (analyze-let exp)
(analyze (let->combination exp)))
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze-let exp)) ;; <----- 4_22 추가됨.
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(override-analyze! analyze)
(define env2 (setup-environment))
(define-variable! '+ (list 'primitive +) env2)
(check-equal? ((analyze '(let ((a 1) (b 2)) (+ a b))) env2)
3)
(override-analyze! origin/analyze)
4_23
;; file: 4_23.rkt
(#%require (prefix racket: racket))
(#%require (prefix trace: racket/trace))
(#%require rackunit)
(racket:require "4_06.rkt")
(racket:require (racket:rename-in "../allcode/ch4-4.1.7-analyzingmceval.rkt"
(_analyze origin/analyze)
(_analyze-sequence origin/analyze-sequence)))
;;
;; Q. analyze-sequence의 본문 버전과, Alyssa의 버전을 비교. expr가 2개인 경우, 1개인 경우 어떻게 돌아가는지 비교해라.
;;
;; ver. Original
(define (analyze-sequence-original exps)
(define (sequentially proc1 proc2)
(lambda (env)
(proc1 env)
(proc2 env)))
(define (loop first-proc rest-procs)
(if (null? rest-procs)
first-proc
(loop (sequentially first-proc (car rest-procs))
(cdr rest-procs))))
(let ((procs (map analyze exps)))
(if (null? procs)
(error "Empty sequence -- ANALYZE"))
(loop (car procs) (cdr procs))))
;; ver. Alyssa P. Hacker
(define (analyze-sequence-alyssa exps)
(define (execute-sequence procs env)
(cond ((null? (cdr procs))
((car procs) env))
(else
((car procs) env)
(execute-sequence (cdr procs) env))))
(let ((procs (map analyze exps)))
(if (null? procs)
(error "Empty sequence -- ANALYZE"))
(lambda (env)
(execute-sequence procs env))))
;; 2개 버전, 1개 버전을 비교하라 했지만, 2개 보다 3개가 좀 더 알기 편할꺼임.
;;
;; 3개버전이라고 하면 procs가 (a1 a2 a3)가 되고
;;
;; ver. Original
;; procs의 리스트 순회를 미리 해버림 없음. lambda로 펼쳐져 있게됨.
;; (lambda (env)
;; ((lambda (env)
;; (a1 env)
;; (a2 env))
;; env)
;; (a3 env))
;;
;; ver. Alyssa P. Hacker
;; execute-sequence를 통한 procs 리스트 순회를 하게됨.
;; (lambda (env)
;; 처음꺼 꺼내오고(execute-sequence)
;; (a1 env)
;; 다음꺼 꺼내오고(execute-sequence)
;; (a2 env)
;; 다음꺼 꺼내오고(execute-sequence)
;; (a3 env)
;; )
;;
;; 1개버전이라고 하면 procs가 (a1)가 되고
;;
;; ver. Original
;; 1개인 경우 그냥 원래것이 빠져나오게 됨.
;; a1
;;
;; ver. Alyssa P. Hacker
;; execute-sequence를 통한 procs 리스트 순회를 하게됨.
;; (lambda (env)
;; 처음꺼 꺼내오고(execute-sequence)
;; (a1 env)
;; )
4_24
;; file: 4_24.rkt
(#%require profile)
(#%require (prefix racket: racket))
(racket:require (racket:prefix-in mceval: "../allcode/ch4-4.1.1-mceval.rkt"))
(racket:require (racket:prefix-in analyzing: "../allcode/ch4-4.1.7-analyzingmceval.rkt"))
;; 이전 버전의 evaluator와 이번 단락에서 소개한 버전(analyze)을 속도 측면에서 비교하기 위한 몇 가지 실험을 설계하고 수행하라.
;; 그 결과를 이용하여, 다양한 프로시저에 대해 분석 단계와 실행 단계 각각에 소요되는 시간의 비율을 추정하라.
;; profile-thunk
;; https://docs.racket-lang.org/profile/index.html#%28def._%28%28lib._profile%2Fmain..rkt%29._profile-thunk%29%29
;; time - https://docs.racket-lang.org/reference/time.html#%28form._%28%28lib._racket%2Fprivate%2Fmore-scheme..rkt%29._time%29%29
;; current-inexact-monotonic-milliseconds - https://docs.racket-lang.org/reference/time.html#%28def._%28%28quote._~23~25kernel%29._current-inexact-monotonic-milliseconds%29%29
;; current-inexact-milliseconds
;; current-monotonic-nanoseconds - https://docs.racket-lang.org/monotonic/index.html
(define expr
'(define (fib n)
(define (fib-iter a b count)
(if (= count 0)
b
(fib-iter (+ a b) a (- count 1))))
(fib-iter 1 0 n))
)
(define env2 (mceval:setup-environment))
(mceval:define-variable! '+ (list 'primitive +) env2)
(mceval:define-variable! '- (list 'primitive -) env2)
(mceval:define-variable! '= (list 'primitive =) env2)
(mceval:eval expr env2)
(profile-thunk
(lambda ()
(mceval:eval '(fib 5000) env2)
)
#:repeat 99)
(define env3 (analyzing:setup-environment))
(analyzing:define-variable! '+ (list 'primitive +) env3)
(analyzing:define-variable! '- (list 'primitive -) env3)
(analyzing:define-variable! '= (list 'primitive =) env3)
(analyzing:eval expr env3)
(profile-thunk
(lambda ()
(analyzing:eval '(fib 5000) env3)
)
#:repeat 99)
4_25
{{#include ../../../source/solution_04/4_25.rkt:2:}}
4_26
;; file: 4_26.rkt
;; 4_06
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
;; lazy evaluation <=> eager evaluation
(define (unless condition usual-value exceptional-value)
(if condition
exceptional-value
usual-value))
;; Ben Bitdidle
;; - lazy evaluation의 중요성에 공감 못함. 그냥 eager evaluation환경에서 unless를 스페셜 폼으로 구현하면 된다.
;;
;; unless 를 (앞선 cond 혹은 let 처럼) derived expression 구현
;;
(define (unless->if expr)
(let ((condition (second expr))
(usual-value (third expr))
(exceptional-value (fourth expr)))
(list 'if condition
exceptional-value
usual-value)))
(check-equal?
(unless->if '(unless (= 1 0)
10
20))
'(if (= 1 0)
20
10))
;; Alyssa P. Hacker
;; - 그렇게 하면 함수를 인자나 반환값으로 사용하는 high-order procedure에서 사용 못한다.
;;
;; unless가 procedure로 사용되면 유용한 예.
;;
(check-equal? (map unless (list true false true) '(1 1 1) '(2 2 2))
'(2 1 2))
4_27
;; file: 4_27.rkt
(#%require rackunit)
(#%require threading)
(#%require (prefix racket: racket))
(racket:require "../allcode/ch4-4.2.2-leval.rkt")
;; lazy evaluator는 eval후 force it을 적용.
;; (driver-loop) 후 입력해도 됨.
;;
;; (define (actual-value exp env)
;; (force-it (eval exp env)))
;;
(override-force-it! force-it-non-memoizing)
;; (override-force-it! force-it-memoizing)
(define env1 (setup-environment))
(~> '(define count 0)
(actual-value env1)
(check-eq? 'ok))
(~> '(define (id x)
(set! count (+ count 1))
x)
(actual-value env1)
(check-eq? 'ok))
(~> '(define w (id (id 10)))
(actual-value env1)
(check-eq? 'ok))
(~> 'count
(actual-value env1)
(check-eq? 1))
(~> 'w
(actual-value env1)
(check-eq? 10))
#;(~> 'w
(actual-value env1)
(check-eq? 10))
(~> 'count
(actual-value env1)
(check-eq? 2))
4_28
;; file: 4_28.rkt
(#%require rackunit)
(#%require threading)
(#%require (prefix racket: racket))
(racket:require "../allcode/ch4-4.2.2-leval.rkt")
;; Q. 예전에는 operator를 apply 에 넘겨주게 전에 그냥 eval했는데 왜 이젠 actual-value를 쓰는가?
;;
;; ch4-4.2.2-leval 에서는 apply시 operator에 actual-value적용
;;
;; actual-value는 eval + force-it임.
;; 그럼 operator에 왜 추가적으로 force-it을 하는가. operator로 thunk가 올 수 있기 때문.
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp)
;; 기존 leval코드는 operator에 actual-value적용.
;; (apply (actual-value (operator exp) env)
;; (operands exp)
;; env)
(apply (eval (operator exp) env)
(operands exp)
env))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env1 (setup-environment))
(~> '(define (id x) x)
(actual-value env1)
(check-eq? 'ok))
(~> '(define op (id +))
(actual-value env1)
(check-eq? 'ok))
(~> 'op
(lookup-variable-value env1)
(thunk?)
(check-true))
(check-exn #rx"Unknown procedure type"
(lambda ()
(~> '(op 1 2)
(actual-value env1))))
4_29
;; file: 4_29.rkt
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require (prefix racket: racket))
(racket:require (racket:prefix-in lazy: "../allcode/ch4-4.2.2-leval.rkt"))
;;
;; count/id는 4_27에서 정의된것.
;;
;; non-memoizing버전과 memoizing 버전의 결과값을 비교해라.
;;
;; non-memoizing 버전에서는 (thunk exp env) 들만 있고, 매 force-it시 thunk에서 값을 계산을 한다.
'(define (force-it-non-memoizing obj)
(if (thunk? obj)
(actual-value (thunk-exp obj) (thunk-env obj))
obj))
;; 반면 memoizing버전에서는 (evaluated-thunk result) 라는게 있어, (thunk exp env) 를 한번 계산하고 캐쉬비슷하게 저장해서 다시 쓴다.
'(define (force-it-memoizing obj)
(cond ((thunk? obj)
(let ((result (actual-value
(thunk-exp obj)
(thunk-env obj))))
(set-car! obj 'evaluated-thunk)
(set-car! (cdr obj) result) ; replace exp with its value
(set-cdr! (cdr obj) '()) ; forget unneeded env
result))
((evaluated-thunk? obj)
(thunk-value obj))
(else obj)))
;; non-memoizing 버전
(lazy:override-force-it! lazy:force-it-non-memoizing)
(define env1 (lazy:setup-environment))
(~> '(define count 0)
(lazy:actual-value env1)
(check-eq? 'ok))
(~> '(define (id x)
(set! count (+ count 1))
x)
(lazy:actual-value env1)
(check-eq? 'ok))
(~> '(define (square x)
(* x x))
(lazy:actual-value env1)
(check-eq? 'ok))
;; non-memoizing에서는 (id 10)이 캐쉬되지 안아 square에서 2번 호출되어 count수도 두번 증가한다.
(~> '(square (id 10))
(lazy:actual-value env1)
(check-eq? 100))
(~> 'count
(lazy:actual-value env1)
(check-eq? 2))
;; memoizing 버전
(lazy:override-force-it! lazy:force-it-memoizing)
(define env2 (lazy:setup-environment))
(~> '(define count 0)
(lazy:actual-value env2)
(check-eq? 'ok))
(~> '(define (id x)
(set! count (+ count 1))
x)
(lazy:actual-value env2)
(check-eq? 'ok))
(~> '(define (square x)
(* x x))
(lazy:actual-value env2)
(check-eq? 'ok))
;; memoizing에서는 (id 10)이 한번 호출되어 캐쉬되어 square에서 (* x x)라도 count수는 한번만 증가한다.
(~> '(square (id 10))
(lazy:actual-value env2)
(check-eq? 100))
(~> 'count
(lazy:actual-value env2)
(check-eq? 1))
4_30
;; file: 4_30.rkt
;; 4_31
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.2.2-leval.rkt"
(_eval-sequence lazy:eval-sequence)))
;; Cy D. Fect (aka sideeffect)는 사이드 이펙트가 생길까 염려.
;; 그래서 eval-sequence시 마지막을 제외하고 강제로 actual-value로 값을 얻어와야 한다고 주장함.
(define (eval-sequence-cy exps env)
(cond ((last-exp? exps)
(eval (first-exp exps) env))
(else
;; 기존
;; (eval (first-exp exps) env)
;;
;; 변경 eval을 actual-value로 변경
(actual-value (first-exp exps) env)
(eval-sequence-cy (rest-exps exps) env))))
;;
;; a. for-each예를 들며, Ben Bitdiddle는 Cy가 틀렸다고 생각함. 원래 lazy:eval-sequence 이 맞다고 생각.
;; c. for-each예를 들며, Cy는 자신의 eval-sequence-cy도 잘 돌아간다고 주장.
(define expr-foreach '(define (for-each proc items)
(if (null? items)
'done
(begin (proc (car items))
(for-each proc (cdr items))))))
(define expr-run-foreach '(for-each
(lambda (x) (newline) (display x))
(list 57 321 88)))
(test-case
"a. Ben Bitdiddle의 주장 lazy:eval-sequence "
(override-eval-sequence! lazy:eval-sequence)
(define env1 (setup-environment))
(~> expr-foreach
(actual-value env1)
(check-equal? 'ok))
(let ([output (racket:with-output-to-string (lambda () (actual-value expr-run-foreach env1)))])
(check-equal? output "\n57\n321\n88")))
(test-case
"c. Cy D. Fect 의 주장 eval-sequence-cy "
(override-eval-sequence! eval-sequence-cy)
(define env1 (setup-environment))
(~> expr-foreach
(actual-value env1)
(check-equal? 'ok))
(let ([output (racket:with-output-to-string (lambda () (actual-value expr-run-foreach env1)))])
(check-equal? output "\n57\n321\n88")))
;;
;; b. 좀 더 복잡한 (p1 1) / (p2 1)의 실행 결과 비교.
(define expr-p1 '(define (p1 x)
(set! x (cons x '(2)))
x))
(define expr-p2 '(define (p2 x)
(define (p e)
e
x)
(p (set! x (cons x '(2))))))
(test-case
"고치지 않으면? ( Ben Bitdiddle의 주장 lazy:eval-sequence )"
(override-eval-sequence! lazy:eval-sequence)
(define env1 (setup-environment))
(~> expr-p1
(actual-value env1)
(check-equal? 'ok))
(~> expr-p2
(actual-value env1)
(check-equal? 'ok))
(~> '(p1 1)
(actual-value env1)
(check-equal? '(1 2)))
;; x가 set!되기전에 값을 유지하고있어서, set!이 된 값이 아닌 1이 반환됨.
(~> '(p2 1)
(actual-value env1)
(check-equal? 1)))
(test-case
"고치면? ( Cy D. Fect 의 주장 eval-sequence-cy )"
(override-eval-sequence! eval-sequence-cy)
(define env2 (setup-environment))
(~> expr-p1
(actual-value env2)
(check-equal? 'ok))
(~> expr-p2
(actual-value env2)
(check-equal? 'ok))
(~> '(p1 1)
(actual-value env2)
(check-equal? '(1 2)))
(~> '(p2 1)
(actual-value env2)
(check-equal? '(1 2))))
;; d. eval-sequcne를 어떻게 해야하나?
;; 1. Cy D. Fect (eval-sequcne-cy)
;; 2. 혹은 Ben Bitdiddle (lazy:eval-sequence)
;; 3. 아니면, 다른 방법?
;;
;; Cy D. Fect말도 사이드 이펙트를 피할 수 있지만, lazy함의 장점을 잃어버림.
;; Ben Bitdiddle의 lazy방식도 좋지만 (p2 1)와 같이 사이드 이팩트가 일어날 수 있음.
;; 다른 방법으로는, expr이 부수효과가 있으면 강제 평가하고 넘어가도록 짜면 피할 수 있음. 다만 부수효과 여부를 어떻게 판별할지가 관건.
4_31
;; file: 4_31.rkt
;; 4_30
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.2.2-leval.rkt"
(_eval-sequence lazy:eval-sequence)))
;; define 문법을 확장하여, 바로 평가할지, lazy-evalution인지, lazy evaluation + memoize인지 설정할 수 있도록 만들어라.
;; |---|--------------------------|
;; | f | 함수이름 |
;; | a | 바로 평가 |
;; | b | lazy evaluation |
;; | c | 바로 평가 |
;; | d | lazy evaluation + memoize|
'(define (f a (b lazy) c (d lazy-memo))
...)
;; eval해서 eval-definition쪽은 그냥 symbol리스트를 저장하는거니 eval함수 수정은 아니고
;; (define (f a (b lazy) c (d lazy-memo)) true)
;; env=> #0=(((f ... )
;; (procedure (a (b lazy) c (d lazy-memo)) (true) #0#)
;; ...
;; ))
;; 4_30과 같이 apply쪽에보면 eval-sequence / list-of-delayed-args / procedure-parameters를 고쳐야 한다.
;; 그리고 force-it 하는 부분도, eager/ lazy / lazy-memo부분을 나누어야한다.
'(define (apply procedure arguments env)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure
procedure
(list-of-arg-values arguments env)))
((compound-procedure? procedure)
(eval-sequence ; <<<< 이 부분: eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure) ; <<<< 이 부분: procedure-parameters
(list-of-delayed-args arguments env) ; <<<< 이 부분: list-of-delayed-args
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (procedure-parameters procedure)
;; (procedure-parameters '(procedure (a (b lazy) c (d lazy-memo)) (true) 'blabla-env))
;; => (a b c d)
(define (darg->var darg)
(if (list? darg)
(first darg)
darg))
(let ((define-args (second procedure)))
(map darg->var define-args)))
(define (procedure-parameter-annotations procedure)
;; (procedure-parameter-annotations '(procedure (a (b lazy) c (d lazy-memo)) (true) 'blabla-env))
;; => (eager lazy eager lazy-memo)
(define (darg->annot darg)
(if (list? darg)
(second darg)
'eager))
(let ((define-args (second procedure)))
(map darg->annot define-args)))
(define (delay-memo-it exp env)
(list 'thunk-memo exp env))
;; list-of-delayed-args는 annotation다룰 자리가 없으니 list-of-new-define-args로 대처
(define (list-of-new-define-args arguments annotations env)
;; (list-of-new-define-args '(1 2 3 4) '(eager lazy eager lazy-memo) 'blabla-env)
;;=> (1 (thunk 2 blabla-env) 3 (thunk-memo 4 blabla-env))
(define (box annot arg env)
(cond ((eq? annot 'eager)
(actual-value arg env))
((eq? annot 'lazy)
(delay-it arg env))
((eq? annot 'lazy-memo)
(delay-memo-it arg env))
(else
(error "annot != (eager|lazy|lazy-memo)" annot arg))))
(define (iter acc args annots env)
(if (null? args)
(reverse acc)
(let ((boxed (box (first annots) (first args) env)))
(iter (cons boxed acc) (rest args) (rest annots) env))))
(iter '() arguments annotations env))
(define (thunk-memo? obj)
(tagged-list? obj 'thunk-memo))
(define (force-it-brand-new obj)
(cond ((thunk? obj)
(actual-value (thunk-exp obj) (thunk-env obj)))
((thunk-memo? obj)
(let ((result (actual-value
(thunk-exp obj)
(thunk-env obj))))
(set-car! obj 'evaluated-thunk)
(set-car! (cdr obj) result) ; replace exp with its value
(set-cdr! (cdr obj) '()) ; forget unneeded env
result))
((evaluated-thunk? obj)
(thunk-value obj))
(else obj)))
(define (apply-30 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
(procedure-parameters procedure) ; <<<<
(list-of-new-define-args arguments (procedure-parameter-annotations procedure) env) ; <<<<
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(override-procedure-parameters! procedure-parameters)
(override-force-it! force-it-brand-new)
(override-apply! apply-30)
(define env1 (setup-environment))
(~> '(define (id x)
x)
(actual-value env1)
(check-equal? 'ok))
(~> '(begin
(define var-d 0)
(define var-c 0)
(define var-b 0)
(define var-a 0)
)
(actual-value env1)
(check-equal? 'ok))
(~> '(define (f a (b lazy) c (d lazy-memo))
(set! var-a a)
(set! var-b b)
(set! var-c c)
(set! var-d d)
(+ a b c d))
(actual-value env1)
(check-equal? 'ok))
(~> '(f (id 1) (id 2) (id 3) (id 4))
(actual-value env1)
(check-equal? 10))
;; env1
;; #0=(((... var-a var-b var-c var-d ...)
;; ...
;; 1
;; (thunk 2 #0#)
;; 3
;; (evaluated-thunk 4)
;; ...))
(~> '(f (id 1) (id 2) (id 3) (id 4))
(actual-value env1)
(check-equal? 10))
;; env1
;; #0=(((... var-a var-b var-c var-d ...)
;; ...
;; 1
;; (thunk (id 2) #0#)
;; 3
;; (evaluated-thunk 4)
;; ...))
(~> '(define (g a (b lazy) c (d lazy-memo))
(set! var-a a)
(set! var-b b)
(set! var-c c)
(set! var-d d)
true)
(actual-value env1)
(check-equal? 'ok))
(~> '(g (id 1) (id 2) (id 3) (id 4))
(actual-value env1)
(check-equal? true))
;; env1
;; #0=(((... var-a var-b var-c var-d ...)
;; ...
;; 1
;; (thunk (id 2) #0#)
;; 3
;; (thunk-memo (id 4) #0#)
;; ...))
4_32
;; file: 4_32.rkt
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.2.2-leval.rkt"
(_eval-sequence lazy:eval-sequence)))
;; 3장에서 다룬 **스트림**과 이 섹션에서 설명한 "더 게으른" **지연 리스트**의 차이점을 보여주는 몇 가지 예제를 제시해라.
;; 이 추가적인 laziness 어떻게 활용할 수 있는가?
;;
;; (provide cons-stream)
;; (define-syntax cons-stream
;; (syntax-rules ()
;; [(_ A B) (r5rs:cons A (r5rs:delay B))]))
;;
;; |------------|------------------------|----------------------------------------|
;; | 스트림 | car의 즉시 평가. | 순차적 접근과 무한 리스트 처리에 적합. |
;; | 지연 리스트| car와 cdr 모두를 지연. | 비순차적 접근에서 더 유연 |
(override-force-it! force-it-memoizing) ; memoizing없이는 solve를 푸는데 한참걸림.
(define env1 (setup-environment))
(~> '(begin
(define (cons x y)
(lambda (m)
(m x y)))
(define (car z)
(z
(lambda (p q) p)))
(define (cdr z)
(z
(lambda (p q) q)))
(define (list-ref items n)
(if (= n 0)
(car items)
(list-ref (cdr items) (- n 1))))
(define (map proc items)
(if (null? items)
'()
(cons (proc (car items))
(map proc (cdr items)))))
(define (scale-list items factor)
(map (lambda (x) (* x factor))
items))
(define (add-lists list1 list2)
(cond ((null? list1) list2)
((null? list2) list1)
(else (cons (+ (car list1)
(car list2))
(add-lists
(cdr list1)
(cdr list2))))))
(define ones (cons 1 ones))
(define integers
(cons 1 (add-lists ones integers))))
(actual-value env1)
(check-equal? 'ok))
(~> '(list-ref integers 17)
(actual-value env1)
(check-equal? '18))
(~> '(begin
(define (integral integrand initial-value dt)
(define int
(cons initial-value
(add-lists (scale-list integrand dt)
int)))
int)
(define (solve f y0 dt)
(define y (integral dy y0 dt))
(define dy (map f y))
y))
(actual-value env1)
(check-equal? 'ok))
(define SMALL-RADIO 0.00001)
(~> '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
(actual-value env1)
(check-= 2.716924 SMALL-RADIO))
(~> '(define (run-forever)
(run-forever))
(actual-value env1)
(check-equal? 'ok))
(~> '(begin
(cons (run-forever) 2)
1)
(actual-value env1)
(check-equal? 1))
(~> '(list-ref (cons (run-forever) (cons 'helloworld nil)) 1)
(actual-value env1)
(check-equal? 'helloworld))
4_33
;; file: 4_33.rkt
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.2.2-leval.rkt"
(_eval-sequence lazy:eval-sequence)))
;; leval에서 '(car '(a b c))를 처리할 수 없는데 처리할 수 있도록 고쳐라.
;;
;; before
;; car의 정의에 따라 풀면 ('(a b c) (lambda (p q) p)) 이런식이 되는데, 이러면 당연히 에러가 날 것이다.
;;
(define env1 (setup-environment))
(~> '(begin
(define (cons x y)
(lambda (m)
(m x y)))
(define (car z)
(z
(lambda (p q) p)))
(define (cdr z)
(z
(lambda (p q) q))))
(actual-value env1)
(check-equal? 'ok))
(check-exn
#rx"Unknown procedure type -- APPLY \\(a b c\\)"
(lambda ()
(~>'(car '(a b c))
(actual-value env1))))
;;
;; after
;; '(a b c)를 lazy list로 풀면 (cons (quote a) (cons (quote b) (cons (quote c) nil))) 잘 동작할 것이다.
;;
(define (handle-quoted expr)
(define (quoted-list lst)
;; (quoted-list '(a b c))
;;=> (cons (quote a) (cons (quote b) (cons (quote c) ())))
(define (iter acc xs)
(if (null? xs)
acc
(iter (list 'cons (list 'quote (first xs)) acc) (rest xs))))
(iter '() (reverse lst)))
(define (quoted-cons pair)
;; (quoted-cons '(a . b)
;;=> '(cons (quote a) (quote b)))
(list 'cons
(list 'quote (first pair))
(list 'quote (rest pair))))
(cond ((list? expr)
(quoted-list expr))
((pair? expr)
(quoted-cons expr))
(else
expr)))
(check-equal? (handle-quoted '(a . b))
'(cons (quote a) (quote b)))
(check-equal? (handle-quoted '(a b c))
'(cons (quote a) (cons (quote b) (cons (quote c) ()))))
(check-equal? (handle-quoted 'a)
'a)
(define (eval-quoted expr env)
(let ((q (handle-quoted expr)))
(if (pair? q)
(eval q env)
q)))
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp)
(eval-quoted (text-of-quotation exp) env))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp) ; clause from book
(apply (actual-value (operator exp) env)
(operands exp)
env))
(else
(error "Unknown expression type -- EVAL" exp))))
(override-eval! eval)
(define env2 (setup-environment))
(~> '(begin
(define (cons x y)
(lambda (m)
(m x y)))
(define (car z)
(z
(lambda (p q) p)))
(define (cdr z)
(z
(lambda (p q) q))))
(actual-value env2)
(check-equal? 'ok))
(~>'(car '(a b c))
(actual-value env2)
(check-equal? 'a))
4_34
;; file: 4_34.rkt
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.2.2-leval.rkt"
(_eval-sequence lazy:eval-sequence)))
;; TODO driver loop를 수정하여 lazy pair / lazy list를 보기 좋게 출력해라.(무한 리스트는 어떻게 다룰 것인가?)
;; evaluator가 lazy pairs를 잘 인식하여 출력하도록, lazy pairs를 내부적으로 어떻게 다를 것인지에 대해 수정해야 할 지도 모른다.
(define env1 (setup-environment))
(~> '(begin
(define (cons x y)
(lambda (m)
(m x y)))
(define (car z)
(z
(lambda (p q) p)))
(define (cdr z)
(z
(lambda (p q) q))))
(actual-value env1)
(check-equal? 'ok))
(~> '(cons nil nil)
(actual-value env1))
#;(~> '(cons 1 (cons 2 '()))
(actual-value env1))
4_35
;; file: 4_35.rkt
;; 4_36, 4_37
(#%require rackunit)
(#%require threading)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 정해진 범위에서 정수 하나를 골라내는 프로시저 an-integer-between을 정의하라.
(define env2 (setup-environment))
(~> '(define (require p)
(if (not p)
(amb)))
(run env2)
(check-equal? 'ok))
(~> '(begin
(define (square x) (* x x))
(define (smallest-divisor n)
(find-divisor n 2))
(define (find-divisor n test-divisor)
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (+ test-divisor 1)))))
(define (divides? a b)
(= (remainder b a) 0))
(define (prime? n)
(= n (smallest-divisor n))))
(run env2)
(check-equal? 'ok))
(~> '(define (prime-sum-pair list1 list2)
(let ((a (an-element-of list1))
(b (an-element-of list2)))
(require (prime? (+ a b)))
(list a b)))
(run env2)
(check-equal? 'ok))
(~> '(define (an-element-of items)
(require (not (null? items)))
(amb (car items)
(an-element-of (cdr items))))
(run env2)
(check-equal? 'ok))
(~> '(prime-sum-pair '(1 3 5 8) '(20 35 110))
(runs env2)
(check-equal? '((3 20)
(3 110)
(8 35))))
(~> '(prime-sum-pair '(19 27 30) '(11 36 58))
(run env2)
(check-equal? '(30 11)))
;;
(define env3 (setup-environment))
(define-variable! '+ (list 'primitive +) env3)
(define-variable! '<= (list 'primitive <=) env3)
(define-variable! 'inc (list 'primitive inc) env3)
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (an-integer-between from to)
;; 정해진 범위에서 정수 하나를 골라내는 프로시저.
;; (an-integer-between 1 10)
;;=> amb (1 2 3 4 5 6 7 8 9 10)
(require (<= from to))
(amb from
(an-integer-between (inc from) to)))
(run env3)
(check-equal? 'ok))
(~> '(define (a-pythagorean-triple-between low high)
;; i^2 + j^2 = k^2 인 세 정수의 쌍 (i, j , k)을 찾아네는 프로시져.
(let ((i (an-integer-between low high)))
(let ((j (an-integer-between i high)))
(let ((k (an-integer-between j high)))
(require (= (+ (* i i) (* j j)) (* k k)))
(list i j k)))))
(run env3)
(check-equal? 'ok))
(~> '(a-pythagorean-triple-between 1 30)
(runs env3)
(check-equal? '((3 4 5)
(5 12 13)
(6 8 10)
(7 24 25)
(8 15 17)
(9 12 15)
(10 24 26)
(12 16 20)
(15 20 25)
(18 24 30)
(20 21 29))))
4_36
;; file: 4_36.rkt
;; 4_35, 4_37
(#%require rackunit)
(#%require threading)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 앞에 정의한 a-pythagorean-triple-between 함수에서 단순히 an-integer-between을 an-integer-starting-from로 바꿔서는 안됨.
;; 안되는 이유는?
;; an-integer-starting-from의 중첩으로는 깊이 우선 탐색으로 i j k가 1 1 1, 1 1 2, 1 1 3 .... 되면서 i가 올라가지 않게됨.
;; require는 조건을 걸러내는 필터일 뿐이고, 탐색 순서 자체를 바꿔주지는 못함.
;;
;; 올바른 해결책은?
;; 깊이 우선 탐색이므로 integer-starting-from만으로는 안됨. an-integer-between을 섞어 제한을 줘야함.
(define env3 (setup-environment))
(define-variable! '+ (list 'primitive +) env3)
(define-variable! '<= (list 'primitive <=) env3)
(define-variable! 'inc (list 'primitive inc) env3)
(define-variable! 'display (list 'primitive display) env3)
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (an-integer-starting-from n)
;; (an-integer-starting-from 1)
;;=> amb (1 .....)
(amb n
(an-integer-starting-from (+ n 1))))
(run env3)
(check-equal? 'ok))
(~> '(define (an-integer-between from to)
;; 정해진 범위에서 정수 하나를 골라내는 프로시저.
;; (an-integer-between 1 10)
;;=> amb (1 2 3 4 5 6 7 8 9 10)
(require (<= from to))
(amb from
(an-integer-between (inc from) to)))
(run env3)
(check-equal? 'ok))
(~> '(define (a-pythagorean-triple-from low)
(let ((k (an-integer-starting-from low)))
(let ((j (an-integer-between low k)))
(let ((i (an-integer-between low j)))
(require (= (+ (* i i) (* j j)) (* k k)))
(list i j k)))))
(run env3)
(check-equal? 'ok))
(~> '(a-pythagorean-triple-from 1)
(runs env3 10)
(check-equal? '((3 4 5)
(6 8 10)
(5 12 13)
(9 12 15)
(8 15 17)
(12 16 20)
(15 20 25)
(7 24 25)
(10 24 26)
(20 21 29))))
4_37
;; file: 4_37.rkt
;; 4_35, 4_36
(#%require rackunit)
(#%require threading)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Ben Bitdiddle 는 4.35에서 나온 a-pythagorean-triple-between보다 자신의 것이 더 효율적이라고 주장하는데, 사실인가?
;; (힌트, 탐색해야할 가능성의 수 고려)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(define env3 (setup-environment))
(define-variable! '+ (list 'primitive +) env3)
(define-variable! '<= (list 'primitive <=) env3)
(define-variable! 'inc (list 'primitive inc) env3)
(define-variable! 'display (list 'primitive display) env3)
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (an-integer-starting-from n)
;; (an-integer-starting-from 1)
;;=> amb (1 .....)
(amb n
(an-integer-starting-from (+ n 1))))
(run env3)
(check-equal? 'ok))
(~> '(define (an-integer-between from to)
;; 정해진 범위에서 정수 하나를 골라내는 프로시저.
;; (an-integer-between 1 10)
;;=> amb (1 2 3 4 5 6 7 8 9 10)
(require (<= from to))
(amb from
(an-integer-between (inc from) to)))
(run env3)
(check-equal? 'ok))
;; 4.35
'(define (a-pythagorean-triple-between low high)
;; i^2 + j^2 = k^2 인 세 정수의 쌍 (i, j , k)을 찾아네는 프로시져.
;; an-integer-between가 3개 O(n^3)
(let ((i (an-integer-between low high)))
(let ((j (an-integer-between i high)))
(let ((k (an-integer-between j high)))
(require (= (+ (* i i) (* j j)) (* k k)))
(list i j k)))))
;; 4.37
(~> '(define (a-pythagorean-triple-between-37 low high)
;; an-integer-between가 2개 O(n^2)
(let ((i (an-integer-between low high))
(hsq (* high high)))
(let ((j (an-integer-between i high)))
(let ((ksq (+ (* i i)
(* j j))))
(require (<= ksq hsq))
(let ((k (sqrt ksq)))
(require (integer? k))
(list i j k))))))
(run env3)
(check-equal? 'ok))
(~> '(a-pythagorean-triple-between-37 1 50)
(runs env3 10)
(check-equal? ' ((3 4 5)
(5 12 13)
(6 8 10)
(7 24 25)
(8 15 17)
(9 12 15)
(9 40 41)
(10 24 26)
(12 16 20)
(12 35 37))))
4_38
;; file: 4_38.rkt
;; 4_38, 4_39, 4_40, 4_41
(#%require rackunit)
(#%require threading)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; multiple-dwelling에서 Smith와 Fletcher가 인접층에 살지 않는다는 require를 빼도록 수정해라. 얼마나 많은 솔루션이 있는가?
(define env3 (setup-environment))
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (distinct? items)
(cond ((null? items) true)
((null? (cdr items)) true)
((member (car items) (cdr items)) false)
(else (distinct? (cdr items)))))
(run env3)
(check-equal? 'ok))
(~> '(define (multiple-dwelling)
(let ((baker (amb 1 2 3 4 5))
(cooper (amb 1 2 3 4 5))
(fletcher (amb 1 2 3 4 5))
(miller (amb 1 2 3 4 5))
(smith (amb 1 2 3 4 5)))
(require
(distinct? (list baker cooper fletcher miller smith)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
;; Smith와 Fletcher가 인접층에 살지 않는다는 require를 빼도록 수정해라.
;; (require
;; (not (= (abs (- smith fletcher)) 1)))
(require
(not (= (abs (- fletcher cooper)) 1)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith))))
(run env3)
(check-equal? 'ok))
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 5))
4_39
;; file: 4_39.rkt
;; 4_38, 4_39, 4_40, 4_41
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Q. multiple-dwelling에서 require의 순서가 답에 영향을 미치는가?
;; 아니다.
;;
;; Q. 시간에 영향을 미치는가?
;;
;; 어쨋든 require를 모두 통과해야 결과가 나옴.
;; require 순서를 조절하여 가지치기를 해두면 검사의 횟수를 줄이이면서 더 빠르게 결과를 얻을 수 있음.
;; 계산비용 자체는 distinct? 함수가 가장 크나,
;; 테스트 결과 (require (> miller cooper)) 이 제약조건이 가지치기를 크게 함으로써 시간에 가장 크게 영향을 끼쳤음.
;;
;; Q. 순서가 중요하다면, 순서를 재배치하여 더 빠른 프로그램을 만들어라. 만약 순서가 중요하지 않다면, 그 이유를 설명하라.
;;
(define env3 (setup-environment))
(define-variable! 'display (list 'primitive display) env3)
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (distinct? items)
(cond ((null? items)
true)
((null? (cdr items))
true)
((member (car items) (cdr items))
false)
(else
(distinct? (cdr items)))))
(run env3)
(check-equal? 'ok))
(define expr-origin
'(define (multiple-dwelling)
(let ((baker (amb 1 2 3 4 5))
(cooper (amb 1 2 3 4 5))
(fletcher (amb 1 2 3 4 5))
(miller (amb 1 2 3 4 5))
(smith (amb 1 2 3 4 5)))
(require (distinct? (list baker cooper fletcher miller smith)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))
(define expr-2
'(define (multiple-dwelling)
(let ((baker (amb 1 2 3 4 5))
(cooper (amb 1 2 3 4 5))
(fletcher (amb 1 2 3 4 5))
(miller (amb 1 2 3 4 5))
(smith (amb 1 2 3 4 5)))
(require (> miller cooper))
(require (not (= fletcher 1)))
(require (not (= cooper 1)))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(require (not (= fletcher 5)))
(require (not (= baker 5)))
(require (distinct? (list baker cooper fletcher miller smith)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))
(~> expr-origin
(run env3)
(check-equal? 'ok))
(racket:time
(racket:for ([i 10])
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 1))))
(~> expr-2
(run env3)
(check-equal? 'ok))
(racket:time
(racket:for ([i 10])
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 1))))
4_40
;; file: 4_40.rkt
;; 4_38, 4_39, 4_40, 4_41
(#%require rackunit)
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Q. distict가 있을때 없을때 경우의 수?
;; 있으면 1
;; 없으면 120
;;
;; Q. 모든 사람들을 층에 배정 후 백트래킹을 통해 이를 제거하는 방식은 매우 비효율적. 이전 제약 조건에 의해 이미 배제된 가능성만 생성하도록 하는, 훨씬 더 효율적인 비결정적 절차를 작성하고 이를 시연하라
;; (힌트: 이를 위해서는 let 표현식의 중첩이 필요하다.)
;;
;; distnct는 모든 사람들이 필요함.: (require (distinct? (list baker cooper fletcher miller smith)))
;; 대신, 사람별로 (require (not (= cooper fletcher))) / (require (not (= miller cooper))) ... 제한을 두게되면 좀 더 최적화가 됨.
(define env3 (setup-environment))
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (distinct? items)
(cond ((null? items) true)
((null? (cdr items)) true)
((member (car items) (cdr items)) false)
(else (distinct? (cdr items)))))
(run env3)
(check-equal? 'ok))
(define expr-origin
'(define (multiple-dwelling)
(let ((baker (amb 1 2 3 4 5))
(cooper (amb 1 2 3 4 5))
(fletcher (amb 1 2 3 4 5))
(miller (amb 1 2 3 4 5))
(smith (amb 1 2 3 4 5)))
(require (distinct? (list baker cooper fletcher miller smith)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))
(define expr-without-distinct
'(define (multiple-dwelling)
(let ((baker (amb 1 2 3 4 5))
(cooper (amb 1 2 3 4 5))
(fletcher (amb 1 2 3 4 5))
(miller (amb 1 2 3 4 5))
(smith (amb 1 2 3 4 5)))
;; (require (distinct? (list baker cooper fletcher miller smith)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))
(define expr-split-let
'(define (multiple-dwelling)
(let ((fletcher (amb 1 2 3 4 5)))
(require (not (= fletcher 1)))
(require (not (= fletcher 5)))
(let ((cooper (amb 1 2 3 4 5)))
(require (not (= cooper 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(let ((miller (amb 1 2 3 4 5)))
(require (> miller cooper))
(let ((smith (amb 1 2 3 4 5)))
(require (not (= (abs (- smith fletcher)) 1)))
(let ((baker (amb 1 2 3 4 5)))
(require (not (= baker 5)))
(require (distinct? (list baker cooper fletcher miller smith)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))))))
(define expr-split-distict
'(define (multiple-dwelling)
(let ((fletcher (amb 1 2 3 4 5)))
(require (not (= fletcher 1)))
(require (not (= fletcher 5)))
(let ((cooper (amb 1 2 3 4 5)))
(require (not (= cooper 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(require (not (= cooper fletcher))) ; for distict?
(let ((miller (amb 1 2 3 4 5)))
(require (> miller cooper))
(require (not (= miller fletcher))) ; for distict?
(require (not (= miller cooper))) ; for distict?
(let ((smith (amb 1 2 3 4 5)))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= smith fletcher))) ; for distict?
(require (not (= smith cooper))) ; for distict?
(require (not (= smith miller))) ; for distict?
(let ((baker (amb 1 2 3 4 5)))
(require (not (= baker 5)))
(require (not (= baker fletcher))) ; for distict?
(require (not (= baker cooper))) ; for distict?
(require (not (= baker miller))) ; for distict?
(require (not (= baker smith))) ; for distict?
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))))))
(~> expr-origin
(run env3)
(check-equal? 'ok))
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 1))
(~> expr-without-distinct
(run env3)
(check-equal? 'ok))
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 120))
(~> expr-origin
(run env3)
(check-equal? 'ok))
(racket:time
(racket:for ([i 10])
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 1))))
(~> expr-split-let
(run env3)
(check-equal? 'ok))
(racket:time
(racket:for ([i 10])
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 1))))
(~> expr-split-distict
(run env3)
(check-equal? 'ok))
(racket:time
(racket:for ([i 10])
(~> '(multiple-dwelling)
(runs env3)
(length)
(check-equal? 1))))
4_41
;; file: 4_41.rkt
;; 4_38, 4_39, 4_40, 4_41
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Q. multiple-dwelling를 Scheme으로 풀어라.
(define env3 (setup-environment))
(define-variable! 'append (list 'primitive append) env3)
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (distinct? items)
(cond ((null? items)
true)
((null? (cdr items))
true)
((member (car items) (cdr items))
false)
(else
(distinct? (cdr items)))))
(run env3)
(check-equal? 'ok))
(define expr-origin
'(define (multiple-dwelling)
(let ((baker (amb 1 2 3 4 5))
(cooper (amb 1 2 3 4 5))
(fletcher (amb 1 2 3 4 5))
(miller (amb 1 2 3 4 5))
(smith (amb 1 2 3 4 5)))
(require (distinct? (list baker cooper fletcher miller smith)))
(require (not (= baker 5)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))))
(~> expr-origin
(run env3)
(check-equal? 'ok))
(racket:time
(~> '(multiple-dwelling)
(runs env3)
(check-equal? '(((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))))))
(define expr-x
'(define (multiple-dwelling-scheme-for-each)
;; eval을 통과하기 위해 일단 do로는 안짬. scheme에는 do가 있고 continue가 없는데 continue가 있다면 더 간단할 것이다.
;; for-each로 짜기로 함.
(let ((baker '(1 2 3 4 5))
(cooper '(1 2 3 4 5))
(fletcher '(1 2 3 4 5))
(miller '(1 2 3 4 5))
(smith '(1 2 3 4 5))
(acc '()))
(for-each (lambda (f)
(if (not (= f 1))
(if (not (= f 5))
(for-each (lambda (c)
(if (not (= c 1))
(if (not (= (abs (- f c)) 1))
(for-each (lambda (m)
(if (> m c)
(for-each (lambda (s)
(if (not (= (abs (- s f)) 1))
(for-each (lambda (b)
(if (not (= b 5))
(let ((val (list b c f m s)))
(if (distinct? val)
(set! acc (append acc (list (list 'baker b)
(list 'cooper c)
(list 'fletcher f)
(list 'miller m)
(list 'smith s))))))))
baker)))
smith)))
miller))))
cooper))))
baker)
acc)))
(~> '(define (for-each proc items)
;; Exercise 4.30
(if (null? items)
'done
(begin (proc (car items))
(for-each proc (cdr items)))))
(run env3)
(check-equal? 'ok))
(~> expr-x
(run env3)
(check-equal? 'ok))
(racket:time
(~> '(multiple-dwelling-scheme-for-each)
(runs env3)
(check-equal? '(((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))))
)
4_42
;; file: 4_42.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Q. "Liars" 퍼즐을 풀어라.
;; Phillips, Hubert. 1934. The Sphinx Problem Book. London: Faber and Faber.
;;
;; 각각 참/거짓을 하나씩 말 할 수 있음.
;;
;; Betty: Kitty == 2 // Betty == 3
;; Ethel: Ethel == 1 // Joan == 2
;; Joan : Joan == 3 // Ethel == 5
;; Kitty: Kitty == 2 // Mary == 4
;; Mary : Mary == 4 // Betty == 1
(define expr-liars
'(define (liars-puzzle)
(let ((betty (amb 1 2 3 4 5))
(ethel (amb 1 2 3 4 5))
(joan (amb 1 2 3 4 5))
(kitty (amb 1 2 3 4 5))
(mary (amb 1 2 3 4 5)))
(require (lie-or-true (= kitty 2) (= betty 3)))
(require (lie-or-true (= ethel 1) (= joan 2)))
(require (lie-or-true (= joan 3) (= ethel 5)))
(require (lie-or-true (= kitty 2) (= mary 4)))
(require (lie-or-true (= mary 4) (= betty 1)))
(require (distinct? (list betty ethel joan kitty mary)))
(list (list 'betty betty)
(list 'ethel ethel)
(list 'joan joan )
(list 'kitty kitty)
(list 'mary mary )))))
(define env3 (setup-environment))
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (distinct? items)
(cond ((null? items)
true)
((null? (cdr items))
true)
((member (car items) (cdr items))
false)
(else
(distinct? (cdr items)))))
(run env3)
(check-equal? 'ok))
(~> '(define (lie-or-true x y)
(not (eq? x y)))
(run env3)
(check-equal? 'ok))
(~> expr-liars
(run env3)
(check-equal? 'ok))
(racket:time
(~> '(liars-puzzle)
(runs env3)
(check-equal? '(((betty 3) (ethel 5) (joan 2) (kitty 1) (mary 4))))))
4_43
;; file: 4_43.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; This is taken from a booklet called “Problematical Recreations,” published in the 1960s by Litton Industries, where it is attributed to the Kansas State Engineer.
;;
;; Mary Ann Moore의 아버지는 요트를 가지고 있으며1, 그의 네 친구인 Colonel Downing, Mr. Hall, Sir Barnacle Hood, Dr. Parker도 각각 요트를 가지고 있습니다.
;;
;; 이 다섯 사람 모두 각각 한 명의 딸이 있으며,
;; 각자는 자신의 요트 이름을 **다른 사람의 딸의 이름**으로 지었습니다.
;;
;; Sir Barnacle Hood의 요트는 Gabrielle입니다.3
;; Mr. Moore는 Lorna를 소유하고 있습니다.4
;; Mr. Hall은 Rosalind를 소유하고 있습니다.6
;; Colonel Downing이 소유한 Melissa는5 Sir Barnacle Hood의 딸의 이름을 따서 지어졌습니다.2
;; Gabrielle의 아버지는 Dr. Parker의 딸의 이름을 딴 요트를 소유하고 있습니다.7 **
;;
;; Lorna의 아버지는 누구입니까?
;;
;;
;; 프로그램을 효율적으로 실행되도록 작성해 보세요 (연습문제 4.40 참조).
;;
;; 4.40 Q. 모든 사람들을 층에 배정 후 백트래킹을 통해 이를 제거하는 방식은 매우 비효율적. 이전 제약 조건에 의해 이미 배제된 가능성만 생성하도록 하는, 훨씬 더 효율적인 비결정적 절차를 작성하고 이를 시연하라
;;
(define expr-find-father-v1
'(begin
(define (yacht-name owner)
(cond ((eq? owner 'Sir-Barnacle-Hood) 'Gabrielle)
((eq? owner 'Mr-Moore) 'Lorna)
((eq? owner 'Mr-Hall) 'Rosalind)
((eq? owner 'Colonel-Downing) 'Melissa)
((eq? owner 'Dr-Parker) 'Mary-Ann-Moore)))
(define (find-father-v1)
;; father : Mr-Moore Colonel-Downing Mr-Hall Sir-Barnacle-Hood Dr-Parker
;; daughter: Mary-Ann-Moore Gabrielle Lorna Rosalind Melissa
(let ((father-Mary-Ann-Moore 'Mr-Moore))
; Mary Ann Moore의 아버지는 요트를 가지고 있으며1. 이름으로써 Mr. Moore의 딸. 확정:(Mary-Ann-Moore Mr-Moore)
(let ((father-Melissa 'Sir-Barnacle-Hood))
; Melissa는 Sir Barnacle Hood의 딸의 이름을 따서 지어졌습니다.2 확정:(Melissa Sir-Barnacle-Hood)
(let ((father-Gabrielle (amb 'Mr-Hall 'Colonel-Downing 'Dr-Parker))
(father-Lorna (amb 'Mr-Hall 'Colonel-Downing 'Dr-Parker))
(father-Rosalind (amb 'Mr-Hall 'Colonel-Downing 'Dr-Parker)))
;(require (not (eq? 'Sir-Barnacle-Hood father-Gabrielle))) ; Sir Barnacle Hood의 요트는 Gabrielle입니다.3 삭제가능 (Melissa Sir-Barnacle-Hood)
;(require (not (eq? 'Mr-Moore father-Lorna))) ; Mr. Moore는 Lorna를 소유하고 있습니다.4 삭제가능 (Mary-Ann-Moore Mr-Moore)
;(require (not (eq? 'Colonel-Downing father-Melissa))) ; Colonel Downing이 소유한 Melissa는5 삭제가능 (Melissa Sir-Barnacle-Hood)
(require (not (eq? 'Mr-Hall father-Rosalind))) ; Mr. Hall은 Rosalind를 소유하고 있습니다.6
(let ((daughter-father-for-Dr-Parker (amb (cons 'Gabrielle father-Gabrielle)
(cons 'Lorna father-Lorna)
(cons 'Rosalind father-Rosalind))))
; Gabrielle의 아버지는 Dr. Parker의 딸의 이름을 딴 요트를 소유하고 있습니다.7 **
; - 아빠와 딸이 같이 붙어있는 제약조건으로 특이함.
(require (eq? (cdr daughter-father-for-Dr-Parker) 'Dr-Parker))
(require (eq? (yacht-name father-Gabrielle) (car daughter-father-for-Dr-Parker)))
(require (distinct? (list father-Mary-Ann-Moore father-Gabrielle father-Lorna father-Rosalind father-Melissa)))
(list (list 'Mary-Ann-Moore father-Mary-Ann-Moore)
(list 'Gabrielle father-Gabrielle)
(list 'Lorna father-Lorna)
(list 'Rosalind father-Rosalind)
(list 'Melissa father-Melissa)))))))
)
)
;;
;; 또한, Mary Ann의 성(last name)이 Moore라는 정보가 주어지지 않을 경우 해결책이 몇 개 있는지도 알아내세요.
;;
(define expr-find-father-v2
'(begin
(define (yacht-name owner)
(cond ((eq? owner 'Sir-Barnacle-Hood) 'Gabrielle)
((eq? owner 'Mr-Moore) 'Lorna)
((eq? owner 'Mr-Hall) 'Rosalind)
((eq? owner 'Colonel-Downing) 'Melissa)
((eq? owner 'Dr-Parker) 'Mary-Ann-Moore)))
(define (find-father-v2)
;; father : Mr-Moore Colonel-Downing Mr-Hall Sir-Barnacle-Hood Dr-Parker
;; daughter: Mary-Ann-Moore Gabrielle Lorna Rosalind Melissa
(let ((father-Melissa 'Sir-Barnacle-Hood))
; Melissa는 Sir Barnacle Hood의 딸의 이름을 따서 지어졌습니다.2 확정:(Melissa Sir-Barnacle-Hood)
(let ((father-Mary-Ann-Moore (amb 'Mr-Moore 'Colonel-Downing 'Mr-Hall 'Dr-Parker))
(father-Gabrielle (amb 'Mr-Moore 'Colonel-Downing 'Mr-Hall 'Dr-Parker))
(father-Lorna (amb 'Mr-Moore 'Colonel-Downing 'Mr-Hall 'Dr-Parker))
(father-Rosalind (amb 'Mr-Moore 'Colonel-Downing 'Mr-Hall 'Dr-Parker)))
; (require (not (eq? 'Sir-Barnacle-Hood father-Gabrielle))) ; Sir Barnacle Hood의 요트는 Gabrielle입니다.3 삭제가능 (Melissa Sir-Barnacle-Hood)
(require (not (eq? 'Mr-Moore father-Lorna))) ; Mr. Moore는 Lorna를 소유하고 있습니다.4
;(require (not (eq? 'Colonel-Downing father-Melissa))) ; Colonel Downing이 소유한 Melissa는5 삭제가능 (Melissa Sir-Barnacle-Hood)
(require (not (eq? 'Mr-Hall father-Rosalind))) ; Mr. Hall은 Rosalind를 소유하고 있습니다.6
(let ((daughter-father-for-Dr-Parker (amb (cons 'Mary-Ann-Moore father-Mary-Ann-Moore)
(cons 'Gabrielle father-Gabrielle)
(cons 'Lorna father-Lorna)
(cons 'Rosalind father-Rosalind))))
; Gabrielle의 아버지는 Dr. Parker의 딸의 이름을 딴 요트를 소유하고 있습니다.7 **
; - 아빠와 딸이 같이 붙어있는 제약조건으로 특이함.
(require (eq? (cdr daughter-father-for-Dr-Parker) 'Dr-Parker))
(require (eq? (yacht-name father-Gabrielle) (car daughter-father-for-Dr-Parker)))
(require (distinct? (list father-Mary-Ann-Moore father-Gabrielle father-Lorna father-Rosalind father-Melissa)))
(list (list 'Mary-Ann-Moore father-Mary-Ann-Moore)
(list 'Gabrielle father-Gabrielle)
(list 'Lorna father-Lorna)
(list 'Rosalind father-Rosalind)
(list 'Melissa father-Melissa)))))))
)
(define env3 (setup-environment))
(define-variable! 'display (list 'primitive display) env3)
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(define (distinct? items)
(cond ((null? items)
true)
((null? (cdr items))
true)
((member (car items) (cdr items))
false)
(else
(distinct? (cdr items)))))
(run env3)
(check-equal? 'ok))
(~> expr-find-father-v1
(run env3)
(check-equal? 'ok))
(~> '(find-father-v1)
(runs env3)
(check-equal? '(((Mary-Ann-Moore Mr-Moore)
(Gabrielle Mr-Hall)
(Lorna Colonel-Downing)
(Rosalind Dr-Parker)
(Melissa Sir-Barnacle-Hood)))))
(~> expr-find-father-v2
(run env3)
(check-equal? 'ok))
(~> '(find-father-v2)
(runs env3)
(check-equal? '(((Mary-Ann-Moore Mr-Moore)
(Gabrielle Mr-Hall)
(Lorna Colonel-Downing)
(Rosalind Dr-Parker)
(Melissa Sir-Barnacle-Hood))
((Mary-Ann-Moore Mr-Hall)
(Gabrielle Mr-Moore)
(Lorna Dr-Parker)
(Rosalind Colonel-Downing)
(Melissa Sir-Barnacle-Hood)))))
4_44
;; file: 4_44.rkt
;; 2_42 / 4_44
;; TODO Q. 8-queen 문제를 푸는 nondeterministic program을 작성해라.
4_45
;; file: 4_45.rkt
;; 4_45 / 4_46 / 4_47 / 4_48 / 4_49
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;;
;; Parsing natural language
;;
(define env3 (setup-environment))
(~> '(define (require p)
(if (not p)
(amb)))
(run env3)
(check-equal? 'ok))
(~> '(begin
(define nouns
;; noun: 명사
'(noun student professor cat class))
(define verbs
;; verb: 동사
'(verb studies lectures eats sleeps))
(define articles
;; article: 관사
'(article the a))
(define (parse-sentence)
;; sentence: 문장
(list 'sentence
(parse-noun-phrase)
(parse-word verbs)))
(define (parse-noun-phrase)
;; noun-phrase: 명사-구
(list 'noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-word word-list)
(require (not (null? *unparsed*)))
(require (memq (car *unparsed*)
(cdr word-list)))
(let ((found-word (car *unparsed*)))
(set! *unparsed* (cdr *unparsed*))
(list (car word-list) found-word)))
(define *unparsed* '())
(define (parse input)
(set! *unparsed* input)
(let ((sent (parse-sentence)))
(require (null? *unparsed*))
sent))
)
(run env3)
(check-equal? 'ok))
(~> '(parse '(the cat eats))
(run env3)
(check-equal? '(sentence
(noun-phrase (article the) (noun cat))
(verb eats))))
(~> '(begin
(define prepositions
;; preposition: 전치사
'(prep for to in by with))
(define (parse-prepositional-phrase)
;; prepositional-phrase: 전치사-구
(list 'prep-phrase
(parse-word prepositions)
(parse-noun-phrase)))
(define (parse-sentence)
(list 'sentence
(parse-noun-phrase)
(parse-verb-phrase)))
(define (parse-verb-phrase)
(define (maybe-extend verb-phrase)
(amb
verb-phrase
(maybe-extend
(list 'verb-phrase
verb-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-word verbs)))
(define (parse-simple-noun-phrase)
(list 'simple-noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-noun-phrase)
(define (maybe-extend noun-phrase)
(amb
noun-phrase
(maybe-extend
(list 'noun-phrase
noun-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-simple-noun-phrase)))
)
(run env3)
(check-equal? 'ok))
(~> '(parse '(the student with the cat
sleeps in the class))
(run env3)
(check-equal? '(sentence
(noun-phrase
(simple-noun-phrase (article the)
(noun student))
(prep-phrase (prep with)
(simple-noun-phrase
(article the)
(noun cat))))
(verb-phrase
(verb sleeps)
(prep-phrase (prep in)
(simple-noun-phrase
(article the)
(noun class)))))))
(~> '(parse '(the professor lectures to
the student with the cat))
(runs env3)
(check-equal?
'((sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb-phrase
(verb lectures)
(prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
(sentence
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase
(prep with)
(simple-noun-phrase (article the) (noun cat))))))))))
;; The professor lectures to the student in the class with the cat.를 5가지 방법으로 분석(parse)할 수 있음.
;; 의미를 설명해라.
;;
(~> '(parse '(the professor lectures to the student in the class with the cat))
(runs env3)
(check-equal?
'((sentence
(simple-noun-phrase (article the) (noun professor))
;; 교수가 **고양이와 함께**, 교실에서 학생에게 강의한다. (교수가 고양이 동반)
(verb-phrase
(verb-phrase
(verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
(prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
(sentence
;; 교수가, **고양이가 있는 교실**에서, 학생에게 강의한다. (교실에 고양이가 있음, 교수/학생과 무관.)
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
(prep-phrase
(prep in)
(noun-phrase
(simple-noun-phrase (article the) (noun class))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))
(sentence
(simple-noun-phrase (article the) (noun professor))
;; 교수가, **고양이와 함께 교실에 있는 학생에게**, 강의한다.
(verb-phrase
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
(sentence
;; 교수가, 교실에 있는, **고양이와 함께 있는 학생**에게 강의한다.
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(noun-phrase
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))
(sentence
;; 교수가, **고양이가 있는 교실**에 있는, 학생에게 강의한다. (학생이 교실에 있고, 교실에 고양이가 있음.)
(simple-noun-phrase (article the) (noun professor))
(verb-phrase
(verb lectures)
(prep-phrase
(prep to)
(noun-phrase
(simple-noun-phrase (article the) (noun student))
(prep-phrase
(prep in)
(noun-phrase
(simple-noun-phrase (article the) (noun class))
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat))))))))))))
4_46
;; file: 4_46.rkt
;; 4_45 / 4_46 / 4_47 / 4_48 / 4_49
;; 4.1(meval)과 4.2(leval)의 평가자는 피연산자(operand)가 평가되는 순서를 결정하지 않는다.
;; amb evaluator는 피연산자를 왼쪽에서 오른쪽으로 평가한다
;; Q. 피연산자를 다른 순서로 평가하면 파싱 프로그램이 동작하지 않는데, 그 이유는?
;;
;; parse가 *unparsed*를 사용하여 왼쪽에서 오른쪽으로 이동.
;; parse-sentense시 operand순서가 바뀌면 parse-noun-phrase보다 parse-word가 먼저 실행되어 구문 평가에 에러가 날것임.
'(define (parse input)
(set! *unparsed* input)
...)
'(define (parse-word word-list)
...
(set! *unparsed* (cdr *unparsed*))
...)
'(define (parse-sentence)
;; sentence: 문장
(list 'sentence
(parse-noun-phrase)
(parse-word verbs)))
4_47
;; file: 4_47.rkt
;; 4_45 / 4_46 / 4_47 / 4_48 / 4_49
;; Louis Reasoner: 동사구(verb phrase)가 단순히 동사(verb)이거나 동사구 뒤에 전치사구(prepositional phrase)가 따라오는 구조라고 주장.
;;
'(define (parse-verb-phrase)
;; 4_45: origin
(define (maybe-extend verb-phrase)
(amb
verb-phrase
(maybe-extend
(list 'verb-phrase
verb-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-word verbs)))
'(define (parse-verb-phrase)
;; 4_47: Louis Reasoner
(amb (parse-word verbs)
(list
'verb-phrase
(parse-verb-phrase)
(parse-prepositional-phrase))))
;; Q. 이 방식이 제대로 동작하는가?
;;
;; 내부에서 호출하는 (parse-verb-phrase) 가 무한 루프를 일으킬 가능성.
;;
;; Q. amb 내부의 표현식 순서를 바꾸면 프로그램이 달리 동작하는가?
;;
;; 순서를 바꿔도 무한 루프 가능성은 사라지지 않음.
4_48
;; file: 4_48.rkt
;; 4_45 / 4_46 / 4_47 / 4_48 / 4_49
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 문법(grammar)을 더 복잡하게 확장시켜 보자.
;; 명사구와 동사구를 형용사(adjective)와 부사(adverb)를 포함하도록 한다거나, 중문(compound sentences)을 처리할 수 있도록 하거나.
;;
(define expr-base
'(begin
(define (require p)
(if (not p)
(amb)))
(define nouns
;; noun: 명사
'(noun student professor cat class))
(define verbs
;; verb: 동사
'(verb studies lectures eats sleeps))
(define articles
;; article: 관사
'(article the a))
(define (parse-sentence)
;; sentence: 문장
(list 'sentence
(parse-noun-phrase)
(parse-word verbs)))
(define (parse-noun-phrase)
;; noun-phrase: 명사-구
(list 'noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-word word-list)
(require (not (null? *unparsed*)))
(require (memq (car *unparsed*)
(cdr word-list)))
(let ((found-word (car *unparsed*)))
(set! *unparsed* (cdr *unparsed*))
(list (car word-list) found-word)))
(define *unparsed* '())
(define (parse input)
(set! *unparsed* input)
(let ((sent (parse-sentence)))
(require (null? *unparsed*))
sent))
;;===
(define prepositions
;; preposition: 전치사
'(prep for to in by with))
(define (parse-prepositional-phrase)
;; prepositional-phrase: 전치사-구
(list 'prep-phrase
(parse-word prepositions)
(parse-noun-phrase)))
(define (parse-sentence)
(list 'sentence
(parse-noun-phrase)
(parse-verb-phrase)))
(define (parse-verb-phrase)
(define (maybe-extend verb-phrase)
(amb
verb-phrase
(maybe-extend
(list 'verb-phrase
verb-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-word verbs)))
(define (parse-simple-noun-phrase)
(list 'simple-noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-noun-phrase)
(define (maybe-extend noun-phrase)
(amb
noun-phrase
(maybe-extend
(list 'noun-phrase
noun-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-simple-noun-phrase)))
)
)
(define env3 (setup-environment))
(define-variable! 'append (list 'primitive append) env3)
(~> expr-base
(run env3)
(check-equal? 'ok))
(~> '(parse '(the cat eats))
(runs env3)
(check-equal?
'((sentence (simple-noun-phrase (article the) (noun cat)) (verb eats)))))
(~> '(begin
(define adjectives
;; 형용사
'(adj beautiful big quiet shiny warm cold fast slow powerful soft))
(define (parse-complex-noun-phrase)
;; 관사 형용사 명사
(list 'complex-noun-phrase
(parse-word articles)
(parse-word adjectives)
(parse-word nouns)))
(define (parse-noun-phrase)
(define (maybe-extend noun-phrase)
(amb
noun-phrase
(maybe-extend
(list 'noun-phrase
noun-phrase
(parse-prepositional-phrase)))))
;; before
;;(maybe-extend (parse-simple-noun-phrase))
;;
;; after
(amb (maybe-extend (parse-simple-noun-phrase))
(maybe-extend (parse-complex-noun-phrase)))
))
(run env3)
(check-equal? 'ok))
(~> '(parse '(the beautiful cat eats))
(runs env3)
(check-equal? '((sentence
(complex-noun-phrase (article the) (adj beautiful) (noun cat))
(verb eats)))))
(~> '(begin
(define adverbs
;; 부사
'(adv quickly quietly loudly slowly carefully happily often rarely completely partly))
(define (parse-adverb-list)
(amb
(list (parse-word adverbs))
(cons (parse-word adverbs) (parse-adverb-list))))
(define (parse-verb-phrase)
(define (maybe-extend verb-phrase)
(amb
verb-phrase
(maybe-extend
(list 'verb-phrase
verb-phrase
(parse-prepositional-phrase)))))
;; before
;; (maybe-extend (parse-word verbs))
;;
;; after
(amb (maybe-extend (parse-word verbs))
(maybe-extend
(list 'verb-phrase
(append (list 'adverb-list) (parse-adverb-list))
(parse-word verbs)))
(maybe-extend
(list 'verb-phrase
(parse-word verbs)
(append (list 'adverb-list) (parse-adverb-list))))
))
)
(run env3)
(check-equal? 'ok))
(~> '(parse '(the beautiful cat eats quickly))
(runs env3)
(check-equal?
'((sentence
(complex-noun-phrase (article the) (adj beautiful) (noun cat))
(verb-phrase (verb eats) (adverb-list (adv quickly))))))
)
(~> '(begin
(define coordinating-conjunctions
;; 등위 접속사
'(coord-conj for and nor but or yet so))
(define (parse-sentence)
;; before
;; (list 'sentence
;; (parse-noun-phrase)
;; (parse-verb-phrase))
;;
;; after
(define (maybe-extend sentence)
(amb
sentence
(maybe-extend
(list 'compound-sentence
sentence
(parse-word coordinating-conjunctions)
(parse-sentence)))))
(maybe-extend (list 'sentence
(parse-noun-phrase)
(parse-verb-phrase))))
)
(run env3)
(check-equal? 'ok))
(~> '(parse '(the cat eats and the cat eats))
(runs env3)
(check-equal?
'((compound-sentence
(sentence (simple-noun-phrase (article the) (noun cat)) (verb eats))
(coord-conj and)
(sentence (simple-noun-phrase (article the) (noun cat)) (verb eats))))))
4_49
;; file: 4_49.rkt
;; 4_45 / 4_46 / 4_47 / 4_48 / 4_49 / 4_50
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Alyssa P. Hacker는 문장을 파싱하는 것보다 흥미로운 문장을 생성하는 데 더 관심이 있다.
;; 그녀는 parse-word 프로시저를 수정하여 "입력 문장"을 무시하고, 대신 항상 성공적으로 적절한 단어를 생성하도록 하면,
;; 기존에 파싱을 위해 작성된 프로그램을 문장 생성에 사용할 수 있다고 생각한다.
;; Alyssa의 아이디어를 구현하고, 생성된 처음 6개 정도의 문장을 보여라.
(define expr-base
'(begin
(define (require p)
(if (not p)
(amb)))
(define nouns
;; noun: 명사
'(noun student professor cat class))
(define verbs
;; verb: 동사
'(verb studies lectures eats sleeps))
(define articles
;; article: 관사
'(article the a))
(define (parse-sentence)
;; sentence: 문장
(list 'sentence
(parse-noun-phrase)
(parse-word verbs)))
(define (parse-noun-phrase)
;; noun-phrase: 명사-구
(list 'noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-word word-list)
(require (not (null? *unparsed*)))
(require (memq (car *unparsed*)
(cdr word-list)))
(let ((found-word (car *unparsed*)))
(set! *unparsed* (cdr *unparsed*))
(list (car word-list) found-word)))
(define *unparsed* '())
(define (parse input)
(set! *unparsed* input)
(let ((sent (parse-sentence)))
(require (null? *unparsed*))
sent))
;;===
(define prepositions
;; preposition: 전치사
'(prep for to in by with))
(define (parse-prepositional-phrase)
;; prepositional-phrase: 전치사-구
(list 'prep-phrase
(parse-word prepositions)
(parse-noun-phrase)))
(define (parse-sentence)
(list 'sentence
(parse-noun-phrase)
(parse-verb-phrase)))
(define (parse-verb-phrase)
(define (maybe-extend verb-phrase)
(amb
verb-phrase
(maybe-extend
(list 'verb-phrase
verb-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-word verbs)))
(define (parse-simple-noun-phrase)
(list 'simple-noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-noun-phrase)
(define (maybe-extend noun-phrase)
(amb
noun-phrase
(maybe-extend
(list 'noun-phrase
noun-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-simple-noun-phrase)))
)
)
(define env3 (setup-environment))
(define-variable! 'append (list 'primitive append) env3)
(define-variable! '< (list 'primitive <) env3)
(define-variable! 'error (list 'primitive error) env3)
(define-variable! 'random (list 'primitive random) env3)
(define-variable! 'length (list 'primitive length) env3)
(racket:random-seed 42)
(~> expr-base
(run env3)
(check-equal? 'ok))
(~> '(parse '(the cat eats))
(runs env3)
(check-equal?
'((sentence (simple-noun-phrase (article the) (noun cat)) (verb eats)))))
(~> '(begin
(define (nth lst n)
(cond ((null? lst) (error "Index out of bounds"))
((< n 0) (error "Index cannot be negative"))
((= n 0) (car lst))
(else (nth (cdr lst) (- n 1)))))
(define (parse-word word-list)
(require (not (null? *unparsed*)))
(require (memq (car *unparsed*)
(cdr word-list)))
(let ((found-word (car *unparsed*)))
(set! *unparsed* (cdr *unparsed*))
;; before
;; (list (car word-list) found-word)
;; after
(list (car word-list)
(nth (cdr word-list)
(random (length (cdr word-list)))))
))
)
(run env3))
(~> '(parse '(the cat eats))
(run env3)
(check-equal? '(sentence (simple-noun-phrase (article the) (noun student)) (verb sleeps))))
4_50
;; file: 4_50.rkt
;; 4_45 / 4_46 / 4_47 / 4_48 / 4_49 / 4_50
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; special form ramb를 만들자.
;; - amb : 인자 왼쪽에서 오른쪽으로 순서대로 고름.
;; - ramd: 순서를 random으로 고름.
;; 4.49에서 Alyssa의 문제를 푸는데 어떤 도움을 줄 수 있는가?
;; helper
(define (list-ref items n)
(if (= n 0)
(car items)
(list-ref (cdr items) (- n 1))))
(define (filter predicate sequence)
(cond ((null? sequence) nil)
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (remove item sequence)
(filter (lambda (x) (not (eq? x item)))
sequence))
;;
(define (ramb? exp)
(tagged-list? exp 'ramb))
(define (analyze-ramb exp)
(let ((cprocs (map analyze (rest exp))))
(lambda (env succeed fail)
(define (try-next choices)
(if (null? choices)
(fail)
;; before: analyze-amb
;; ((car choices) env
;; succeed
;; (lambda ()
;; (try-next (cdr choices))))
;;
;; after: analyze-ramb
(let* ((r-idx (random (length choices)))
(r-item (list-ref choices r-idx))
(next-items (remove r-item choices)))
(r-item env
succeed
(lambda ()
(try-next next-items))))))
(try-next cprocs))))
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp)))
((amb? exp) (analyze-amb exp))
((ramb? exp) (analyze-ramb exp)) ;**
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(override-analyze! analyze)
;;
(define expr-base
'(begin
(define (require p)
(if (not p)
(amb)))
(define nouns
;; noun: 명사
'(noun student professor cat class))
(define verbs
;; verb: 동사
'(verb studies lectures eats sleeps))
(define articles
;; article: 관사
'(article the a))
(define (parse-sentence)
;; sentence: 문장
(list 'sentence
(parse-noun-phrase)
(parse-word verbs)))
(define (parse-noun-phrase)
;; noun-phrase: 명사-구
(list 'noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-word word-list)
(require (not (null? *unparsed*)))
(require (memq (car *unparsed*)
(cdr word-list)))
(let ((found-word (car *unparsed*)))
(set! *unparsed* (cdr *unparsed*))
(list (car word-list) found-word)))
(define *unparsed* '())
(define (parse input)
(set! *unparsed* input)
(let ((sent (parse-sentence)))
(require (null? *unparsed*))
sent))
;;===
(define prepositions
;; preposition: 전치사
'(prep for to in by with))
(define (parse-prepositional-phrase)
;; prepositional-phrase: 전치사-구
(list 'prep-phrase
(parse-word prepositions)
(parse-noun-phrase)))
(define (parse-sentence)
(list 'sentence
(parse-noun-phrase)
(parse-verb-phrase)))
(define (parse-verb-phrase)
(define (maybe-extend verb-phrase)
(amb
verb-phrase
(maybe-extend
(list 'verb-phrase
verb-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-word verbs)))
(define (parse-simple-noun-phrase)
(list 'simple-noun-phrase
(parse-word articles)
(parse-word nouns)))
(define (parse-noun-phrase)
(define (maybe-extend noun-phrase)
(amb
noun-phrase
(maybe-extend
(list 'noun-phrase
noun-phrase
(parse-prepositional-phrase)))))
(maybe-extend (parse-simple-noun-phrase)))
)
)
(define env3 (setup-environment))
(define-variable! 'append (list 'primitive append) env3)
(define-variable! '< (list 'primitive <) env3)
(define-variable! 'error (list 'primitive error) env3)
(define-variable! 'random (list 'primitive random) env3)
(define-variable! 'length (list 'primitive length) env3)
(racket:random-seed 42)
(~> expr-base
(run env3)
(check-equal? 'ok))
(~> '(parse '(the cat eats))
(runs env3)
(check-equal?
'((sentence (simple-noun-phrase (article the) (noun cat)) (verb eats)))))
(~> '(begin
(define (nth lst n)
(cond ((null? lst) (error "Index out of bounds"))
((< n 0) (error "Index cannot be negative"))
((= n 0) (car lst))
(else (nth (cdr lst) (- n 1)))))
(define (ramdom-select lst)
(if (null? lst)
'()
(ramb (car lst)
(ramdom-select (cdr lst)))))
(define (parse-word word-list)
(require (not (null? *unparsed*)))
(require (memq (car *unparsed*)
(cdr word-list)))
(let ((found-word (car *unparsed*)))
(set! *unparsed* (cdr *unparsed*))
;; before
;; (list (car word-list) found-word)
;;
;; before: 4.49
;; (list (car word-list)
;; (nth (cdr word-list)
;; (random (length (cdr word-list)))))
;;
;; after: 4.50
(list (car word-list)
(ramdom-select (cdr word-list)))
))
)
(run env3))
(~> '(parse '(the cat eats))
(run env3)
(check-equal? '(sentence (simple-noun-phrase (article the) (noun student)) (verb lectures))))
4_51
;; file: 4_51.rkt
;; 4_51 / 4_52 / 4_53
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(racket:provide
;; ((permutation-set? exp) (analyze-permutation-set exp)) ;**
permutation-set? analyze-permutation-set)
;; 실패로 끝나더라도 값을 유지하는, permutation-set! 구현하라.
;;
;; permanent-set! 말고 set! 을 썼다면 어 떤 값이 나오는가?
;;
(define (permutation-set? exp)
(tagged-list? exp 'permanent-set!))
(define (analyze-permutation-set exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
;; before: analyze-assignment
;; (lambda (val fail2) ; *1*
;; (let ((old-value (lookup-variable-value var env)))
;; (set-variable-value! var val env)
;; (succeed 'ok
;; (lambda () ; *2*
;; (set-variable-value! var old-value env)
;; (fail2)))))
;;
;; after: analyze-permutation-set
;; analyze-assignment에서 old-value를 저장해서 덮어쓰는 로직 제거.
(lambda (val fail2)
(set-variable-value! var val env)
(succeed 'ok fail2))
fail))))
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((permutation-set? exp) (analyze-permutation-set exp)) ;**
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp)))
((amb? exp) (analyze-amb exp))
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(override-analyze! analyze)
;; ======================================
(define env3 (setup-environment))
(~> '(begin
(define (require p)
(if (not p)
(amb)))
(define (an-element-of items)
(require (not (null? items)))
(amb (car items) (an-element-of (cdr items))))
)
(run env3)
(check-equal? 'ok))
(~> '(begin
;; set! 테스트
(define count 0)
(let ((x (an-element-of '(a b c)))
(y (an-element-of '(a b c))))
(set! count (+ count 1)) ;;(permanent-set! count (+ count 1))
(require (not (eq? x y)))
(list x y count)))
(runs env3)
(check-equal? '((a b 1) (a c 1) (b a 1) (b c 1) (c a 1) (c b 1)))
)
(~> '(begin
;; permanent-set! 테스트
(define count 0)
(let ((x (an-element-of '(a b c)))
(y (an-element-of '(a b c))))
(permanent-set! count (+ count 1))
(require (not (eq? x y)))
(list x y count)))
(runs env3)
(check-equal? '((a b 2) (a c 3) (b a 4) (b c 6) (c a 7) (c b 8))))
4_52
;; file: 4_52.rkt
;; 4_51 / 4_52 / 4_53
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(racket:provide
;; ((if-fail? exp) (analyze-if-fail exp)) ;**
if-fail? analyze-if-fail)
;; 표현식 2개를 받아 첫번째가 성공시 첫번째 값을, 실패시 두번째 값을 반환하는 if-fail을 구현해라.
(define (if-fail? exp)
(tagged-list? exp 'if-fail))
(define (analyze-if-fail exp)
(let ((pproc (analyze (if-predicate exp)))
(cproc (analyze (if-consequent exp))))
(lambda (env succeed fail)
;; before: analyze-if
;; (pproc env
;; (lambda (pred-value fail2)
;; (if (true? pred-value)
;; (cproc env succeed fail2)
;; (aproc env succeed fail2)))
;; fail)
;;
;; after: analyze-if-fail
(pproc env
succeed
(lambda ()
(cproc env succeed fail))))))
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((if-fail? exp) (analyze-if-fail exp)) ;**
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp)))
((amb? exp) (analyze-amb exp))
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(override-analyze! analyze)
;; ======================================
(define env3 (setup-environment))
(define-variable! 'even? (list 'primitive even?) env3)
(~> '(begin
(define (require p)
(if (not p)
(amb)))
(define (an-element-of items)
(require (not (null? items)))
(amb (car items) (an-element-of (cdr items))))
)
(run env3)
(check-equal? 'ok))
(~> '(if-fail
(let ((x (an-element-of '(1 3 5))))
(require (even? x))
x)
'all-odd)
(run env3)
(check-equal? 'all-odd)
)
(~> '(if-fail
(let ((x (an-element-of '(1 3 5 8))))
(require (even? x))
x)
'all-odd)
(run env3)
(check-equal? '8)
)
4_53
;; file: 4_53.rkt
;; 4_51 / 4_52 / 4_53
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 연습문제 4.51의 permanent-set! 와 연습문제 4.52의 if-fail을 가지고 다음을 구해보면?
;; 일단 permanent-set! / if-fail 적용시켜주고,
(#%require "4_51.rkt")
(#%require "4_52.rkt")
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((permutation-set? exp) (analyze-permutation-set exp)) ;**
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((if-fail? exp) (analyze-if-fail exp)) ;**
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp)))
((amb? exp) (analyze-amb exp))
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(override-analyze! analyze)
;; =================================================
(define env3 (setup-environment))
(define-variable! 'even? (list 'primitive even?) env3)
(~> '(begin
(define (square x) (* x x))
(define (smallest-divisor n)
(find-divisor n 2))
(define (find-divisor n test-divisor)
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (+ test-divisor 1)))))
(define (divides? a b)
(= (remainder b a) 0))
(define (prime? n)
(= n (smallest-divisor n))))
(run env3)
(check-equal? 'ok))
(~> '(begin
(define (require p)
(if (not p)
(amb)))
(define (an-element-of items)
(require (not (null? items)))
(amb (car items) (an-element-of (cdr items))))
(define (prime-sum-pair list1 list2)
(let ((a (an-element-of list1))
(b (an-element-of list2)))
(require (prime? (+ a b)))
(list a b)))
)
(run env3)
(check-equal? 'ok))
(~> '(let ((pairs '()))
(if-fail (let ((p (prime-sum-pair
'(1 3 5 8)
'(20 35 110))))
(permanent-set! pairs (cons p pairs))
(amb))
pairs))
(runs env3)
(check-equal? '(
((8 35) (3 110) (3 20))
))
)
4_54
;; file: 4_54.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.3.3-ambeval.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; amb함수를 써서 require 함수를 구현하는 방법을 모른다면, special form으로 만들어야함.
;; special form으로 require문을 처리해라.
(define (require? exp)
(tagged-list? exp 'require))
(define (require-predicate exp)
(cadr exp))
(define (analyze-require exp)
;; analyze-if 참고.
(let ((pproc (analyze (require-predicate exp))))
(lambda (env succeed fail)
(pproc env
(lambda (pred-value fail2)
(if (not pred-value)
(fail2)
(succeed 'ok fail2)))
fail))))
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp)))
((amb? exp) (analyze-amb exp))
((require? exp) (analyze-require exp)) ; <-----------------
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(override-analyze! analyze)
;; =================================================
(define env2 (setup-environment))
(~> '(let ((x (amb 0 1 2)))
(require (> x 0))
x)
(runs env2)
(check-equal? '(1 2)))
(~> '(begin
(define (square x) (* x x))
(define (smallest-divisor n)
(find-divisor n 2))
(define (find-divisor n test-divisor)
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (+ test-divisor 1)))))
(define (divides? a b)
(= (remainder b a) 0))
(define (prime? n)
(= n (smallest-divisor n)))
(define (an-element-of items)
(require (not (null? items)))
(amb (car items)
(an-element-of (cdr items))))
(define (prime-sum-pair list1 list2)
(let ((a (an-element-of list1))
(b (an-element-of list2)))
(require (prime? (+ a b)))
(list a b)))
)
(run env2)
(check-equal? 'ok))
(~> '(prime-sum-pair '(1 3 5 8) '(20 35 110))
(runs env2)
(check-equal? '((3 20)
(3 110)
(8 35))))
(~> '(prime-sum-pair '(19 27 30) '(11 36 58))
(run env2)
(check-equal? '(30 11)))
4_55
;; file: 4_55.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(initialize-data-base microshaft-data-base)
;; (query-driver-loop)
(~> '(job ?x (computer programmer))
(run)
(check-equal? '((job (Fect Cy D) (computer programmer))
(job (Hacker Alyssa P) (computer programmer)))))
;; 쿼리 만들어보기
;;
;; (address {이름} {주소})
;; (job {이름} ({부서} . {타이틀}))
;; (salary {이름} {급여})
;; (supervisor {하급자} {상급자})
;; (can-do-job {상위직업} {하위직업})
;; 1. Ben Bitdiddle가 관리하는 모든 사람들
(~> '(supervisor ?name (Bitdiddle Ben))
(run)
(check-equal? '(
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
)))
;; 2. accounting 부서의 모든 사람들의 이름과 직업;
(~> '(job ?name (accounting . ?job))
(run)
(check-equal? '(
(job (Cratchet Robert) (accounting scrivener))
(job (Scrooge Eben) (accounting chief accountant))
)))
;; 3. Slumerville에 살고 있는 사람들의 이름과 주소
(~> '(address ?name (Slumerville . ?address))
(run)
(check-equal? '(
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
)))
4_56
;; file: 4_56.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 쿼리 만들어보기
(initialize-data-base microshaft-data-base)
;; (and
;; (or
;; (not
;; (lisp-value {predicate} {arg0} ... {argn})
;; 1. Ben Bitdiddle가 관리하는 모든 사람의 이름과 주소
(~> '(and (supervisor ?name (Bitdiddle Ben))
(address ?name ?address))
(run)
(check-equal? '(
(and (supervisor (Tweakit Lem E) (Bitdiddle Ben))
(address (Tweakit Lem E) (Boston (Bay State Road) 22)))
(and (supervisor (Fect Cy D) (Bitdiddle Ben))
(address (Fect Cy D) (Cambridge (Ames Street) 3)))
(and (supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)))
)))
;; 2. Ben Bitdiddle 보다 salary가 적은 사람들과 급여. 그리고 Ben Bitdiddle의 급여.
(~> '(and (salary (Bitdiddle Ben) ?ben-salary)
(salary ?name ?amount)
(lisp-value < ?amount ?ben-salary))
(run)
(check-equal? '(
(and (salary (Bitdiddle Ben) 60000)
(salary (Aull DeWitt) 25000)
(lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000)
(salary (Cratchet Robert) 18000)
(lisp-value < 18000 60000))
(and (salary (Bitdiddle Ben) 60000)
(salary (Reasoner Louis) 30000)
(lisp-value < 30000 60000))
(and (salary (Bitdiddle Ben) 60000)
(salary (Tweakit Lem E) 25000)
(lisp-value < 25000 60000))
(and (salary (Bitdiddle Ben) 60000)
(salary (Fect Cy D) 35000)
(lisp-value < 35000 60000))
(and (salary (Bitdiddle Ben) 60000)
(salary (Hacker Alyssa P) 40000)
(lisp-value < 40000 60000))
)))
;; 3. computer 부서에 속하지 않은 사람이 관리하는 모든 사람들 그리고 관리자. 이름과 job 포함.
(~> '(and (job ?supervisor-name (computer . ?x))
(supervisor ?name ?supervisor-name)
(job ?name . ?y)
)
(run)
(check-equal? '(
(and (job (Hacker Alyssa P) (computer programmer))
(supervisor (Reasoner Louis) (Hacker Alyssa P))
(job (Reasoner Louis) (computer programmer trainee)))
(and (job (Bitdiddle Ben) (computer wizard))
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(job (Tweakit Lem E) (computer technician)))
(and (job (Bitdiddle Ben) (computer wizard))
(supervisor (Fect Cy D) (Bitdiddle Ben))
(job (Fect Cy D) (computer programmer)))
(and (job (Bitdiddle Ben) (computer wizard))
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(job (Hacker Alyssa P) (computer programmer)))
)))
4_57
;; file: 4_57.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 쿼리 만들어보기
(initialize-data-base microshaft-data-base)
;; (rule {패턴} {질의문})
;; (rule (lives-near ?person-1 ?person-2) : 주변에 사는가?
;; (rule (same ?x ?x)) : 같은가?
;; (rule (wheel ?person) : supervisor의 supervisor
;; (rule (outranked-by ?staff-person ?boss) : ?boss가 관리하는 자(?staff-person)인가?
(~> '(lives-near ?x (Bitdiddle Ben))
(run)
(check-equal? '((lives-near (Aull DeWitt) (Bitdiddle Ben))
(lives-near (Reasoner Louis) (Bitdiddle Ben)))))
(~> '(and (job ?x (computer programmer))
(lives-near ?x (Bitdiddle Ben)))
(run)
(check-equal? '()))
;; 정의한 규칙을 사용하여 다음을 찾는 질의를 작성하시오:
;; - 사람 1이 사람 2를 대체할 수 있으려면,
;; - 사람 1이 사람 2와 같은 직업을 가지거나,
;; - 사람 1의 직업을 가진 누군가가 사람 2의 직업도 수행할 수 있어야 하며,
;; - 사람 1과 사람 2가 동일한 사람이 아니어야 한다.
(define rule-can-replace
'(rule (can-replace ?person-Replacer ?person-Replaced)
(and (job ?person-Replacer ?job-1)
(job ?person-Replaced ?job-2)
(or
(same ?job-1 ?job-2) ;; - 사람 1이 사람 2와 같은 직업을 가지거나,
(can-do-job ?job-1 ?job-2) ;; - 사람 1의 직업을 가진 누군가가 사람 2의 직업도 수행할 수 있어야 하며,
)
(not (same ?person-Replacer ?person-Replaced)) ;; - 사람 1과 사람 2가 동일한 사람이 아니어야 한다.
)))
(~>> (list rule-can-replace)
(append microshaft-data-base)
(initialize-data-base))
;; a. Cy D. Fect을 대신할 수 있는 모든 사람들.
(~> '(can-replace ?person (Fect Cy D))
(run)
(check-equal? '(
(can-replace (Bitdiddle Ben) (Fect Cy D))
(can-replace (Hacker Alyssa P) (Fect Cy D))
)))
;; b. 보다 급여를 많이 받는 사람을 대신할 수 있는 후보목록(대체할 수 있는 사람과 대채자 그리고 급여와 같이)
(~> '(and (can-replace ?person-1 ?person-2)
(salary ?person-1 ?salary-1)
(salary ?person-2 ?salary-2)
(lisp-value < ?salary-1 ?salary-2))
(run)
(check-equal? '((and (can-replace (Aull DeWitt) (Warbucks Oliver))
(salary (Aull DeWitt) 25000)
(salary (Warbucks Oliver) 150000)
(lisp-value < 25000 150000))
(and (can-replace (Fect Cy D) (Hacker Alyssa P))
(salary (Fect Cy D) 35000)
(salary (Hacker Alyssa P) 40000)
(lisp-value < 35000 40000)))))
4_58
;; file: 4_58.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 쿼리 만들어보기
;; 다음 조건을 만족하는 규칙을 정의하시오:
;; - 한 사람이 부서에서 "중요 인물(big shot)"로 간주되려면
;; - 그 사람이 해당 부서에서 일하고,
;; - 그 부서에서 일하는 상사가 없어야 한다.
(define rule-bigshot
'(rule (bigshot ?person ?division)
(and (job ?person (?division . ?title-1)) ;; - 그 사람이 해당 부서에서 일하고,
(not (and (job ?supervisor (?division . ?title-2)) ;; - 그 부서에서 일하는 상사가 없어야 한다.
(supervisor ?person ?supervisor))))))
(~>> (list rule-bigshot)
(append microshaft-data-base)
(initialize-data-base))
(~> '(bigshot ?person ?division)
(run)
(check-equal? '((bigshot (Scrooge Eben) accounting)
(bigshot (Warbucks Oliver) administration)
(bigshot (Bitdiddle Ben) computer))))
4_59
;; file: 4_59.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 쿼리 만들어보기
(define rows
'(
;; (meeting {부서} ({요일} {시간}))
(meeting accounting (Monday 9am))
(meeting administration (Monday 10am))
(meeting computer (Wednesday 3pm))
(meeting administration (Friday 1pm))
;; 모든 사원 참석.
(meeting whole-company (Wednesday 4pm))
))
;; a. 금요일 아침에 Ben은 그 날에 있는 모든 회의를 찾으려 한다.
(~> microshaft-data-base
(append rows)
(initialize-data-base))
(~> '(meeting ?division (Friday ?time))
(run)
(check-equal? '((meeting administration (Friday 1pm)))))
;; b. 자기 이름으로 자기가 참석해야할 모든 회의를 뽑는 룰을 만들어라.
(define rule-meeting-time
'(rule (meeting-time ?person ?day-and-time)
(and (job ?person (?division . ?title))
(or (meeting ?division ?day-and-time)
(meeting whole-company ?day-and-time))))
)
(~> microshaft-data-base
(append rows)
(append (list rule-meeting-time))
(initialize-data-base))
;; c. 수요일에 Alyssa는 그 날 참석해야할 회의를 찾으려 한다.
(~> '(and (meeting ?div (Wednesday . ?time))
(meeting-time (Hacker Alyssa P) (Wednesday . ?time)))
(run)
(check-equal? '((and (meeting whole-company (Wednesday 4pm))
(meeting-time (Hacker Alyssa P) (Wednesday 4pm)))
(and (meeting computer (Wednesday 3pm))
(meeting-time (Hacker Alyssa P) (Wednesday 3pm))))))
4_60
;; file: 4_60.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(~> microshaft-data-base
(initialize-data-base))
(~> '(lives-near ?person (Hacker Alyssa P))
(run)
(check-equal? '((lives-near (Fect Cy D) (Hacker Alyssa P)))))
(~> '(lives-near ?person-1 ?person-2)
(run)
(check-equal? '((lives-near (Aull DeWitt) (Reasoner Louis)) ; A
(lives-near (Aull DeWitt) (Bitdiddle Ben)) ; B
(lives-near (Reasoner Louis) (Aull DeWitt)) ; A
(lives-near (Reasoner Louis) (Bitdiddle Ben)) ; D
(lives-near (Hacker Alyssa P) (Fect Cy D)) ; ** C
(lives-near (Fect Cy D) (Hacker Alyssa P)) ; ** C
(lives-near (Bitdiddle Ben) (Aull DeWitt)) ; B
(lives-near (Bitdiddle Ben) (Reasoner Louis))))) ; D
;; Q. 왜 중복해서 나오는 문제가 있는가?
;;
;; (rule (lives-near ?person-1 ?person-2)
;; (and (address ?person-1 (?town . ?rest-1))
;; (address ?person-2 (?town . ?rest-2))
;; (not (same ?person-1 ?person-2))))
;;
;; 룰에서 ?person-1 / ?person-2가 같지만 않으면 통과라서. 추가 제제가 없음.
;;
;; Q. 가까운데 사는데 중복이 없도록 나오게 만들 방법이 있는가?
;;
;; uid를 주입해서 활용.
(define uids
;; (uid {unique-id} {이름})
'((uid 1 (Aull DeWitt))
(uid 2 (Cratchet Robert))
(uid 3 (Scrooge Eben))
(uid 4 (Warbucks Oliver))
(uid 5 (Reasoner Louis))
(uid 6 (Tweakit Lem E))
(uid 7 (Fect Cy D))
(uid 8 (Hacker Alyssa P))
(uid 9 (Bitdiddle Ben))))
(~> microshaft-data-base
(append uids)
(initialize-data-base))
(~> '(and (lives-near ?person-1 ?person-2)
(uid ?uid-1 ?person-1)
(uid ?uid-2 ?person-2)
(lisp-value < ?uid-1 ?uid-2))
(run)
(check-equal?
'((and (lives-near (Aull DeWitt) (Reasoner Louis)) (uid 1 (Aull DeWitt)) (uid 5 (Reasoner Louis)) (lisp-value < 1 5))
(and (lives-near (Aull DeWitt) (Bitdiddle Ben)) (uid 1 (Aull DeWitt)) (uid 9 (Bitdiddle Ben)) (lisp-value < 1 9))
(and (lives-near (Reasoner Louis) (Bitdiddle Ben)) (uid 5 (Reasoner Louis)) (uid 9 (Bitdiddle Ben)) (lisp-value < 5 9))
(and (lives-near (Fect Cy D) (Hacker Alyssa P)) (uid 7 (Fect Cy D)) (uid 8 (Hacker Alyssa P)) (lisp-value < 7 8)))))
;; 이름정렬방식 : environment에 함수를 주입 lisp-value를 사용하여 사람 이름으로 정렬.
;; - 이름이 중복일 경우도 있음. => 문제발생.
(let ((environment (scheme-report-environment 5)))
(eval
'(begin
(define (fold-right op init lst)
(if (null? lst)
init
(op (car lst) (fold-right op init (cdr lst)))))
(define (string-join lst delimiter)
(if (null? lst)
""
(fold-right (lambda (x acc)
(if (string=? acc "")
x
(string-append x delimiter acc)))
""
lst)))
(define (pair->string pair)
(string-join (map symbol->string pair) " "))
(define (compare-person-name p1 p2)
(string<? (pair->string p1)
(pair->string p2))))
environment)
(override-user-initial-environment! environment))
(~> '(and (lives-near ?person-1 ?person-2)
(lisp-value compare-person-name ?person-1 ?person-2))
(run)
(check-equal? '((and (lives-near (Aull DeWitt) (Reasoner Louis))
(lisp-value compare-person-name (Aull DeWitt) (Reasoner Louis)))
(and (lives-near (Aull DeWitt) (Bitdiddle Ben))
(lisp-value compare-person-name (Aull DeWitt) (Bitdiddle Ben)))
(and (lives-near (Fect Cy D) (Hacker Alyssa P))
(lisp-value compare-person-name (Fect Cy D) (Hacker Alyssa P)))
(and (lives-near (Bitdiddle Ben) (Reasoner Louis))
(lisp-value compare-person-name (Bitdiddle Ben) (Reasoner Louis))))))
4_61
;; file: 4_61.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(define rules-append-to-form
'(
;; (append-to-form ?x ?y ?z) : ?x 랑 ?y를 합쳐서 ?z만들기.
;; (append-to-form (a b) (c d) ?z)
;;=> ((append-to-form (a b) (c d) (a b c d)))
(rule (append-to-form () ?y ?y))
(rule (append-to-form (?u . ?v) ?y (?u . ?z))
(append-to-form ?v ?y ?z))
))
(~> microshaft-data-base
(append rules-append-to-form)
(initialize-data-base))
(~> '(append-to-form (a b) (c d) ?z)
(run)
(check-equal? '((append-to-form (a b) (c d) (a b c d)))))
(~> '(append-to-form (a b) ?y (a b c d))
(run)
(check-equal? '((append-to-form (a b) (c d) (a b c d)))))
(~> '(append-to-form ?x ?y (a b c d))
(run)
(check-equal? '((append-to-form (a b c d) () (a b c d))
(append-to-form () (a b c d) (a b c d))
(append-to-form (a) (b c d) (a b c d))
(append-to-form (a b) (c d) (a b c d))
(append-to-form (a b c) (d) (a b c d)))))
;; 쿼리 만들어보기
(define rules-next-to
'(
;; (?x next-to ?y in ?z) : ?z에서 붙어있는 ?x / ?y 찾기
(rule (?x next-to ?y in (?x ?y . ?u)))
(rule (?x next-to ?y in (?v . ?z))
(?x next-to ?y in ?z))
))
(~> microshaft-data-base
(append rules-next-to)
(initialize-data-base))
(~> '(?x next-to ?y in (1 (2 3) 4))
(run)
(check-equal? '(((2 3) next-to 4 in (1 (2 3) 4))
(1 next-to (2 3) in (1 (2 3) 4)))))
(~> '(?x next-to 1 in (2 1 3 1))
(run)
(check-equal? '((3 next-to 1 in (2 1 3 1))
(2 next-to 1 in (2 1 3 1)))))
4_62
;; file: 4_62.rkt
;; 2_17 / 4_62 / 4_63 / 4_69
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(racket:provide
rules-last-pair)
;; Q. 연습문제 2.17에 나온 last-pair를 rule로 만들어라.
;;
;; - 연습문제 2.17
;; - last-pair: 마지막 요소가 포함된 리스트를 반환하는 함수
;; - (last-pair (list 23 72 149 34)) ;=> (34)
;;
(define rules-last-pair
'(
;; (last-pair ?lst (?last-elem)) : ?lst에서 ?last-elem을 찾음
(rule (last-pair (?x) (?x))) ; == (rule (last-pair (?x . ()) (?x . ())))
(rule (last-pair (?x . ?y) ?z)
(last-pair ?y ?z))
)
)
(~> microshaft-data-base
(append rules-last-pair)
(initialize-data-base))
(~> '(last-pair (3) ?x)
(run)
(check-equal? '((last-pair (3) (3)))))
(~> '(last-pair (1 2 3) ?x)
(run)
(check-equal? '((last-pair (1 2 3) (3)))))
(~> '(last-pair (2 ?x) (3))
(run)
(check-equal? '((last-pair (2 3) (3)))))
;; Q. (last-pair ?x (3)) 와 같은 것에도 제대로 동작하나?
;; 제약조건인 ?x가 미지수이기에 결과를 제대로 얻지못함.
4_63
;; file: 4_63.rkt
;; 2_17 / 4_62 / 4_63 / 4_69
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(racket:provide
Genesis-4
rules-find-grandson
rules-find-son
)
(define Genesis-4
'(
;; 창세기 4 족보
;;
;; 아담(Adam)
;; └── 가인(Cain)
;; └── 에녹(Enoch)
;; └── 이라드(Irad)
;; └── 므후야엘(Mehujael)
;; └── 므드사엘(Methushael)
;; └── 라멕(Lamech) + 아다(Adah)
;; ├── 야발(Jabal)
;; └── 유발(Jubal)
;; (son {부모} {아들})
;; (wife {남편} {아내})
(son Adam Cain)
(son Cain Enoch)
(son Enoch Irad)
(son Irad Mehujael)
(son Mehujael Methushael)
(son Methushael Lamech)
(wife Lamech Ada)
(son Ada Jabal)
(son Ada Jubal)
))
;; Q. 규칙을 만들어라
;;
;; - S가 f의 아들이고, f가 G의 아들이면, S는 G의 손자이다
;; - W가 M의 아내이고, S가 W의 아들이면, S는 M의 아들이다.
(define rules-find-grandson
'(
;; (find-grandson {조부모} {손자})
(rule (find-grandson ?G ?S) ; S는 G의 손자이다
(and (find-son ?f ?S) ; S가 f의 아들이고,
(find-son ?G ?f))) ; f가 G의 아들이면,
)
)
(define rules-find-son
'(
;; (find-son {부모} {아들})
(rule (find-son ?M ?S) ; S는 M의 아들이다.
(or (son ?M ?S)
(and (wife ?M ?W) ; W가 M의 아내이고,
(son ?W ?S)))) ; S가 W의 아들이면,
))
;; Q. Cain의 손자 / Lamech의 아들들 / Methushael의 손자들을 찾아내는 쿼리 만들어라.
(~> microshaft-data-base
(append Genesis-4)
(append rules-find-grandson)
(append rules-find-son)
(initialize-data-base))
(~> '(find-grandson Cain ?grandson)
(run)
(check-equal? '((find-grandson Cain Irad))))
(~> '(find-son Lamech ?son)
(run)
(check-equal? '((find-son Lamech Jubal)
(find-son Lamech Jabal))))
(~> '(find-grandson Methushael ?grandson)
(run)
(check-equal? '((find-grandson Methushael Jubal)
(find-grandson Methushael Jabal))))
4_64
;; file: 4_64.rkt
;; 4_64 / 4_67
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(racket:provide
microshaft-data-base-modified-outranked-by)
;; Q. outranked-by를 바꿨는데, 왜 무한 루프에 빠지는가?
;;
;; 제약조건 (supervisor ?staff-person ?middle-manager)와 (outranked-by ?middle-manager ?boss)의 순서가 바뀌면서,
;; outranked-by에서 제약을 받지않는 ?middle-manager ?boss 변수를 찾으려고 시도하는데, 이제 자꾸 반복되어 호출되면서 무한루프.
;;
(define microshaft-data-base-modified-outranked-by
'(
;; from section 4.4.1
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
(job (Bitdiddle Ben) (computer wizard))
(salary (Bitdiddle Ben) 60000)
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
(job (Hacker Alyssa P) (computer programmer))
(salary (Hacker Alyssa P) 40000)
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(address (Fect Cy D) (Cambridge (Ames Street) 3))
(job (Fect Cy D) (computer programmer))
(salary (Fect Cy D) 35000)
(supervisor (Fect Cy D) (Bitdiddle Ben))
(address (Tweakit Lem E) (Boston (Bay State Road) 22))
(job (Tweakit Lem E) (computer technician))
(salary (Tweakit Lem E) 25000)
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(job (Reasoner Louis) (computer programmer trainee))
(salary (Reasoner Louis) 30000)
(supervisor (Reasoner Louis) (Hacker Alyssa P))
(supervisor (Bitdiddle Ben) (Warbucks Oliver))
(address (Warbucks Oliver) (Swellesley (Top Heap Road)))
(job (Warbucks Oliver) (administration big wheel))
(salary (Warbucks Oliver) 150000)
(address (Scrooge Eben) (Weston (Shady Lane) 10))
(job (Scrooge Eben) (accounting chief accountant))
(salary (Scrooge Eben) 75000)
(supervisor (Scrooge Eben) (Warbucks Oliver))
(address (Cratchet Robert) (Allston (N Harvard Street) 16))
(job (Cratchet Robert) (accounting scrivener))
(salary (Cratchet Robert) 18000)
(supervisor (Cratchet Robert) (Scrooge Eben))
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(job (Aull DeWitt) (administration secretary))
(salary (Aull DeWitt) 25000)
(supervisor (Aull DeWitt) (Warbucks Oliver))
(can-do-job (computer wizard) (computer programmer))
(can-do-job (computer wizard) (computer technician))
(can-do-job (computer programmer)
(computer programmer trainee))
(can-do-job (administration secretary)
(administration big wheel))
(rule (lives-near ?person-1 ?person-2)
(and (address ?person-1 (?town . ?rest-1))
(address ?person-2 (?town . ?rest-2))
(not (same ?person-1 ?person-2))))
(rule (same ?x ?x))
(rule (wheel ?person)
(and (supervisor ?middle-manager ?person)
(supervisor ?x ?middle-manager)))
#;(rule (outranked-by ?staff-person ?boss)
(or (supervisor ?staff-person ?boss)
(and (supervisor ?staff-person ?middle-manager)
(outranked-by ?middle-manager ?boss))))
(rule (outranked-by ?staff-person ?boss)
(or (supervisor ?staff-person ?boss)
(and (outranked-by ?middle-manager ?boss)
(supervisor ?staff-person ?middle-manager))))
))
(~> microshaft-data-base-modified-outranked-by
(initialize-data-base))
;; endless waiting ...
;; (~> '(outranked-by (Bitdiddle Ben) ?who)
;; (run))
4_65
;; file: 4_65.rkt
;; 4_65 / 4_66
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Q. 왜 (Warbucks Oliver)가 4번 나오는가?
;;
;; supervisor관계도를 나타내면
;;
;; (Warbucks Oliver) -- 0
;; ├─ (Bitdiddle Ben) -- 1
;; │ ├─ (Hacker Alyssa P) -- 2 **
;; │ │ └─ (Reasoner Louis) -- 3
;; │ ├─ (Fect Cy D) -- 2 **
;; │ └─ (Tweakit Lem E) -- 2 **
;; ├─ (Scrooge Eben) -- 1
;; │ └─ (Cratchet Robert) -- 2 **
;; └─ (Aull DeWitt) -- 1
;;
;; wheel은 supervisor의 supervisor를 찾는거니,
;; (Warbucks Oliver) 기준으로깊이가 2이상인 애들을 찾으면 4명.
;;
;; (rule (wheel ?person)
;; (and (supervisor ?middle-manager ?person)
;; (supervisor ?x ?middle-manager)))
(~> microshaft-data-base
(initialize-data-base))
(~> '(wheel ?who)
(run)
(check-equal? '((wheel (Warbucks Oliver))
(wheel (Warbucks Oliver))
(wheel (Bitdiddle Ben))
(wheel (Warbucks Oliver))
(wheel (Warbucks Oliver)))))
4_66
;; file: 4_66.rkt
;; 4_65 / 4_66
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; Ben은 쿼리 시스템을 일반화 시키고 있음. 새로운 시스템은 다음과 같은 형태의 표현을 허용하도록 만들고 싶음.
;;
;; (accumulation-function {variable}
;; {query pattern})
;;
;; ex. 모든이들의 급의여 합.
;; (sum ?amount
;; (and (job ?x (computer programmer))
;; (salary ?x ?amount)))
;;
;; 하지만 연습문제 4.65에서 wheel결과를 보고 Ben은 좌절에 빠짐.
;;
;; Q. Ben이 깨닫은 것은?
;;
;; 기존 쿼리 시스템에서 중복이 나올 가능성이 있음. 이 중복으로 계산의 결과가 올바르지 못하게 될 경우가 있음.
;;
(~> microshaft-data-base
(initialize-data-base))
(~> '(and (wheel (Warbucks Oliver))
(salary ?x ?amount))
(run)
(check-equal? '((and (wheel (Warbucks Oliver)) (salary (Aull DeWitt) 25000))
(and (wheel (Warbucks Oliver)) (salary (Aull DeWitt) 25000))
(and (wheel (Warbucks Oliver)) (salary (Cratchet Robert) 18000))
(and (wheel (Warbucks Oliver)) (salary (Aull DeWitt) 25000))
(and (wheel (Warbucks Oliver)) (salary (Scrooge Eben) 75000))
(and (wheel (Warbucks Oliver)) (salary (Cratchet Robert) 18000))
(and (wheel (Warbucks Oliver)) (salary (Warbucks Oliver) 150000))
(and (wheel (Warbucks Oliver)) (salary (Aull DeWitt) 25000))
(and (wheel (Warbucks Oliver)) (salary (Reasoner Louis) 30000))
(and (wheel (Warbucks Oliver)) (salary (Scrooge Eben) 75000))
(and (wheel (Warbucks Oliver)) (salary (Tweakit Lem E) 25000))
(and (wheel (Warbucks Oliver)) (salary (Cratchet Robert) 18000))
(and (wheel (Warbucks Oliver)) (salary (Fect Cy D) 35000))
(and (wheel (Warbucks Oliver)) (salary (Warbucks Oliver) 150000))
(and (wheel (Warbucks Oliver)) (salary (Hacker Alyssa P) 40000))
(and (wheel (Warbucks Oliver)) (salary (Cratchet Robert) 18000))
(and (wheel (Warbucks Oliver)) (salary (Bitdiddle Ben) 60000))
(and (wheel (Warbucks Oliver)) (salary (Reasoner Louis) 30000))
(and (wheel (Warbucks Oliver)) (salary (Scrooge Eben) 75000))
(and (wheel (Warbucks Oliver)) (salary (Tweakit Lem E) 25000))
(and (wheel (Warbucks Oliver)) (salary (Scrooge Eben) 75000))
(and (wheel (Warbucks Oliver)) (salary (Fect Cy D) 35000))
(and (wheel (Warbucks Oliver)) (salary (Warbucks Oliver) 150000))
(and (wheel (Warbucks Oliver)) (salary (Hacker Alyssa P) 40000))
(and (wheel (Warbucks Oliver)) (salary (Warbucks Oliver) 150000))
(and (wheel (Warbucks Oliver)) (salary (Bitdiddle Ben) 60000))
(and (wheel (Warbucks Oliver)) (salary (Reasoner Louis) 30000))
(and (wheel (Warbucks Oliver)) (salary (Reasoner Louis) 30000))
(and (wheel (Warbucks Oliver)) (salary (Tweakit Lem E) 25000))
(and (wheel (Warbucks Oliver)) (salary (Tweakit Lem E) 25000))
(and (wheel (Warbucks Oliver)) (salary (Fect Cy D) 35000))
(and (wheel (Warbucks Oliver)) (salary (Fect Cy D) 35000))
(and (wheel (Warbucks Oliver)) (salary (Hacker Alyssa P) 40000))
(and (wheel (Warbucks Oliver)) (salary (Hacker Alyssa P) 40000))
(and (wheel (Warbucks Oliver)) (salary (Bitdiddle Ben) 60000))
(and (wheel (Warbucks Oliver)) (salary (Bitdiddle Ben) 60000)))))
;; Q. 이 상황을 해결하기 위해선?
;;
;; 중복된 결과를 유니크한 결과로 바꿀 메커니즘이 필요.
4_67
;; file: 4_67.rkt
;; 2_18 / 4_67 / 4_68
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; TODO Q. 쿼리 시스템에 루프 감지기를 설치하여 본문과 연습문제 4.64에서 설명된 간단한 루프를 피할 수 있는 방법을 고안하시오.
;; 일반적인 아이디어는 시스템이 현재 추론 체인의 이력을 유지하고, 이미 처리 중인 쿼리를 다시 처리하지 않도록 하는 것입니다.
;; 이 이력에 포함되는 정보(패턴과 프레임)의 종류와 검사 방법을 설명하시오.
;;
;; (4.4.4절에서 쿼리 시스템 구현의 세부 사항을 공부한 후, 루프 감지기를 포함하도록 시스템을 수정할 수 있습니다.)
(racket:require "4_64.rkt")
(~> microshaft-data-base-modified-outranked-by
(initialize-data-base))
(define (qeval query frame-stream)
(display query)
(newline)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-stream)
(simple-query query frame-stream))))
(override-qeval! qeval)
;; (~> '(outranked-by (Bitdiddle Ben) ?who)
;; (run))
;;
;; (outranked-by (Bitdiddle Ben) (? who))
;; (or (supervisor (? 1 staff-person) (? 1 boss)) (and (outranked-by (? 1 middle-manager) (? 1 boss)) (supervisor (? 1 staff-person) (? 1 middle-manager))))
;; (supervisor (? 1 staff-person) (? 1 boss))
;; (and (outranked-by (? 1 middle-manager) (? 1 boss)) (supervisor (? 1 staff-person) (? 1 middle-manager)))
;;
;; (outranked-by (? 1 middle-manager) (? 1 boss))
;; (or (supervisor (? 2 staff-person) (? 2 boss)) (and (outranked-by (? 2 middle-manager) (? 2 boss)) (supervisor (? 2 staff-person) (? 2 middle-manager))))
;; (supervisor (? 2 staff-person) (? 2 boss))
;; (supervisor (? 1 staff-person) (? 1 middle-manager))
;; (and (outranked-by (? 2 middle-manager) (? 2 boss)) (supervisor (? 2 staff-person) (? 2 middle-manager)))
;;
;; (outranked-by (? 2 middle-manager) (? 2 boss))
;; (or (supervisor (? 3 staff-person) (? 3 boss)) (and (outranked-by (? 3 middle-manager) (? 3 boss)) (supervisor (? 3 staff-person) (? 3 middle-manager))))
;; (supervisor (? 3 staff-person) (? 3 boss))
;; (supervisor (? 2 staff-person) (? 2 middle-manager))
;; (and (outranked-by (? 3 middle-manager) (? 3 boss)) (supervisor (? 3 staff-person) (? 3 middle-manager)))
;;
;; ...
;;
;; (outranked-by (? {N} middle-manager) (? {N} boss))
;; (or (supervisor (? {N+1} staff-person) (? {N+1} boss)) (and (outranked-by (? {N+1} middle-manager) (? {N+1} boss)) (supervisor (? {N+1} staff-person) (? {N+1} middle-manager))))
;; (supervisor (? {N+1} staff-person) (? {N+1} boss))
;; (supervisor (? {N} staff-person) (? {N} middle-manager))
;; (and (outranked-by (? {N+1} middle-manager) (? {N+1} boss)) (supervisor (? {N+1} staff-person) (? {N+1} middle-manager)))
4_68
;; file: 4_68.rkt
;; 2_18 / 4_67 / 4_68
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
;; Q. 연습문제 2.18의 reverse를 rule로 만들어 봐라. (힌트, append-to-form 활용)
;;
(define rules-append-to-form
'(
;; (append-to-form ?x ?y ?z) : ?x 랑 ?y를 합쳐서 ?z만들기.
;; (append-to-form (a b) (c d) ?z)
;;=> ((append-to-form (a b) (c d) (a b c d)))
(rule (append-to-form () ?y ?y))
(rule (append-to-form (?u . ?v) ?y (?u . ?z))
(append-to-form ?v ?y ?z))
))
(define rules-reverse
'(
;; (reverse ?x ?reversed) : ?x를 받아 뒤집어서 ?reversed.
;; (reverse (1 2 3) ?x)
;;=> ((reverse (1 2 3) (3 2 1)))
(rule (reverse () ()))
(rule (reverse (?first . ?rest) ?reversed)
(and (reverse ?rest ?rest-reversed)
(append-to-form ?rest-reversed (?first) ?reversed)))
))
(~> microshaft-data-base
(append rules-append-to-form)
(append rules-reverse)
(initialize-data-base))
(~> '(reverse () ?x)
(run)
(check-equal? '((reverse () ()))))
(~> '(reverse (1) ?x)
(run)
(check-equal? '((reverse (1) (1)))))
(~> '(reverse (1 2 3) ?x)
(run)
(check-equal? '((reverse (1 2 3) (3 2 1)))))
(~> '(reverse ?x (1 2 3))
(run)
(check-equal? '((reverse (1 2 3) (3 2 1)))))
;; 무한루프
;;
;; (~> '(reverse (1 2 3) ?x)
;; (run)
;; (check-equal? '((reverse (1 2 3) (3 2 1)))))
;; TODO Q. (reverse (1 2 3) ?x) 과 (reverse ?x (1 2 3)) 에 모두 답할 수 있는가?
;;
;; (reverse ?x (1 2 3))는 무한 루프.
4_69
;; file: 4_69.rkt
;; 2_17 / 4_62 / 4_63 / 4_69
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(#%require "../allcode/ch4-4.4.4.1-query.rkt")
;; 연습문제 4.63에서 만든 데이터베이스와 규칙을 시작으로, 손자 관계에 “great”를 추가하는 규칙을 고안하시오.
;; 이 규칙은 시스템이 Irad가 Adam의 2대 손자(great-grandson)임을 추론하거나, Jabal과 Jubal이 Adam의 6대 손자(great-great-great-great-great-grandson)임을 추론할 수 있도록 해야 합니다.
;;
;; 힌트: 예를 들어, Irad에 대한 사실을 ((great grandson) Adam Irad)로 표현하시오.
;; 리스트가 grandson이라는 단어로 끝나는지 판단하는 규칙을 작성하시오.
;; 이를 사용하여 (?rel이 grandson으로 끝나는 리스트일 때)
;; ((great . ?rel) ?x ?y) 관계를 도출하는 규칙을 표현하시오.
;;
;; ((great grandson) ?g ?ggs)나 (?relationship Adam Irad)와 같은 질의에서 규칙을 확인하시오.
;;
;; Grandson : 손자
;; Great-grandson : 2대 손자
;; Great-great-grandson : 3대 손자
;; Great-great-great-grandson : 4대 손자
;; Great-great-great-great-grandson : 5대 손자
;; Great-great-great-great-great-grandson : 6대 손자
(racket:require (racket:only-in "4_62.rkt"
rules-last-pair))
(racket:require (racket:only-in "4_63.rkt"
Genesis-4
rules-find-grandson
rules-find-son))
(define rules-relationship-of-grandson
'(
;; ((great {손자 관계}) {?대 조상} {?대 손자})
(rule ((grandson) ?x ?y)
(find-grandson ?x ?y))
(rule ((great . ?rel) ?x ?y)
(and (find-son ?x ?x-son)
(?rel ?x-son ?y)
(last-pair ?rel (grandson))))
))
(~> microshaft-data-base
(append Genesis-4)
(append rules-find-son)
(append rules-find-grandson)
(append rules-last-pair)
(append rules-relationship-of-grandson)
(initialize-data-base))
(~> '((great grandson) ?x Irad)
(run)
(check-equal? '(
((great grandson) Adam Irad)
)))
(~> '((great grandson) ?g ?ggs)
(run)
(check-equal? '(
((great grandson) Mehujael Jubal)
((great grandson) Irad Lamech)
((great grandson) Mehujael Jabal)
((great grandson) Enoch Methushael)
((great grandson) Cain Mehujael)
((great grandson) Adam Irad)
)))
(~> '(?relationship Adam Irad)
(run)
(check-equal? '(
((great grandson) Adam Irad)
)))
(~> '(?relationship Adam Jubal)
(run)
(check-equal? '(
((great great great great great grandson) Adam Jubal)
)))
(~> '((great great great great great grandson) Adam ?x)
(run)
(check-equal? '(
((great great great great great grandson) Adam Jubal)
((great great great great great grandson) Adam Jabal)
)))
4_70
;; file: 4_70.rkt
;; Q. 프로시저 add-assertion! 과 add-rule! 에서 let을 쓰는 목적이 무엇인가?
;;
;; cons-stream을 쓰는데 이게 두번째(cdr)위치에 있는 것을 dealy시킴.
;; delay되면서 자기 자신을 참조하게되는데 그걸 방지할 목적으로 let으로 미리 저장해둔걸 사용.
;;
;; Q. 다음과 같이 add-assertion!을 구현하면 무엇이 잘못인가?
;; - 3.5.2절에서 끝없는 스트림의 정의를 되새겨 보라
;; - (define ones (cons-stream 1 ones))
;;
;; (define (add-assertion! assertion)
;; (store-assertion-in-index assertion)
;; (set! THE-ASSERTIONS (cons-stream assertion THE-ASSERTIONS))
;; 'ok)
;; 예를들어 (add-assertion! '(a 1)) 라고 하면
;; THE-ASSERTIONS 는 다음과 같이 무한으로 나가게 된다.
;; (a 1) THE-ASSERTIONS
;; (a 1) THE-ASSERTIONS
;; (a 1) THE-ASSERTIONS
;; ...
4_71
;; file: 4_71.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(racket:require (racket:rename-in "../allcode/ch4-4.4.4.1-query.rkt"
(_simple-query simple-query-before)
(_disjoin disjoin-before)))
;; simple-query과 disjoin에서 delay시키느냐 안시키느냐의 차이.
;; simple-query
;; rule적용을 delay시키는데, 이상한 룰이 있으면 무한루프에 빠지게됨.
(~> '(
(married Minnie Mickey)
(rule (married ?x ?y)
(married ?y ?x))
)
(initialize-data-base))
(define query
'(married Mickey (? x))
)
(~> (simple-query query (singleton-stream '()))
(stream-car)
(check-equal? '(((? 1 y) . Minnie) ((? x) ? 1 y) ((? 1 x) . Mickey))))
(define (simple-query-after query-pattern frame-stream)
(stream-flatmap (lambda (frame)
;; before
;; (stream-append-delayed (find-assertions query-pattern frame)
;; (delay (apply-rules query-pattern frame)))
;;
;; after
(stream-append (find-assertions query-pattern frame)
(apply-rules query-pattern frame))
)
frame-stream))
(override-simple-query! simple-query-after)
;; endless loop
;;
;; (simple-query query (singleton-stream '()))
;; disjoin
;;
;; or 연산을 담당하는데, or의 두번째에 이상한걸 넣게되면 무한루프에 빠지게 됨.
(reset!)
(~> '(
(married Minnie Mickey)
(rule (married ?x ?y)
(married ?y ?x))
)
(initialize-data-base))
(define query2
'((married Mickey (? x)) (married (? x) 1))
)
(~> (disjoin query2 (singleton-stream '()))
(stream-car)
(check-equal? '(((? 1 y) . Minnie) ((? x) ? 1 y) ((? 1 x) . Mickey))))
(define (disjoin-after disjuncts frame-stream)
(if (empty-disjunction? disjuncts)
the-empty-stream
;; before
;; (interleave-delayed (qeval (first-disjunct disjuncts) frame-stream)
;; (delay (disjoin (rest-disjuncts disjuncts) frame-stream)))
(interleave (qeval (first-disjunct disjuncts) frame-stream)
(disjoin-after (rest-disjuncts disjuncts) frame-stream))
))
(override-disjoin! disjoin-after)
;; endless loop
;;
;; (disjoin query2 (singleton-stream '()))
4_72
;; file: 4_72.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; 왜 disjoin 와 stream-flatmap에서 스트림을 병합할때 append가 아닌 interleave를 사용하는가?
(racket:require "../allcode/ch4-4.4.4.1-query.rkt")
'(define (disjoin disjuncts frame-stream)
(if (empty-disjunction? disjuncts)
the-empty-stream
(interleave-delayed (qeval (first-disjunct disjuncts) frame-stream)
(delay (disjoin (rest-disjuncts disjuncts) frame-stream)))))
'(define (stream-flatmap proc s)
(flatten-stream (stream-map proc s)))
'(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed (stream-car stream)
(delay (flatten-stream (stream-cdr stream))))))
'(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream (stream-car s1)
(interleave-delayed (force delayed-s2)
(delay (stream-cdr s1))))))
'(define (stream-append-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream (stream-car s1)
(stream-append-delayed (stream-cdr s1)
delayed-s2))))
(define ones (cons-stream 1 ones))
(define twos (cons-stream 2 twos))
;; append시 첫번째 스트림이 무한일때, 두번째 스트림에 접근이 불가.
(~> (stream-append-delayed ones (delay twos))
(stream-cdr)
(stream-cdr)
(stream-cdr)
(stream-car)
(check-equal? 1))
;; interleave면 첫번째 스트림이 무한이라도 번갈아 기회가 생김.
(~> (interleave-delayed ones (delay twos))
(stream-cdr)
(stream-cdr)
(stream-cdr)
(stream-car)
(check-equal? 2))
4_73
;; file: 4_73.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; flatten-stream 는 왜 delay 사용하나?
;; 계산을 미뤄 무한 스트림에 대한 무한루프 방지.
(racket:require (racket:rename-in "../allcode/ch4-4.4.4.1-query.rkt"
(_flatten-stream flatten-stream-before)))
(define ones (cons-stream 1 ones))
(define twos (cons-stream 2 twos))
#;(flatten-stream (list->stream (list (list->stream '(1 2 3)) ones)))
(~> (flatten-stream (cons-stream (list->stream '(1 2 3)) ones))
(stream-car)
(check-equal? 1))
(define (flatten-stream-after stream)
;; before
;; (if (stream-null? stream)
;; the-empty-stream
;; (interleave-delayed (stream-car stream)
;; (delay (flatten-stream (stream-cdr stream)))))
;; after
(if (stream-null? stream)
the-empty-stream
(interleave (stream-car stream)
(flatten-stream-after (stream-cdr stream)))))
(override-flatten-stream! flatten-stream-after)
;; 무한 루프
;; (~> (flatten-stream (cons-stream (list->stream '(1 2 3)) ones))
;; (stream-car)
;; (check-equal? 1))
4_74
;; file: 4_74.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;;
;; simple-flatten을 구현하라
(racket:require "../allcode/ch4-4.4.4.1-query.rkt")
(define (simple-stream-flatmap proc s)
(simple-flatten (stream-map proc s)))
(define (simple-flatten stream)
(stream-map stream-car
(stream-filter (lambda (s)
(not (stream-null? s)))
stream)))
'(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed (stream-car stream)
(delay (flatten-stream (stream-cdr stream))))))
(define test-stream
(list->stream (list (list->stream '(1))
(list->stream '(2))
(list->stream '())
(list->stream '(3)))))
(~> (flatten-stream test-stream)
(stream->list )
(check-equal?'(1 2 3)))
(~> (simple-flatten test-stream)
(stream->list )
(check-equal?'(1 2 3)))
(override-flatten-stream! flatten-stream)
(override-stream-flatmap! simple-stream-flatmap)
;; 쿼리 시스템의 행동이 달라지는가?
;; 달라지지 않는다.
;; frame 스트림에 프로시저를 적용하면 언제나 빈 스트림이나 원소 한 개짜리 스트림이 나오므로, 스트림을 번갈아 끼워넣을 필요가 없다.
4_75
;; file: 4_75.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
(racket:provide
uniquely-asserted)
;; 쿼리 시스템에 unique 라는 special form을 추가하라.
(racket:require "../allcode/ch4-4.4.4.1-query.rkt")
(~> microshaft-data-base
(initialize-data-base))
(define (uniquely-asserted content frame-stream)
(let* ((q (first content)))
;; 남은 스트림을 다시 커다란 스트림 하나로 묶어서 unique 쿼리의 결과를 내놓게 된다.
(stream-flatmap (lambda (frame)
;; qeval을 사용하여, 스트림 속의 각 일람표에 대해 정해진 쿼리를 만족하도록 확장된 모든 일람표의 스트림을 찾아낸다
(let ((qstream (qeval q (singleton-stream frame))))
;; 이로부터 정확히 원소 하나만 들지 않은 스트림은 걸러내야 한다.
(cond ((stream-null? qstream) the-empty-stream)
((stream-null? (stream-cdr qstream)) qstream)
(else the-empty-stream))))
frame-stream)))
(put 'unique 'qeval uniquely-asserted)
(~> '(unique (job ?x (computer wizard)))
(run)
(check-equal? '((unique (job (Bitdiddle Ben) (computer wizard))))))
(~> '(unique (job (Bitdiddle Ben) (computer wizard)))
(run)
(check-equal? '((unique (job (Bitdiddle Ben) (computer wizard))))))
(~> '(unique (job ?x (computer programmer)))
(run)
(check-equal? '()))
(~> '(and (job ?x ?j)
(unique (job ?anyone ?j)))
(run)
(check-equal? '(
(and (job (Aull DeWitt) (administration secretary))
(unique (job (Aull DeWitt) (administration secretary))))
(and (job (Cratchet Robert) (accounting scrivener))
(unique (job (Cratchet Robert) (accounting scrivener))))
(and (job (Scrooge Eben) (accounting chief accountant))
(unique (job (Scrooge Eben) (accounting chief accountant))))
(and (job (Warbucks Oliver) (administration big wheel))
(unique (job (Warbucks Oliver) (administration big wheel))))
(and (job (Reasoner Louis) (computer programmer trainee))
(unique (job (Reasoner Louis) (computer programmer trainee))))
(and (job (Tweakit Lem E) (computer technician))
(unique (job (Tweakit Lem E) (computer technician))))
(and (job (Bitdiddle Ben) (computer wizard))
(unique (job (Bitdiddle Ben) (computer wizard)))))
))
4_76
;; file: 4_76.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)
(#%require profile)
(#%require (prefix r5rs: r5rs))
(#%require (prefix racket: racket))
;; TODO and의 두번째 쿼리를처리하는 과정에서 첫 번째 쿼리가 만들어낸 모든 일람표에 대해 데이터베이스를 훌어보아야 하기 때문에 효율이 떨어진다.
;; 이와달리, and의 두절을 따로 처리한 다음에, 출력 일람표들의 모든쌍이 서로 어긋나지 않는지 살펴보는 방법도 있다.
;; 그리하려면, 두 일람표를 인자로 받아, 두 일람표 속의 정의가 서로 맞아떨어진다면 두 정의를 한데 합쳐 하나의 일람표를 만들어내는 프로시저를 짜야한다.
;; 이 연산은 unification과 유사하다.
(racket:require "../allcode/ch4-4.4.4.1-query.rkt")
(~> microshaft-data-base
(initialize-data-base))
(define (conjoin-origin conjuncts frame-stream)
(if (empty-conjunction? conjuncts)
frame-stream
(conjoin-origin (rest-conjuncts conjuncts)
(qeval (first-conjunct conjuncts)
frame-stream))))
(put 'and 'qeval conjoin-origin)
(define (conjoin-after conjuncts frame-stream)
(if (empty-conjunction? conjuncts)
frame-stream
(conjoin-after (rest-conjuncts conjuncts)
(qeval (first-conjunct conjuncts)
frame-stream))))
(put 'and 'qeval conjoin-after)
4_77
;; file: 4_77.rkt
#|
TODO 연습문제 4.77: 4.4.3절에서 우리는 not과 lisp-value가 변수가 바인딩되지 않은 프레임에 적용될 경우 쿼리 언어가 "잘못된" 답변을 줄 수 있다는 점을 살펴보았다.
이 단점을 해결할 방법을 고안하시오.
한 가지 아이디어는 필터링을 "지연된" 방식으로 수행하는 것이다.
즉, 프레임에 필터링을 약속하는 "프로미스"를 추가하여, 해당 연산이 가능해질 만큼 충분한 변수가 바인딩되었을 때만 이 약속을 이행하는 것이다.
모든 다른 연산이 수행될 때까지 필터링을 기다릴 수 있지만,
효율성을 위해 가능한 한 빨리 필터링을 수행하여 생성되는 중간 프레임의 수를 줄이고자 한다.
|#
4_78
;; file: 4_78.rkt
#|
TODO 연습문제 4.78
쿼리 언어를 스트림 프로세스가 아닌, 4.3절의 평가기를 사용하여 구현되는 비결정적 프로그램으로 재설계하시오.
이 접근 방식에서는 각 쿼리가 모든 답변의 스트림 대신 단일 답변을 생성하며, 사용자는 try-again을 입력하여 추가 답변을 볼 수 있습니다.
이 섹션에서 구축한 많은 메커니즘이 비결정적 검색과 백트래킹에 의해 포함된다는 것을 알게 될 것입니다.
그러나 새로 구현한 쿼리 언어가 여기서 구현한 쿼리 언어와 행동에서 미묘한 차이가 있을 가능성도 있습니다.
이러한 차이를 보여주는 예를 찾을 수 있습니까?
|#
4_79
;; file: 4_79.rkt
#|
TODO 연습문제 4.79
4.1절에서 Lisp 평가기를 구현할 때, 프로시저의 매개변수 간 이름 충돌을 피하기 위해 로컬 환경을 사용하는 방법을 살펴보았다.
예를 들어, 다음을 평가할 때:
(define (square x)
(* x x))
(define (sum-of-squares x y)
(+ (square x) (square y)))
(sum-of-squares 3 4)
square의 x와 sum-of-squares의 x 사이에 혼동이 없는데, 이는 각 프로시저의 본문이 로컬 변수에 대한 바인딩을 포함하도록 특별히 구성된 환경에서 평가되기 때문이다.
쿼리 시스템에서는 규칙을 적용할 때 이름 충돌을 피하기 위해 다른 전략을 사용했다.
규칙을 적용할 때마다 변수를 고유한 새 이름으로 바꾼다.
Lisp 평가기에 유사한 전략을 적용한다면, 로컬 환경을 제거하고 프로시저를 적용할 때마다 프로시저 본문의 변수 이름을 바꾸는 방식이 될 것이다.
1. 쿼리 언어에 대해 이름 변경 대신 환경을 사용하는 규칙 적용 방법을 구현하시오.
2. 환경 구조를 활용하여 쿼리 언어에서 블록 구조 프로시저와 유사한 규칙의 아날로그를 만들어 대규모 시스템을 다룰 수 있는 구조를 만들 수 있는지 확인하시오.
3. 이를 “만약 내가 $ P $가 참이라고 가정한다면, $ A $와 $ B $를 추론할 수 있을 것이다”와 같은 문맥에서의 추론 문제를 해결하는 방법과 연관 지을 수 있습니까?
(이 문제는 개방형입니다. 좋은 답변은 아마도 박사 학위 수준의 가치를 가질 것입니다.)
|#