Keyboard shortcuts

Press ← or → to navigate between chapters

Press S or / to search in the book

Press ? to show this help

Press Esc to hide this help

SICP(Structure and Interpretation of Computer Programs)

  • Structures and Interpretation of Computer Program
    • 컴퓨터 프로그램의 구조와 해석은 MIT 대학 교수인 Harold Abelson과 Gerald Jay Sussman이 Julie Sussman과 함께 쓴 컴퓨터 과학 교과서입니다. 해커 문화에서는 "마법사 책"으로 알려져 있습니다.
  • wikipedia

간단 느낌

  • 1장: 할만한데 그 놈의 뉴턴
  • 2장: 알 수 있는걸 말하는거 같은데 그 놈의 연습문제
  • 3장: 연습문제 연습문제 연습문제
  • 4장: 이발, 이발, 이발, 이발 아이고 쿼리
  • 5장: 이젠 어셈블까지? 그리고 마지막에 가서는 연습문제로 알려줄거 다 알려줬으니 알아서 C로 해보라고.

요구조건

  • 엄청난 시간.
    • 연습문제는 깊이있는 이해를 도와주지만, 손을 대는 순간 타임머신이므로, 탐독할 시간이 적으신 분은 욕심을 내려놓으셔야 합니다.
      • 한시간씩만 잡아도 356시간 > 잠안자고 15일
        • 46(1장) + 97(2장) + 82(3장) + 79(4장) + 52(5장) = 356
      • 증명해라 / 구현해라
  • 엄청난 양/깊이
    • 저자가 열심히 설명했지만, 다루는 양과 깊이 자체가 두께에 비해 흔히 접할 수 있는 컴퓨터 서적보다는 많고 깊음.
    • 정보 과부하가 걸리기 시작하면서 연습문제를 맞이하면, 그리고 일상생활에 치여 흐름이 끊기면 이어나가기 힘듬.
  • 영어.
    • 번역서가 있기는 하나, 번역하신 분께는 죄송하나, 원문의 내용을 오해하게 만들거나, 어색하거나 이해하기 어려운 번역이 있어 뭔가 이상하면 원서를 봐야합니다.
    • Ai(chatgpt/deepl)나, 번역서비스(google/naver)를 이용 권장. 어쨋든 번역서 만으로 이해하는데 에로사항이 많음.

책

비디오

솔루션

기타

들어가며

연습문제가 엄청 많다. 문제 해결 (Problem solving) 트래이닝 북이라고 생각하면 편하다.

  • 언어의 문제
    • 번역서의 문제
    • 결국 영어를 알아야한다.
  • car/cdr/cadr문제
    • first/rest/second ...로 치환하는게 맞다고 생각한다
  • 다른 언어를 쓰다 이 책을 보면 느끼는 위화감
    • function / procedure / application
      • 책에서 function / procedure / application 이라 나오면 그냥 함수라 생각하면 된다.
  • 책에 연습문제는 해답이 없다.
    • 극혐하는 답없는 교재이다.
    • 어차피 solution은 나오기 마련이다.
    • 답이 있다 하더라도 프로그래밍은 결국 사람 취향에 따라 다르게 나올 수 있다.
  • 연습문제에서 이전에 나왔던 것을 물어보는 경우가 있는데, 책 특성상 링크가 안된다.
    • 가뜩이나 저자가 생소한 개념 / 단어들을 들고오는데 기억이랑 단어랑 매칭이 잘 안되는 경우가 많음.
    • 그래서 어디였지 1장? 3장이라고 하는데 그게 몇페이지지? 하면서 찾아야함.
    • a연습문제를 건너 뛰었는데 a연습문제랑 연관된 b연습문제가 나타남.
  • 리펙토링
    • 4장부터 함수 이름이나 인자 순서같은걸 내가 이해하는 방식으로 코드를 변경한다면
      • ide도 별로고 새로 추가되는 코드를 따라갈 수 가 없다.

문제해결능력 리펙토링 무엇을 모르는지

끝까지 보는것이 최우선 알고리즘 문제는 두번째

단순 설명이 아니라 무엇이 가능한지 가능성을 보여줌. 1장

  • 일급함수(First-class Function)
  • 고차 함수(Higher-order function)
  • Tail Recursion
  • 평가전략
    • Call-by-Value(Applicative-Order Evaluation)
    • Call-by-Name(Normal-Order Evaluation)
    • Call-by-Need(Lazy Evaluation) 2장 3장
  • Lazy Sequence(책에선 Stream) 4장
  • Lisp 인터프리터 구현 3장
  • Lisp 컴파일러 구현

↦ map to

DrRacket

The Racket Programming Environment

racket 설치 (raco 도 같이 설치된다)

Windows

linux (ubuntu)

sudo apt-get install racket

macOs

brew install --cask racket

왜 DrRacket

PLr5rs함수 재정의GUI IDE
DrRacketRacketOXDrRacket
MITSchemeSchemeOOEdwin (GNU Emacs clone)
GNU GuileSchemeOOX
CHICKEN SchemeSchemeOOX
SBCLCommon LispXOSlt Plugin for JetBrains IDEs
LispWorksCommon LispXOLispWorks
  • Common Lisp로 하는건 일단 배제하고,
  • Emacs 사용이 자유로운 사람이라면, 함수를 계속 덮어쓰므로 Scheme구현체 중 하나를 선택하면 좋다.
  • 단점! 물론 불러온 함수 재정의가 안되는 치명적인 단점과 필요에 따라 추가적인 racket문법을 익혀야 한다는 단점이 있다.
  • 장점! 설치도 간편. IDE를 지원하는게 DrRacket이 유일. 디버거도 그럭저럭 쓸만하고, racket 패키지들도 유용하고 문서화가 잘 되어 있다.
  • 단점도 엄청 치명적이긴 한데 IDE지원이라는 장점이 진입장벽을 낮춤으로써 단점보다 조금 더 낫다고 생각했다.

흔히 쓰게될 단축키

단축키
파일 실행Ctrl + R / F5
코드 포맷Ctrl + I
코드 <=> Repl 전환Ctrl + F6shift-focus
λ 문자 삽입Ctrl + \insert λ#lang racket에선 lambda대신 λ도 가능
자동완성Ctrl + /Complete Word
파일 버퍼 되돌리기Ctrl + Shift + ERevert외부 에디터에서 파일을 수정해도 자동으로 버퍼를 갱신하지 않으니 외부에서 파일 수정시 버퍼 초기화 용도
인덴트 가이드Ctrl + Shift + IShow Indent Guides
  • 정의로 가기는 단축키가 없다
    • 함수 이름 우클릭 > Jump to definition of {blabla}? 클릭

Tip

SICP가 설치가 안되어 있다면

코드 색깔 바꾸기

코드 포맷

  • 메뉴> Racket > Reindent All
  • 혹은 단축키 Ctrl + I
  • 혹은 전체 선택(Ctrl + A) 후 Tab

백업파일(.bak) 생성 안되게

  • 메뉴> Edit > Preferences...
    • General 탭
      • Make backups for unsaved files 체크 해제
      • Create first-change files 체크 해제

Emacs 키 바인딩이 그립다면

쓰레딩 매크로( ~> / ~>> )를 사용하고 싶다면

  • threading
    • clojure -> / ->> 와는 다르게 ~> / ~>> 이다
#lang sicp
(#%require threading)

(~> 2 (/ 5))
;;=> 2/5

(~>> 2 (/ 5))
;;=> 5/2

유닛테스트를 하고 싶다면?

#lang sicp

(#%require rackunit)

(check-equal? (+ 1 2) 3)
;; (check-equal? <expected> <actual> <message>)

DrRacket 디버거 사용이 힘들어 그냥 쉽게 출력해서 보고 싶다면

#lang debug sicp
(+ 1 2 #R(* 3 4))
;;>> {* 3 4} = 12
;;=> 15

함수 수행을 따라가 보고 싶다면

#lang sicp

(define (f x)
  (if (zero? x) 0
      (add1 (f (sub1 x)))))

(#%require (prefix trace: racket/trace))
(trace:trace f)

todo errortrace

"C:\Program Files\Racket\Racket.exe" -l errortrace -t 4_08.rkt

  • https://docs.racket-lang.org/errortrace/using-errortrace.html

todo pretty print

  • https://docs.racket-lang.org/reference/pretty-print.html

TODO sandbox

  • https://docs.racket-lang.org/reference/Sandboxed_Evaluation.html

기타 문법


;; 블록 코맨트( #; )
#;(error "wtf")


;; TODO 설명 필요

(#%require (prefix racket: racket))
(racket:provide (racket:all-defined-out))

VsCode 설정

DrRacket을 쓰면 상관없지만, VsCode로 하고싶다면

racket-rangserver 설치

raco pkg install racket-langserver
Would you like to install these dependencies? [Y/n/a/c/?]

raco pkg update racket-langserver

# sicp 설치(필요시)
raco pkg install sicp

Scheme

1장. 함수로 추상화 쌓기

  • Building Abstractions with Procedures

    • 1장은, 추상화를 쌓아 올리기 위한 함수 기법을 설명한다.

  • 프로그래밍에서 추상화(abstraction)는 복잡한 것에서 불필요한 세부를 숨기고, 꼭 필요한 핵심만 간추려 내는 것을 말한다.

  • 책에서는 함수(function)를 수학적인 개념이라하고, 프로씨저(procedure)를 계산 절차라 구분지었는데,

    • 함수를 짠다는 말이 더 익숙하기에 그냥 이 둘을 합쳐서 함수로 퉁치자.

  • 복잡한 것을 단순한 것에서부터 쌓아 올려 일반화(여러 상황에서 쓸 수 있도록)한다.

    • 세부 구현을 숨기면, 복잡한 로직도 하나의 도구처럼 취급 가능

  • 함수를 이름 붙여 재사용하고, 세부 구현을 감춘다.

  • 동작 자체를 데이터처럼 다루는 능력

    • 함수를 인자로 받아 사용하거나 함수를 반환하는 함수.

기본

문법

;; ================
;; 변수 정의
(define SIZE 2)

;; ================
;; 영역 변수
(let ((x 1)
      (y 2))
  (+ x y))

(let* ((x 1)
       (y (+ x 2)))
  (+ x y))

;; ================
;; 함수 정의
(define (Square x)
  (* x x))

;; ================
;; 익명함수
((lambda (x) (+ x 4)) 5)
   
;; ================
;; 조건문 cond / if
(define (Abs-1 x)
  (cond ((= x 0) 0)
        ((> x 0) x)
        ((< x 0) (- x))))

(define (Abs-2 x)
  (cond ((< x 0) (- x))
        (else x)))

(define (Abs-3 x)
  (if (< x 0)
      (- x)
      x))

;; =============
;; 참(true , #t) / 거짓 (false , #f)
true
;;=> #t
#t
;;=> #t
false
;;=> #f
#f
;;=> #f

;; ================
;; 시퀀스의 각 요소에 함수를 적용.
(map (lambda (x) (* x x)) '(1 2 3 4))
;;=> (1 4 9 16)

기타 내장 함수

(display "Hello World")       ; 출력
;;>> Hello World

(newline)                     ; 빈 라인 출력
;;>> 
;;=> 

(error "this is error!" 1 2 3) ; 에러 출력 및 중단
;;=> this is error! 1 2 3

(inc 1)                        ; 1 증가
;;=> 2

(dec 1)                        ; 1 감소
;;=> 0

Function / Procedure / Process

  • 책에서는 함수와 프로시져를 구분해왔으나, 여기 개념설명 이후, 그냥 함수( function + procedure )로 퉁 치겠다.

함수(Function) = 수학적 개념

Factorial(N) = N!

프로시저(Procedure) = 프로그래머가 작성한 계산 절차(알고리즘)

(define (Factorial n)
  (if (= n 1)
      1
      (* n (Factorial (dec n)))))

프로세스(Process) = 프로시저를 실행할 때, 전개되는 계산의 단계적 진행상황

(Factorial 3)
→ 3 * (Factorial 2)
→ 3 * (2 * (Factorial 1))
→ 3 * (2 * (1 * (Factorial 0)))
→ 3 * (2 * (1 * 1))
→ 6

일반 재귀 (non-tail recursion)와 꼬리 재귀 (tail recursion)

  • procedure와 process의 차이를 보여주며, procedure가 만들어내는 process를 상상해 낼 수 있는 능력을 강조.
    • procedure
      • 함수 정의, 계산을 수행하기 위한 명령어 집합 혹은 알고리즘의 규칙
    • process
      • 메모리, 시간, 호출 스택 등과 관련된 실행의 구체적인 양상

일반 재귀 (non-tail recursion) linear recursive process

  • 내부의 곱셈을 계산하기 위해 함수의 Call 스택이 쌓인다.
    • 단계가 늘어나면 스택이 넘치게 된다( Stack overflow )
(define (Factorial-recur n)
  (if (= n 1)
      1
      (* n (Factorial-recur (dec n)))))

;; (Factorial-recur 3)
;; → 3 * (Factorial-recur 2)
;; → 3 * (2 * (Factorial-recur 1))
;; → 3 * (2 * (1 * (Factorial-recur 0)))
;; → 3 * (2 * (1 * 1))
;; → 6

꼬리 재귀 (tail recursion) linear iterative process

(define (Factorial-iter n)
  (if (< n 0)
      (error "n must be greater than or equal to 0. n =" n ))
  (define (iter acc x)
    (if (= x 0)
        acc
        (iter (* acc x) (dec x))))
  (iter 1 n))

;; (Factorial-iter 3)
;; → (iter 1 3)
;; → (iter (* 1 3) 2)
;; → (iter (* 3 2) 1)
;; → (iter (* 6 1) 0)
;; → 6

고차 함수 (higher-order function)

  • 함수를 데이터처럼 사용하는 함수
    • ex)
      • C 에서의 함수포인터
      • C# 에서의 delegate 혹은 Func/Action/Predicate타입
(define (compose f g)
  (lambda (x)
    (f (g x))))

(define (square x)
  (* x x))

((compose square inc) 6)
;=> (square (inc 6))
;=> (square 7)
;=> 49

평가전략(evaluation strategy)

  • Applicative-Order Evaluation
  • 다른 이름: Call-by-Value, Eager Evaluation
  • 인자를 먼저 평가하고 그 결과 값을 프로시저에 대입
  • Normal-Order Evaluation
  • 다른 이름: Call-by-Name
  • 인자를 평가하지 않고 그대로 본문에 대입 (문자 그대로 펼침)
  • Lazy Evaluation
  • 다른 이름: Call-by-Need
  • Normal-Order와 비슷하지만 한 번 계산한 결과를 저장해서 다시 계산하는것을 방지(메모이제이션)

뉴턴-랩슨 방법으로 제곱근 찾기

  • 뉴턴-랩슨 방법( Newton-Raphson method )
    • https://en.wikipedia.org/wiki/Newton%27s_method
    • 미분가능한 함수 f(a, b) → R에 대해 x에 대한 방정식 f(x)=0의 근의 근삿값을 구하는 알고리즘.
    • 뉴턴: 1669년 무렵, 비선형 방정식을 푸는 반복법을 고안. 주로 기하학적 직관과 미분 개념을 활용.
    • 랩슨: 1690년에 뉴턴 방법을 기하학 설명 없이 순수 대수 형태로 단순화해서 발표. 이 버전이 계산에 더 쓰기 좋아짐.
  • 뉴턴-랩슨 공식

$$ x_{n+1} = x_n - \frac{f(x_n)}{f'(x_n)} $$

제곱근 구하기

$$ y {>=} 0; 이고; y^2=x; 일때; \sqrt{x}는; y다.$$

$$ y \ge 0, \quad y^2 = S$$

  • 함수 정의 $$ f(x) = x^2 - S $$

  • 미분 $$ f'(x) = 2x $$

  • 공식에 대입 $$ x_{n+1} = x_n - \frac{x_n^2 - S}{2x_n} $$

$$ x_{n+1} = \frac{2x_n^2 - x_n^2 + S}{2x_n} $$

$$ x_{n+1} = \frac{x_n^2 + S}{2x_n} $$

  • 최종 식 $$ x_{n+1} = \frac{1}{2} \left( x_n + \frac{S}{x_n} \right) $$
;; 1.1.7 연습: 뉴튼 법으로 제곱근 찾기
;; 연습문제: 1_06, 1_07

(define (square x)
  (* x x))

(define (sqrt-iter guess x)
  (if (good-enough? guess x)
      guess
      (sqrt-iter (improve guess x) x)))

(define (improve guess x)
  (average guess (/ x guess)))

(define (average x y)
  (~> (+ x y) 
      (/ 2)))

(define (good-enough? guess x)
  (~> (square guess)
      (- x)
      (abs)
      (< 0.001)))

(define (sqrt x)
  (sqrt-iter 1.0 x))

(sqrt 9)
;;=> 3.00009155413138

TODO

ex 1.5 Applicative-Order Evaluation / lazy

1.17 뉴튼법 제곱근 ex 1.6 뉴튼 cont if 스페셜폼 ex 1.7 ** 뉴튼 cont good-enough 최적화 ex 1.8 뉴튼 cont 세제곱근(cube root) - ** 식이 나와있는데 원레 3제곱에서 유도하는법 1.3.4 - 뉴튼법 cont

1.2.1 재귀

  • non-tail recursion / tail recursion
  • Primitive Recursive Function / or not

ex 1.9 일반 재귀 (non-tail recursion)와 꼬리 재귀 (tail recursion) ex 1.10 에커만 함수 Primitive Recursive Function가 아닌 리커시브함수 ex 1.11 ** 꼬리 재귀 (tail recursion) 연습 심화 ex 1.12 파스칼 삼각형 recursion ex 1.13 *** 증명 ;; φ = (1+√5)/2 // Fib(n) = (φ^n)/√5 피보나치 수열. 특성방정식. 황금비. Binet 공식. 귀납법(induction)

1.2.4 거듭제곱 fast-expt ex 1.19 ** fast-fib-iter

1.2.5 최대공약수 GDC 유클리드

소수찾기 페르마 검사 연습문제 피보나치 하노이의 탑

2장. 데이터로 추상화 쌓기

  • Building Abstractions with Data

    • 2장은, 1장에서의 함수 뿐만 아니라 데이터도 추상화가 필요함을 설명한다.

  • 데이터 은닉 + 인터페이스 노출

    • sicp: 클로저와 인터페이스 함수로 캡슐화 구현
    • OOP: 클래스와 접근 제한자로 캡슐화 구현

  • 데이터 저장 방식이 달라도 영향이 없음.

기본

문법

;; ================
;; Cons Cell
(cons 1 2)
;;=> (1 . 2)

(car '(1 . 2))          ; cons cell의 첫번째
;;=> 1

(cdr '(1 . 2))          ; cons cell의 두번째
;;=> 2

(pair? '(1 . 2))       ; cons cell로 구성되어 있는가?
;;=> #t


;; ================
;; 리스트
(list 1 2 3)            ; '(1 . (2 . (3 . ())))
;;=> (1 2 3)

(car '(1 2 3))
;;=> 1

(cdr '(1 2 3))
;;=> (2 3)

(cadr '(1 2 3))        ; cdr 이후 car
;;=> 2

(pair? '(1 2 3))       ; list 역시 cons cell.
;;=> #t

(length '(1 2))        ; 길이
;;=> 2

(append '(1 2) '(3 4)) ; 덧붙이기
;;=> (1 2 3 4)

(memq 'c '(a b c d))   ; 포함하는 맴버인지 확인
;;=> (c d)
(memq 'c '(a b (c) d))
;;=> #f


;; ================
;; 널
(null? nil)            ; nil은 null이다.
;;=> #t
(null? '())            ; '() 빈것도 null이다.
;;=> #t


;; ================
;; quote 평가 지연
(quote '(1 2 3))       ; 입력받은 표현식을 평가하지 않고 반환.
;;=> '(1 2 3)


;; ================
;; 음수? / 0? / 양수?
(negative? -1)         ; 음수?
;;=> #t

(zero? 0)              ; 0?
;;=> #t

(positive? 1)          ; 양수?
;;=> #t


;; ================
;; 동일한지 체크
(eq? nil '())          ; 같은 객체인가?
;;=> #t
(eq? '(1 2) '(1 2))
;;=> #f

(equal? '(1 2) '(1 2)) ; 구조가 같은가?
;;=> #t

;; ================
;; association list(연관 리스트, alist)
(define a-alist '((apple . 100) (banana . 200))) ; '((key-a . value-a) (key-b . value-b) ... )
(assoc 'apple a-list)
;;=>(apple . 100)                                ; (key-a . value-a)

Data Abstraction(데이터 추상화)

  • 데이터를 어떻게 사용할지 만을 드러내는 기법.

    • 어떻게 표현할지는 드러나지 않음.

  • Constructor : 생성자

    • 데이터 객체를 만드는 함수.
    • ex) vector2

  • Selector : 흔히 말하는 getter

    • 만들어진 데이터 객체에서 필드를 꺼내는 함수.
    • ex) vector2-x, vector2-y

예제

  • vector2 / vector2-x / vector2-y
    • 데이터를 사용하는 방식은 유지한체
    • 데이터를 표현하는 방식은 바뀔 수 있다.
;; v1 - cons cell을 이용한 방식

(define (vector2 x y)
  (cons x y))
(define (vector2-x p)
  (cons-item1 p))
(define (vector2-y p)
  (cons-item2 p))
  
(vector2 1 2)
;;=> (1 . 2)
(vector2-x (vector2 1 2))
;;=> 1
(vector2-y (vector2 1 2))
;;=> 2

;; v2 - 리스트를 이용한 방식

(define (vector2 x y)
  (list x y))
(define (vector2-x p)
  (first p))
(define (vector2-y p)
  (second p))

(vector2 1 2)
;;=> (1 2)
(vector2-x (vector2 1 2))
;;=> 1
(vector2-y (vector2 1 2))
;;=> 2

(cons (list 1 2) (list 3 4))
;;
;; (
;;   (1 . (2 . ())) . (3 . (4 . ()))
;; )
;; 
;; +---+---+   +---+---+    +---+---+
;; | ● | ●---> | 3 | ●--->  | 4 | ()|
;; +-|-+---+   +---+---+    +---+---+
;;   |             
;;   v             
;; +---+---+    +---+---+
;; | 1 | ●--->  | 2 | ()|
;; +---+---+    +---+---+

TODO

복소수

연습문제 2.42 에잇퀸 퍼즐

2.2.4 연습 : 그림 언어 https://docs.racket-lang.org/sicp-manual/SICP_Picture_Language.html

#lang sicp
(#%require sicp-pict)
(paint einstein)

2.3.4 연습 : 허프만 인코딩 나무

2.4 요약된 데이터의 표현 방식이 여러 가지일 때 복소수를 직각좌표로도 극좌표로도 구현 2.4.1 복소수 표현 2.4.2 타입을 표시한 데이터 2.4.3 데이터 중심 프로그래밍과 덧붙임 성질

2.5 일반화된 연산 시스템 2.5.1 일반화된 산술 연산 2.5.2 타입이 다른 데이터를 엮어 쓰는 방법 2.5.3 연습 : 기호 식 대수

분수

3장. 모듈, 객체, 상태

  • Modularity, Objects, and State

    • 3장은, 상태를 도입하면 프로그램이 더 많은 것을 표현할 수 있지만, 그만큼 이해와 예측이 어려워지는 것을 설명.

  • 변하는 데이터와 시간의 흐름을 다룸.

    • 상태가 있는 시스템에서 시간과 동시성 문제는 필연적으로 등장.
    • 상태를 안전하게 다루는 데에 있어 모듈성과 캡슐화는 필수.
    • 지연 평가를 활용하면 무한 리스트나 신호 처리처럼 강력한 모델을 만들 수 있음.

기본

문법

;; ================
;; 셋팅

(set! a 10)
;;!> set!: assignment disallowed;
;;!> cannot set variable before its definition
;;!>  variable: a

(define a 10)
(set! a 20)
a
;;=> 20


(define a-cons (cons 1 2))
a-cons
;;=> (1 . 2)
(set-car! a-cons 10)
(set-cdr! a-cons 20)
a-cons
;;=> (10 . 20)


;; ================
;; begin 블록
(begin                 ; 블록 구문. 맨 마지막 표현식이 반환값.
  (display "Hello, ")
  (display "world!")
  (newline)
  42)
;;>> Hello, world!
;;=> 42



cons-stream - (cons a (delay b))
delay - (delay exp)는 구문적 설탕입니다 .(lambda () exp)
force

Closure

  • 함수가 정의될 때, 해당 함수가 속한 어휘적 환경(lexical environment) 에 대한 접근 권한을 유지하는 함수.
(define (new-counter initial-value)
  (let ((curr (dec initial-value)))                        ; local state variable
    (lambda ()
      (set! curr (inc curr))
      curr)))

(define counter (new-counter 1))
counterx)
;;=> 1
(counter)
;;=> 2
(counter)
;;=> 3

curr                                                        ; count-factory함수 밖에서는 curr접근 불가.
;;!> . . curr: undefined;
 ;;!> cannot reference an identifier before its definition

TODO

3.3 변형 가능한 데이터로 프로그래밍하기 3.3.1 변형 가능한 리스트 3.3.2 큐 queue/deque dictionary memoization - fibonacci

  • https://clojuredocs.org/clojure.core/memoize

3.3.3 표 3.3.4 디지털 회로 시뮬레이터 3.3.5 관계 알리기(constraint propagation)

3.4 병행성竝行性 : 시간은 중요하다 은행의 출금을 예로들어 serializer

  • 자원을 공유하는 함수들 끼리 그룹을 묶어, 그 구룹내에 있는 함수들은 동시에 실행이 안되게 막음.
  • job queue같은걸 만들어 큐에 쌓고 순차적으로 실행.

parallel-execute - https://stackoverflow.com/questions/13467753/implement-parallel-execute-in-scheme

  • mutex(Mutual Exclusion Lock)락을 이용해서 재화를 건드리는 함수들에 락을 걸어버림.
    • 하나의 쓰레드만 자원 접근 가능

3.5 스트림

  • stream == lazy sequence
    • 지연 평가(lazy evaluation)를 통해 필요할 때만 다음 요소를 계산하는 시퀀스를 뜻합니다.
  • ref
    • https://clojuredocs.org/clojure.core/lazy-seq

4장. 메타언어적 추상화

기본적인 Meta circular / Analyzing / Lazy / Ambiguous / Query를 단계적으로 제공해주면서 연습문제로 코드에 대한 이해 및 활용 그리고 수정할 기회를 줌.

우리는 당면한 문제에 특히 적합한 [용어]를 사용하여 문제를 다른 방식으로 설명하고 (따라서 사고할 수 있도록) 복잡한 문제를 처리하는 능력을 향상시킬 수 있습니다

"우리가 지금 사용하고 있는 언어(Scheme)를 사용해서, 또 다른 언어의 규칙과 의미를 정의하거나 해석하는 것" 프로그래밍 언어를 직접 정의하고 확장하는 추상화 기법이다.

  • MCE(Meta-Circular Evaluator) - https://en.wikipedia.org/wiki/Meta-circular_evaluator

    • Meta: "자기 자신을 대상으로 한"
    • Circular: "순환 구조의"
    • 자기 자신과 같은 언어로 작성되어, 자기 구조를 그대로 참조/사용하는 평가기.

  • eval

    • MetaCircular Evaluator
      • eval -> ( eval -> apply ) -> apply
      • 구문 분석을 위해 eval, apply 반복
    • Analyzing Evaluator
      • eval -> ( analyze ) -> call -> appy
      • analy를 통한 구문분석 후 apply로 평가
      • eval 횟수 감소 및 프로시져를 풀어씀으로써 계산 최적화
    • Lazy Evaluator
      • eval -> ( eval -> apply -> delay-it ) -> force-it
      • 지연 평가
      • 'thunk태그로 감싸고, 필요할때 평가
      • 불필요한 계산 건너뛸 수 있고, 메모이제이션을 이용한 최적화
    • Amb Evaluator
      • eval -> ( eval -> amb-apply )-> try-next-choice/fail
      • 비결정적(non-deterministic)
      • amb: Ambiguous choice
      • (amb)활용
      • 오버헤드가 있으나, 선언적으로 문제를 정의함으로써 풀 수 있음.
      • 제약조건 순서에 따라 연산 속도가 달라 질 수 있음.

    • Query system

meval / analyzingeval / leval 비교

#| 4_27 (define count 0) (define (id x) (set! count (+ count 1)) x) (define w (id (id 10)))

;; meval 매번 funcall eval때마다, expr로 저장된 프로시져의 expr을 순회하면서 special form / operator / arguments들에 대해 매번 eval을 실행.

#0=((w id count...) 10 (procedure (x) ((set! count (+ count 1)) x) #0#) 2 ... )

;; analyzingeval 매번 funcall eval때마다, lambda로 저장된 프로시져에 env가 들어오며 이미 env를 어디에 적용될지 맵핑된 lambda함수들이 한번에 apply 실행. #0=((w id count...) 10 (procedure (x) #procedure:... #0#) 2 ... )

#procedure:...은 symbol리스트가 아닌 함수가 컴파일된것. (lambda (env) (make-procedure '(x) (lambda (env) ((lambda (env) (set-variable-value! 'count (execute-application (lookup-variable-value '+ env) (list (lookup-variable-value 'count env) 1)) env) 'ok) env) ((lambda (env) (lookup-variable-value 'x env)) env)) env))

;; leval ;; - force-it-non-memoizing & force-it-memoizing #0=(((w id count ...) (thunk (id 10) #0#) (procedure (x) ((set! count (+ count 1)) x) #0#) 1 ... )

여기서 w를 호출하면

;; - force-it-non-memoizing #0=(((w id count ...) (thunk (id 10) #0#) (procedure (x) ((set! count (+ count 1)) x) #0#) 2 ... )

;; - force-it-memoizing #0=(((w id count ...) (evaluated-thunk 10) (procedure (x) ((set! count (+ count 1)) x) #0#) 2 ... )

여기서 한번 더 w를 호출하면

;; - force-it-non-memoizing #0=(((w id count ...) (thunk (id 10) #0#) (procedure (x) ((set! count (+ count 1)) x) #0#) 3 ... )

;; - force-it-memoizing #0=(((w id count ...) (evaluated-thunk 10) (procedure (x) ((set! count (+ count 1)) x) #0#) 2 ... ) |#

- delay
  - delay-it
    - ('thunk exp env)
- deref
  - force-it
    - ('thunk exp env) => ('evaluated-thunk result)

TODO

4.1 lisp로 lisp 인터프리터 만들기.

저자가 작성한 eval / apply / env / frame 설명 연습문제로 let / let* / letrec 확장을 볼 수 있다. halt problem

4.2 normal-order evaluation

  • 3장에서 상태를 덮어쓰기 때문에 생겨나는 여러 복잡한 문제를 피하기 위해 스트림 데이터(lazy sequence)를 사용.
  • Scheme(혹은 Racket)은 스트림 프로그램을 짜기에 번거로운 점이 있다 4.3 nondeterministic computing 4.4 logic-programming - prolog같은 논리형 프로그래밍

(list? '()) ;;=> #t (pair? '()) ;;=> #f

인터프리터와 컴파일러

  • 인터프리터: 표현식을 직접 실행
  • 컴파일러: 고수준 표현식을 더 낮은 수준(예: 가상 머신 코드, 기계어)으로 변환하고 그것을 실행
    • 단순한 인터프리터 대비 컴파일은 중복 평가 제거, 공통 하위 표현식 최적화 등이 가능.

Eval & Apply

4.1은 Eval과 Apply로 시작하게 된다.

코드가 길고 car/cdr/cadr/caddr ... 난리도 아니다. 다음을 정의하고 시작하자 (define first car) (define rest cdr) (define second cadr) (define third caddr)


;; ============================================================================
;; EVAL
;; ============================================================================

(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 expresslon type -- EVAL" exp))))

(define (self-evaluating? exp) nil)
(define (variable? exp) nil)
(define (quoted? exp) nil)
(define (assignment? exp) nil)
(define (definition? exp) nil)
(define (if? exp) nil)
(define (lambda? exp) nil)
(define (begin? exp) nil)
(define (cond? exp) nil)
(define (application? exp) nil)

(define (lookup-variable-value exp env)nil)
(define (text-of-quotation exp) nil)

(define (eval-assignment exp env) nil)
(define (eval-definition exp env) nil)
(define (eval-if exp env) nil)
(define (eval-sequence exps env) nil)

(define (make-procedure exp1 exp2 env) nil)
(define (lambda-parameters exp) nil)
(define (lambda-body exp) nil)
(define (begin-actions exp) nil)
(define (cond->if exp) nil)
(define (operator exp) nil)
(define (list-of-values exps env) nil)
(define (operands exp) nil)

;; ============================================================================
;; APPLY
;; ============================================================================

(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 (primitive-procedure? procedure) nil)
(define (compound-procedure? procedure) nil)
(define (apply-primitive-procedure procedure arguments) nil)
(define (procedure-body procedure) nil)
(define (extend-environment parameters arguments env) nil)
(define (procedure-parameters procedure) nil)
(define (procedure-environment procedure) nil)

4.1

(eval environment expression) (apply function function-arguments)

  1. 언어를 처리하는 기법

4.1 메타써큘러 실행기

4.1.1 언어 실행기의 알짜배기 eval / apply

Exercise 4.6 ** 문제자체는 쉽지만 Let을 다룬다.

4.1.2 식을 나타내는 방법 eval

(define (self-evaluating? exp) (or (number? exp) (string? exp))) (define (variable? exp) (symbol? exp)) (define (quoted? exp) (tagged-list? exp 'quote)) (define (assignment? exp) (tagged-list? exp 'set!)) (define (definition? exp) (tagged-list? exp 'define)) (define (if? exp) (tagged-list? exp 'if)) (define (lambda? exp) (tagged-list? exp 'lambda)) (define (begin? exp) (tagged-list? exp 'begin)) (define (cond? exp) (tagged-list? exp 'cond)) (define (application? exp) (pair? exp))

4.1.3 언어 실행기에서 쓰는 데이터 구조 평가기evaluator를 구현할 때는 프로그램의 외부 문법(external syntax)만 정의하는 것이 아니라 프로그램 실행 과정에서 평가기가 내부적으로 다루는 데이터 구조도 정의해야 함

참과 거짓 (define (true? x) (eq? x true)) (define (false? x) (not (true? x)))

내장 함수 ( primitive-procedure // aka built-in-function )

(apply-primitive-procedure (primitive-procedure?

환경(env) (lookup-variable-value (extend-environment (define-variable! (set-variable-value!

eval을 테스트하기 껄끄럽기에 연습문제 4.01 ~ 4.14는 4.1.4 Running the Evaluator as a Program 까지 읽고 풀기.

  • 개념
    • frame
      • ((symbol-a symbol-b ...) value-a (primitive func-b) ...)
      • 변수/함수이름 리스트 + 변수/함수들...
      • 연습문제 4.11에서
        • '((변수/함수이름 변수/함수) ...) 식으로 바꿈
        • '((symbol-a value-a) (symbol-b (primitive func-b)) ...)
    • environment
      • (frame-a frame-b)
      • 프레임 리스트
      • (cons new-frame env)
      • (cons 'b '(a)) => (b a) 새로운 frame이 앞에오는 구조

4.1.4 언어 실행기를 보통 프로그램처럼 돌려보기

set-car! set-cdr!

(define (setup-environment) (let ((initial-env (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment))) (define-variable! 'true true initial-env) (define-variable! 'false false initial-env) initial-env))

연습 4.13 ** 문제 make-unbound! 함수를 만들어 env에서 지울 수 있도록 만들자. first-frame에서만 지우면 되는가?

4.1.5 Data as Programs 프로그램도 데이터처럼

6 => factorial => 720 The factorial program, viewed as an abstract machine. 6 => evaluator => 720 evaluator as a very special machine

evaluator is seen to be a universal machine.

  • A Universal Turing machine, often just called a universal machine, is an abstract computational device that can simulate other computational devices.
  • UTM https://en.wikipedia.org/wiki/Universal_Turing_machine

단순하고 자명한 것에서 복잡한것이 나오게 된다.

GEB( Gödel, Escher, Bach: an Eternal Golden Braid ) 괴델, 에셔, 바흐: 영원한 황금 노끈 https://de.wikipedia.org/wiki/G%C3%B6del,_Escher,_Bach

recursion theory ( Computability theory ) "무엇이 계산 가능하고, 무엇이 절대 계산 불가능한가?" https://en.wikipedia.org/wiki/Computability_theory

연습 4.15 ** Halting Problem

4.1.6 안쪽 정의(internal definition)

c언어의 전방선언과 비슷한 느낌.

선언과 할당을 동시에 할때 생기는 문제 let을 써서(frame 을 하나 더 써서) 풀어보고 선언 먼저 '*unassigned*로 공간을 만들어주고 그 다음 할당.

연습문제 4.17 - frame을 쓰지 않고 풀어보고

연습문제 4.19 ** Sequential Scope Simultaneous Scope lazy evaluation 연습문제 4.21 ** Z combinator - lambda calculus

4.1.7 문법 분석과 실행 과정을 떼어놓기

  • eval시 analyze과정을 넣어 최적화

4.2 Scheme 바꿔보기 - 제때 계산법

4.2.1 식의 값을 구하는 차례 - 정의대로 계산법과 인자 먼저 계산법

lazy evaluation <=> eager evaluation

(define (try a b) (if (= a 0) 1 b))

(try 0 (/ 1 0)) ;=> 1 // lazy evaluation ;!> /: division by zero // eager evaluation

4.2.2 제때 계산법을 따르는 실행기

  • frame
    • ((symbol-a symbol-b ...) value-a (primitive func-b) ...)

(define (actual-value exp env) (force-it (eval exp env)))

(define (force-it obj) thunk면 계산해서 캐쉬에 넣기 ) (define (delay-it exp env) (list 'thunk exp env))

(thunk exp env) (evaluated-thunk exp env)

연습문제 4.30 ** (define (f a (b lazy) c (d lazy-memo)) ...) 구현

4.2.3 제때셈 리스트와 스트림

연습문제 4_34 ** lazy pair / lazy list의 출력방식 수정

4.3 Scheme 바꿔보기 - 비결정적 계산

Nondeterministic Computing

amb ( Ambiguous )

(define (an-integer-starting-from n) (amb n (an-integer-starting-from (+ n 1))))

(define (an-element-of items) (require (not (null? items))) (amb (car items) (an-element-of (cdr items))))

(define (require p) (if (not p) (amb)))

  • Teach Yourself Scheme in Fixnum Days - 14 Nondeterminism

    • McCarthy’s nondeterministic operator amb

  • A BASIS FOR A MATHEMATICAL THEORY OF COMPUTATION∗ by JOHN McCARTHY

    • https://www-formal.stanford.edu/jmc/basis1/basis1.html

  • 3.5.2에서 나온 스트림 프로시져 integers-starting-from 와는 다름

    • n으로 시작하는 정수 리스트

  • amb의 an-integer-starting-from

    • 정수 하나

4.3.1 amb와 찾기 4.36 **

4.3.2 비결정적 프로그램 짜기 multiple-dwelling 4.39 ** 4.43 ** Lorna의 아빠 찾기 4.44 ** 8-queen

4.3.3 amb 실행기 구현

4.1.7절에서 만든 문법을 분석하는 해석기를 고치자 ( analyzingmceval => ambeval)

4.4 논리로 프로그램 짜기

https://www.slideshare.net/slideshow/sicp-44-logic-programming/1552206

3.5 스트림도 보고 오는게 좋음

4.4.1 연역식 정보 찾기 - 쿼리짜는 연습 rule

4.4.2 쿼리 시스템의 동작 방식

  • 데이터베이스 fact와 rule을 매치시키기 위한 방법으로 amb활용이나 스트림 활용 할 수 있음

  • 여기선 스트림 활용.

  • query system: pattern matching + unification

    • pattern matching
      • 단순비교, 쿼리가 데이터베이스의 fact와 일치하는지 확인.
      • 단방향 매칭
    • unification
      • 쿼리와 rule, rule과 fact, 또는 rule과 rule 간의 일치를 처리하는 데 사용.
      • 양방향 매칭
(simple-query query-pattern frame-stream)
  |
  v
[frame-stream] ==> stream-flatmap
                        |
                        v
                    (per frame)
                  stream-append-delayed
                  |                     \
                  v                      v
             find-assertions         delay (apply-rules)
                  |                      |
                  v                      v
             fetch-assertions        fetch-rules
                  |                      |
               (per datum)             (per rule)
             check-an-assertion       apply-a-rule
                  |                      |
                  v                      v
             pattern-match           unify-match
                  |                      |
                  v                      v
             extend-if-consistent    extend-if-possible
                  |                      |
                  v                      v
             [frame-stream]          [frame-stream]
                  |                      /
                  v                     v
                  stream-append-delayed
                        |
                        v
                  stream-flatmap    ===========>   [result-frame-stream]

;; (pattern-match {패턴} {데이터} {프레임(사전역활)})
;;=> {새로운 프레임}

(pattern-match '((? x) (? y) (? x)) '(a b a) '())
;;=> (((? y) . b)
;;    ((? x) . a))

(pattern-match '((? x) (? y) (? x)) '(a b a) '(((? y) . a)))
;;=> failed

(pattern-match '((? x) (? y) (? x)) '(a b a) '(((? y) . b)))
;;=> (((? x) . a)
;;    ((? y) . b))

;; (unify-match {패턴1} {패턴2} {프레임(사전역활)})
;;=> {새로운 프레임}

(unify-match '((? x) (? x)) '((a (? y) c) (a b (? z))) '())
;;=> (((? z) . c)
;;    ((? y) . b)
;;    ((? x) a (? y) c))

(unify-match '((? x) (? x)) '(((? y) a (? w)) (b (? v) (? z))) '())
;;=> (((? w) ? z)
;;    ((? v) . a)
;;    ((? y) . b)
;;    ((? x) (? y) a (? w)))
  • unifier
    • 상수변수패턴1: (?x a ?y)
    • 상수변수패턴2: (?y ?z a)
    • frame()
      • => ?x => a ?y => a? z => a

4.4.3 논리 프로그래밍은 수학 논리를 따르는가?

  • 4.4.3에 나오지만 4.4.4를 보고 푸는게 좋음
    • 연습문제 4.67 **
    • 연습문제 4.68 **

연습문제 4.69 **

4.4.4 쿼리 시스템 만들기

4.4.4.1 드라이버 루프와 쿼리 값 찍어내기(instantiation)

(define (instantiate exp frame unbound-var-handler)
  (define (copy exp)
    (cond ((var? exp)
           (let ((binding (binding-in-frame exp frame)))
             (if binding
                 (copy (binding-value binding))
                 (unbound-var-handler exp frame))))
          ((pair? exp)
           (cons (copy (car exp)) (copy (cdr exp))))
          (else exp)))
  (copy exp))

;; (query-syntax-process '(hello world ?x ?y))
;;=> (hello world (? x) (? y))

;; (expand-question-mark '?x)
;;=> (? x)

4.4.4.2 실행기(evaluator)

(define (qeval query frame-stream)
  (let ((qproc (get (type query) 'qeval)))
    (if qproc
        (qproc (contents query) frame-stream)
        (simple-query query frame-stream)))):


(define (simple-query query-pattern frame-stream)
  (stream-flatmap (lambda (frame)
                    (stream-append-delayed (find-assertions query-pattern frame)
                                           (delay (apply-rules query-pattern frame))))
                  frame-stream))

4.4.4.3 패턴 매칭으로 참말 찾아내기 4.4.4.4 규칙과 동일화 4.4.4.5 데이터베이스의 관리 4.4.4.6 스트림 연산 4.4.4.7 쿼리의 문법을 처리하는 프로시저 4.4.4.8 일람표와 정의

4.01 cons left right 4.02 application? 위치 4.03 data-directed style 4.04 and? or? 추가

5장. 레지스터 머신으로 계산

  • CODE 코드 : 컴퓨터 하드웨어와 소프트웨어에 숨어 있는 언어
    • Code: The Hidden Language of Computer Hardware and Software

Lecture 9A: Register Machines

  • fact설명

ch5-regsim 커스텀 기계 코드를 정의하고, label 과 register를 가진 실행 머신을 만듬

stack이 레지스터 별로가 아니라 통합이라서 save/restore순서 주의

슬금 슬금 머신 코드를 보여주다가 인터프리터를 돌 릴 수 있는 머신 코드가 나옴

instruction label pc flag stack - save / restore

5.1에서 controller로 의사코드를 보여주면서

5.2에서 make-machine으로 머신을 만들어 구동 load-eceval 파일은 SICP 5.4절에서 정의된 **명시적 제어 평가기(ECEval)**를 로드합니다. ECEval은 Scheme 프로그램을 해석(interpret)하는 인터프리터로, Scheme 코드를 직접 실행할 수 있도록 설계된 가상 머신입니다.

load-eceval-compiler SICP 5.5절에서 다루는 컴파일러와 연동된 ECEval을 로드합니다. 즉, Scheme 코드를 컴파일하여 기계어 수준의 명령어로 변환한 뒤, 이를 ECEval에서 실행할 수 있도록 지원합니다.

eceval - EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4

TODO

  • Computing with Register Machines
    • 5장은, 레지스터 머신과 가비지 컬렉터 그리고 컴파일러를 구현한다.
  1. 레지스터 기계로 계산하기
(define (gcd a b)
  (if (= b 0)
      a
      (gcd b (remainder a b))))
data path레지스터 + 연산
controller연산 순서
네모레지스터
세모상수
사다리꼴연산
원검사

a <- b: a에 b값을 덮어쓰기

(data-paths
 (registers
  ((name a)
   (buttons ((name a<-b) 
             (source (register b)))))
  ((name b)
   (buttons ((name b<-t)
             (source (register t)))))
  ((name t)
   (buttons ((name t<-r)
             (source (operation rem))))))
 (operations
  ((name rem)
   (inputs (register a) (register b)))
  ((name =)
   (inputs (register b) (constant 0)))))

(controller
 test-b                ; label
   (test =)            ; test
   (branch 
    (label gcd-done))  ; conditional branch
   (t<-r)              ; button push
   (a<-b)              ; button push
   (b<-t)              ; button push
   (goto 
    (label test-b))    ; unconditional branch
 gcd-done)             ; label

5.1 레지스터 기계 설계하기 5.1.1 레지스터 기계를 묘사하는 언어 5.1.2 기계 디자인에서의 속 내용 감추기(abstraction) 5.1.3 서브루틴

(define (factorial n)
  (if (= n 1) 
      1
      (* (factorial (- n 1)) n)))

;;FIGURE 5.11
(controller
   (assign continue (label fact-done))     ; set up final return address

 fact-loop
   (test (op =) (reg n) (const 1))
   (branch
     (label base-case))

   ;; Set up for the recursive call by saving n and continue.
   ;; Set up continue so that the computation will continue
   ;; at after-fact when the subroutine returns.
   (save continue)
   (save n)
   (assign n (op -) (reg n) (const 1))
   (assign continue
     (label after-fact))
   (goto
     (label fact-loop))

 after-fact
   (restore n)
   (restore continue)
   (assign val (op *) (reg n) (reg val))   ; val now contains n(n-1)!
   (goto (reg continue))                   ; return to caller

 base-case
   (assign val (const 1))                  ; base case: 1!=1
   (goto (reg continue))                   ; return to caller

 fact-done)

** 5.1.4 스택(stack)을 이용해 되돌기(recursion) 구현하기

5.1.5 명령어 정리

5.2 레지스터 기계 시뮬레이터

(define gcd-machine
  (make-machine
     ;; 레지스터 목록
   '(a b t)
   
   ;; 연산 목록
   (list (list 'rem remainder) (list '= =))

   ;; 컨트롤러
   '(test-b
      (test (op =) (reg b) (const 0))
      (branch (label gcd-done))
      (assign t (op rem) (reg a) (reg b))
      (assign a (reg b))
      (assign b (reg t))
      (goto (label test-b))
     gcd-done)))

(set-register-contents! gcd-machine 'a 206)
(set-register-contents! gcd-machine 'b 40)

(start gcd-machine)

(get-register-contents gcd-machine 'a)

5.2.1 기계 모형 5.2.2 어셈블러 5.2.3 명령에 해당하는 실행 프로시저 만들기

eval/analyze같은 존재 make-execution-procedure

연습문제 5.11 c) **

5.2.4 기계 성능 지켜보기

연습문제 5.17 ** 명령어 바로 앞에 오는 레이블을 출력하 연습문제 5.19 ** breakpoint 구현

5.3 메모리 할당(memory allocation)과 재활용(garbage collection) 5.3.1 벡터로 나타낸 메모리 5.3.2 무한히 많은 메모리인 양 보이기 ?

;; 2장에서 enumerate-interval / filter / accumulate
(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (filter predicate sequence)
  (cond ((null? sequence) nil)
        ((predicate (car sequence))
         (cons (car sequence)
               (filter predicate (cdr sequence))))
        (else (filter predicate (cdr sequence)))))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(accumulate + 0 (filter odd? (enumerate-interval 0 n)))

계산이 끝나면 enumerate-interval랑 filter로 생성된 리스트는 의미가 없음.
  • stop-and-copy
    • memory
      • working memory
      • free memory
- working memory : 현재 작업 메모리
the-cars[]
the-cdrs[]

- free memory    : 여유 메모리
new-cars[]
new-cdrs[]


free               - 그림5.14 / 연습문제5.20 에서 다음에 객체(쌍)를 할당할 위치를 가리키는 포인터(index).
                     할당할때마다 free증가
scan               - 새 메모리에서 현재 스캔 중인 쌍의 위치를 가리키는 포인터(index).
                     gc-loop 루프를 돌며 scan은 free와 같아질때까지 재배치된걸 검색
root               - 가비지 컬렉션이 시작되면 root가 가리키는 객체를 새 메모리로 재배치하고, 재배치된 새 위치로 root를 업데이트
                     이 레지스터는 프로그램이 접근할 수 있는 모든 데이터의 진입점 역할
new                - 재배치된 객체의 새 메모리 위치를 저장하는 레지스터.
old                - 재배치할 객체의 이전 메모리 위치를 가리키는 포인터
relocate-continue - lable 저장용


메모리 재활용 시점: 
- working memory를 다 썼을 시(cons연산이 메모리 벡터끝을 넘어서 free 포인터를 증가시키려 할때)

begin-garbage-collection                                                   ; def begin-garbage-collection
  (assign free (const 0))                                                  ;   free = 0
  (assign scan (const 0))                                                  ;   scan = 0
  (assign old (reg root))                                                  ;   old = root
  (assign relocate-continue (label reassign-root))                         ;   relocate-continue = <reassign-root>
  (goto (label relocate-old-result-in-new))                                ;   return <relocate-old-result-in-new>

reassign-root                                                              ; def reassign-root
  (assign root (reg new))                                                  ;   root = new
  (goto (label gc-loop))                                                   ;   return <gc-loop>
    

gc-loop                                                                    ; def gc-loop
  (test (op =) (reg scan) (reg free))                                      ;   if (scan == free)
  (branch (label gc-flip))                                                 ;        return <gc-flip>
  (assign old (op vector-ref) (reg new-cars) (reg scan))                   ;   old = new-cars[scan]
  (assign relocate-continue (label update-car))                            ;   relocate-continue = <update-car>
  (goto (label relocate-old-result-in-new))                                ;   return <relocate-old-result-in-new>
    


update-car                                                                 ; def update-car
  (perform (op vector-set!) (reg new-cars) (reg scan) (reg new))           ;   new-cars[scan] = new
  (assign old (op vector-ref) (reg new-cdrs) (reg scan))                   ;   old = new-cdrs[scan]
  (assign relocate-continue (label update-cdr))                            ;   relocate-continue = <update-cdr>
  (goto (label relocate-old-result-in-new))                                ;   return <relocate-old-result-in-new>

update-cdr                                                                 ; def update-cdr
  (perform (op vector-set!) (reg new-cdrs) (reg scan) (reg new))           ;   new-cdrs[scan] = new
  (assign scan (op +) (reg scan) (const 1))                                ;   scan = scan + 1
  (goto (label gc-loop))                                                   ;   return <gc-loop>

relocate-old-result-in-new                                                 ; def relocate-old-result-in-new
  (test (op pointer-to-pair?) (reg old))                                   ;   if (pointer-to-pair? old)
  (branch (label pair))                                                    ;      return <pair>
  (assign new (reg old))                                                   ;   new = old
  (goto (reg relocate-continue))                                           ;   return (relocate-continue)

pair                                                                       ; def pair
  (assign oldcr (op vector-ref) (reg the-cars) (reg old))                  ;   oldcr = the-cars[old]
  (test (op broken-heart?) (reg oldcr))                                    ;   if (broken-heart? oldcr)
  (branch (label already-moved))                                           ;      return <already-moved>
  (assign new (reg free)) ;new location for pair                           ;   new = free
  (assign free (op +) (reg free) (const 1))                                ;   free = free + 1
  (perform (op vector-set!) (reg new-cars) (reg new) (reg oldcr))          ;   new-cars[new] = oldcr
  (assign oldcr (op vector-ref) (reg the-cdrs) (reg old))                  ;   oldcr = the-cdrs[old]
  (perform (op vector-set!) (reg new-cdrs) (reg new) (reg oldcr))          ;   new-cdrs[new] = oldcr
  (perform (op vector-set!) (reg the-cars) (reg old) (const broken-heart)) ;   the-cars[old] = 'broken-heart
  (perform (op vector-set!) (reg the-cdrs) (reg old) (reg new))            ;   the-cdrs[old] = new
  (goto (reg relocate-continue))                                           ;   return (relocate-continue)

already-moved                                                              ; def already-moved
  (assign new (op vector-ref) (reg the-cdrs) (reg old))                    ;   new = the-cdrs[old]
  (goto (reg relocate-continue))                                           ;   return (relocate-continue)



gc-flip                                                                    ; def gc-flip
  (assign temp (reg the-cdrs))                                             ;   swap(the-cdrs, new-cdrs)
  (assign the-cdrs (reg new-cdrs))                                         ;   ..
  (assign new-cdrs (reg temp))                                             ;   ..
  (assign temp (reg the-cars))                                             ;   swap(the-cars, new-cars)
  (assign the-cars (reg new-cars))                                         ;   ..
  (assign new-cars (reg temp))                                             ;   ..

5.4 제어가 다 보이는 실행기 5.4.1 제어가 다 보이는 실행기의 핵심부 5.4.2 시퀀스 계산과 꼬리 되돌기(tail recursion) 5.4.3 조건 식, 덮어쓰기(assignment), 정의

연습문제 5.24 ** if로 변환하지 않고 cond구현. 연습문제 5.25 ** normal-order evaluation 구현.

5.4.4 실행기 돌리기

5.5 번역(compilation) 5.5.1 번역기의 구조 5.5.2 프로그램 식의 번역 5.5.3 조합 식 번역하기 5.5.4 명령줄 한데 합치기 5.5.5 번역된 코드의 예 5.5.6 텍스트에서 변수의 정의를 파악하기(lexical addressing) 5.5.7 번역된 코드를 실행기에 연결하기

(reg ⟨register-name⟩) or (const ⟨constant-value⟩). These instructions were introduced in 5.1.1:

(assign ⟨register-name⟩ (reg ⟨register-name⟩))
(assign ⟨register-name⟩ 
        (const ⟨constant-value⟩))
(assign ⟨register-name⟩ 
        (op ⟨operation-name⟩) 
        ⟨input₁⟩ … ⟨inputₙ⟩)
(perform (op ⟨operation-name⟩) 
         ⟨input₁⟩ 
         … 
         ⟨inputₙ⟩)
(test (op ⟨operation-name⟩) 
      ⟨input₁⟩ 
      … 
      ⟨inputₙ⟩)
(branch (label ⟨label-name⟩))
(goto (label ⟨label-name⟩))
The use of registers to hold labels was introduced in 5.1.3:

(assign ⟨register-name⟩ (label ⟨label-name⟩))
(goto (reg ⟨register-name⟩))
Instructions to use the stack were introduced in 5.1.4:

(save ⟨register-name⟩)
(restore ⟨register-name⟩)
The only kind of ⟨constant-value⟩ we have seen so far is a number, but later we will use strings, symbols, and lists. For example,
(const "abc") is the string "abc",
(const abc) is the symbol abc,
(const (a b c)) is the list (a b c),
and (const ()) is the empty list.

(make-machine ⟨register-names⟩
              ⟨operations⟩
              ⟨controller⟩)
(set-register-contents! ⟨machine-model⟩ 
                        ⟨register-name⟩ 
                        ⟨value⟩)
(get-register-contents ⟨machine-model⟩
                       ⟨register-name⟩)
(start ⟨machine-model⟩)

풀이

todo

  • 1 46
    • 1_20 ~
  • 2 97
    • 2_01 ~
  • 3 82
    • 3_05
    • 3_09 ~
  • 4 79
    • 4_34
    • 4_44
    • 4_67
    • 4_77
    • 4_78
    • 4_79
  • 5 52
    • 5_01
    • 5_05
    • 5_24 ~

Chapter 1 - Building Abstractions with Procedures

1.1 – The Elements of Programming
1.011.021.031.041.05
1.061.071.08........

1.2 – Procedures and the Processes They Generate
............1.091.10
1.111.121.131.141.15
1.161.171.181.191.20
1.211.221.231.241.25
1.261.271.28........

1.3 – Formulating Abstractions with Higher-Order Procedures
............1.291.30
1.311.321.331.341.35
1.361.371.381.391.40
1.411.421.431.441.45
1.46................

Chapter 2 - Building Abstractions with Data

2.1 – Introduction to Data Abstraction
2.012.022.032.042.05
2.062.072.082.092.10
2.112.122.132.142.15
2.16................

2.2 – Hierarchical Data and the Closure Property
....2.172.182.192.20
2.212.222.232.242.25
2.262.272.282.292.30
2.312.322.332.342.35
2.362.372.382.392.40
2.412.422.432.442.45
2.462.472.482.492.50
2.512.52............

2.3 – Symbolic Data
........2.532.542.55
2.562.572.582.592.60
2.612.622.632.642.65
2.662.672.682.692.70
2.712.72............

2.4 – Multiple Representations for Abstract Data
........2.732.742.75
2.76................

2.5 – Systems with Generic Operations
....2.772.782.792.80
2.812.822.832.842.85
2.862.872.882.892.90
2.912.922.932.942.95
2.962.97............

Chapter 3 - Modularity, Objects, and State

3.1 – Assignment and Local State
3.013.023.033.043.05
3.063.073.08........

3.2 – The Environment Model of Evaluation
............3.093.10
3.11................

3.3 – Modeling with Mutable Data
....3.123.133.143.15
3.163.173.183.193.20
3.213.223.233.243.25
3.263.273.283.293.30
3.313.323.333.343.35
3.363.37............

3.4 – Concurrency: Time Is of the Essence
........3.383.393.40
3.413.423.433.443.45
3.463.473.483.49....

3.5 – Streams
................3.50
3.513.523.533.543.55
3.563.573.583.593.60
3.613.623.633.643.65
3.663.673.683.693.70
3.713.723.733.743.75
3.763.773.783.793.80
3.813.82............

Chapter 4 - Metalinguistic Abstraction

4.1 – The Metacircular Evaluator
4.014.024.034.044.05
4.064.074.084.094.10
4.114.124.134.144.15
4.164.174.184.194.20
4.214.224.234.24....

4.2 – Variations on a Scheme – Lazy Evaluation
................4.25
4.264.274.284.294.30
4.314.324.334.34....

4.3 – Variations on a Scheme – Nondeterministic Computing
................4.35
4.364.374.384.394.40
4.414.424.434.444.45
4.464.474.484.494.50
4.514.524.534.54....

4.4 – Logic Programming
................4.55
4.564.574.584.594.60
4.614.624.634.644.65
4.664.674.684.694.70
4.714.724.734.744.75
4.764.774.784.79....

Chapter 5 - Computing with Register Machines

5.1 – Designing Register Machines
5.015.025.035.045.05
5.06................

5.2 – A Register-Machine Simulator
....5.075.085.095.10
5.115.125.135.145.15
5.165.175.185.19....

5.3 – Storage Allocation and Garbage Collection
................5.20
5.215.22............

5.4 – The Explicit-Control Evaluator
........5.235.245.25
5.265.275.285.295.30

5.5 – Compilation
5.315.325.335.345.35
5.365.375.385.395.40
5.415.425.435.445.45
5.465.475.485.495.50
5.515.52............

연습문제 풀이 01

1_01

;; file: 1_01.rkt

10
;;=> 10
 
(+ 5 3 4)
;;=> 12
 
(- 9 1)
;;=> 8
 
(/ 6 2)
;;=> 3
 
(+ (* 2 4) (- 4 6))
;;=> 6


;; ===========================================

(define a 3)
(define b (+ a 1))

(+ a b (* a b))
;;=> 19
 
(= a b)
;;=> #f
 
(if (and (> b a) (< b (* a b)))
    b
    a)
;;=> 4
 

(cond ((= a 4) 6)
      ((= b 4) (+ 6 7 a))
      (else 25))
;;=> 16

(+ 2 (if (> b a)
         b
         a))
;;=> 6

(* (cond ((> a b) a)
         ((< a b) b)
         (else -1))
   (+ a 1))
;;=> 16

1_02

$$\frac{5 + 4 + (2 - (3 - (6 + 4/5)))}{3(6 - 2)(2 - 7)}$$

;; file: 1_02.rkt

(/ (+ 5 4 (- 2 (- 3 (+ 6 (/ 4 5)))))
   (* 3 (- 6 2) (- 2 7)))
;;=> -37/150

1_03

;; file: 1_03.rkt

(#%require rackunit)
(#%require threading)
(#%require "../allcode/helper/my-util.rkt")

;; a, b, c 를 인자로 받고 가장 큰 두 수의 제곱의 합
;; 1.1.4에 나온 sum-of-squares 사용.

(define (square x)
  (* x x))

(define (sum-of-squares x y)
  (+ (square x) (square y)))

(define (ex1-03 a b c)
  (cond ((and (< a b) (< a c))
         (sum-of-squares b c))
        ((< b c)
         (sum-of-squares a c))
        (else
         (sum-of-squares a b))))
  
(check-equal? (ex1-03 2 10 3) 109)


;; ======================================================================================
;; 번외. sequcne(list)와 고차함수를(filter/sort/take)  이용한 방법.

(define (filter pred? sequence)
  (cond ((null? sequence) '())
        ((pred? (first sequence))
         (cons (first sequence) (filter pred? (rest sequence))))
        (else
         (filter pred? (rest sequence)))))

(define (sort less-than? lst)
  (if (or (null? lst) (null? (rest lst)))
      lst
      (let* ((pivot (first lst))
             (rest (rest lst))
             (smaller (filter (lambda (x) (less-than? x pivot)) rest))
             (greater-equal (filter (lambda (x) (not (less-than? x pivot))) rest)))
        (append (sort less-than? smaller)
                (cons pivot (sort less-than? greater-equal))))))

(define (take n sequence)
  (cond ((<= n 0) '())
        ((null? sequence) '())
        (else (cons (first sequence)
                    (take (- n 1) (rest sequence))))))

(define (largest-squares n xs)
  (~>> xs
       (sort >)
       (take n)
       (map (lambda (x) (* x x)))
       (apply +)))


(check-equal? (largest-squares 2 '(2 10 3)) 109)

1_04

;; file: 1_04.rkt

(define (a-plus-abs-b a b)
  ((if (> b 0)
       +
       -)
   a b))


(a-plus-abs-b 2 7)
;;=> 9

(a-plus-abs-b 2 -7)
;;=> 9


(a-plus-abs-b -2 7)
;;=> 5

(a-plus-abs-b -2 -7)
;;=> 5

1_05

;; file: 1_05.rkt

(define (p)
  (p))
(define (test x y)
  (if (= x 0)
      0
      y))

(test 0 (p))
;;=> 0

;; #lang sicp 라면 y로 들어온 (p)가 무한히 호출됨.
;; #lang lazy 라면 y를 평가하지 않아 0이 반환.
;; #lang lazy는 엄밀히 말하면 Lazy Evaluation인데 normal-order evaluation에 캐쉬를 단거라 생각하면됨.

1_06

;; file: 1_06.rkt
(#%require threading)

;; 1.1.7 연습: 뉴튼 법으로 제곱근 찾기

(define (square x)
  (* x x))

#;(define (sqrt-iter guess x)
    (if (good-enough? guess x)
        guess
        (sqrt-iter (improve guess x) x)))

(define (improve guess x)
  (average guess (/ x guess)))

(define (average x y)
  (~> (+ x y) 
      (/ 2)))

(define (good-enough? guess x)
  (~> (square guess)
      (- x)
      (abs)
      (< 0.001)))

(define (sqrt x)
  (sqrt-iter 1.0 x))

;; ref: https://docs.racket-lang.org/reference/if.html#%28form._%28%28quote._~23~25kernel%29._if%29%29
;;
;; (if test-expr
;;     then-expr
;;     else-expr)
;; 
;; if는 Special form으로 predicate를 수행후 then이나 else를 수행한다.
;;
;; 하지만 new-if는 함수인데, Applicative-Order evaluation에서의 함수는 인자를 다 평가시켜버려서,
;; (sqrt-iter (improve guess x) x) 도 계속 실행시켜버려 메모리가 부족해져버린다.

(define (new-if predicate then-clause else-clause)
  (cond (predicate then-clause)
        (else else-clause)))

(define (sqrt-iter guess x)
  (new-if (good-enough? guess x)
          guess
          (sqrt-iter (improve guess x) x)))

;; #lang sicp에서는 Applicative-Order Evaluation이기에
(sqrt 9)
;;!> . Interactions disabled; out of memory

;; #lang lazy에서는 Lazy Evaluation이기에
(sqrt 9)
;;=> 3.00009155413138

1_07

;; file: 1_07.rkt
(#%require threading)
(#%require (prefix racket: racket))
(#%require rackunit)

;; 1.1.7 연습: 뉴튼 법으로 제곱근 찾기

(define (square x)
  (* x x))

#;(define (sqrt-iter guess x)
    (if (good-enough? guess x)
        guess
        (sqrt-iter (improve guess x) x)))

(define (improve guess x)
  (average guess (/ x guess)))

(define (average x y)
  (~> (+ x y) 
      (/ 2)))

#;(define (good-enough? guess x)
    (~> (square guess)
        (- x)
        (abs)
        (< 0.001)))

(define (sqrt x)
  (sqrt-iter 1.0 x))


;; ========================================
;; 중요한거. 번역판을 읽으면 이 문제를 풀기 어려워진다.
;; 원문을 읽어야 이 문제를 보다 풀기가 쉬워진다.
;;
;; An alternative strategy for implementing good-enough? is to watch how guess changes from one iteration to the next
;; and to stop when the change is a very small fraction of the guess.
;; 반복할 때마다 `guess`의 **변화량**를 살펴보고,
;; `guess`에 **변화량**이 **아주 작은** 비율이 되었을 때 멈추는 것이다.
(define DECIMAL-EPSILON
  (let loop ([e 1.0])
    (if (= (+ 1.0 e) 1.0)
        (* 2 e)
        (loop (/ e 2)))))

(define VERY-SMALL-RADIO DECIMAL-EPSILON)
;; (define VERY-SMALL-RADIO 0.00000000001)

VERY-SMALL-RADIO
;;=> 2.220446049250313e-16

(define (good-enough? guess next-guess)
  (let ((diff (- guess next-guess)))
    (~> (/ diff next-guess)
        (abs)
        (< VERY-SMALL-RADIO))))

(define (sqrt-iter guess x)
  (let ((next-guess (improve guess x)))
    (if (good-enough? guess next-guess)
        guess
        (sqrt-iter next-guess x))))

;; 아주 큰 수의 제곱근을 잘 구하는가?
;; 아주 작은 수 의 제곱근을 잘 구하는가?
(define COMPARE-EPSILON 0.00000001)
(check-= (sqrt 0.00000000123456) (racket:sqrt 0.00000000123456) COMPARE-EPSILON)
(check-= (sqrt 123456789012345) (racket:sqrt 123456789012345) COMPARE-EPSILON)


;; ref: https://sicp-solutions.net/post/sicp-solution-exercise-1-7/

1_08

$$ \text{목표: } y = \sqrt[3]{x} $$

$$ \text{⇒ 양변을 세제곱: } y^3 = x $$

$$ \text{⇒ 함수로 표현: } f(y) = y^3 - x $$

$$ \text{⇒ 도함수: } f'(y) = 3y^2 $$

$$ \text{⇒ 뉴튼 방법 일반식: } y_{n+1} = y_n - \frac{f(y_n)}{f'(y_n)} $$

$$ \text{⇒ 대입: } y_{n+1} = y_n - \frac{y_n^3 - x}{3y_n^2} $$

$$ = y_n - \frac{1}{3} \left( y_n - \frac{x}{y_n^2} \right) $$

$$ = \frac{2y_n + \frac{x}{y_n^2}}{3} $$

$$ \therefore \boxed{ y_{n+1} = \frac{x/y_n^2 + 2y_n}{3} } $$

;; file: 1_08.rkt
(#%require threading)
(#%require rackunit)

;; imporve 가 바뀌고 나머지는sqrt를 구할때와 거의 비슷한 흐름으로 흘러간다.
(define (improve guess x)
  "( x/y^2 + 2y ) / 3"
  (/ (+ (/ x (* guess guess)) (* 2 guess)) 3))

(define VERY-SMALL-RADIO 0.00000000001)

(define (good-enough? guess next-guess)
  (let ((diff (- guess next-guess)))
    (~> (/ diff next-guess)
        (abs)
        (< VERY-SMALL-RADIO))))


(define (cube-root-iter guess x)
  (let ((next-guess (improve guess x)))
    (if (good-enough? guess next-guess)
        guess
        (cube-root-iter next-guess x))))

(define (cube-root x)
  (cube-root-iter 1.0 x))

(define (cube x)
  (* x x x))

(define COMPARE-EPSILON 0.00000001)
(check-= 12345 (cube (cube-root 12345)) COMPARE-EPSILON)

1_09

;; file: 1_09.rkt
(#%require (prefix trace: racket/trace))

(define (x+ a b)
  (if (= a 0)
      b
      (inc (x+ (dec a) b))))

;; (x+ 2 1)
;; (inc (x+ 1 1))
;; (inc (inc (x+ 0 1)))
;; (inc (inc 1))
;; (inc 2)
;;=> 3

(define (y+ a b)
  (if (= a 0)
      b
      (y+ (dec a) (inc b))))

;; (y+ 2 1)
;; (y+ 1 2))
;; (y+ 0 3)
;;=> 3

(trace:trace x+)
(trace:trace y+)

(display "x+ ==============================\n")
(x+ 2 1)
;;>> >{x+ 2 1}
;;>> > {x+ 1 1}
;;>> > >{x+ 0 1}
;;>> < <1
;;>> < 2
;;>> <3
;;=> 3
(display "y+ ==============================\n")
(y+ 2 1)
;;>> >{y+ 2 1}
;;>> >{y+ 1 2}
;;>> >{y+ 0 3}
;;>> <3
;;=> 3

1_10

;; file: 1_10.rkt
(#%require (prefix trace: racket/trace))

(define (A x y)
  ;; A(x, 0) = 0
  ;; A(0, y) = 2y
  ;; A(x, 1) = 2
  ;; A(x, y) = A(x-1, A(x, y-1))
  (cond ((= y 0) 0)
        ((= x 0) (* 2 y))
        ((= y 1) 2)
        (else   (A (- x 1) (A x (- y 1))))))

(A 1 10)
;;=> 1024
(A 2 4)
;;=> 65536
(A 3 3)
;;=> 65536
(A 4 2)
;;=> 4


(define (f n) (A 0 n))
;; A(0, y) = 2y
;; f(n) = 2n

(define (g n) (A 1 n))
;; A(1, n-0)
;; = 2 * A(1, n-1)
;; = 2 * 2 * A(1, n-2)
;; = 2 * 2 * ... * A(1, n-(n- 1))
;; = 2 * 2 * ... * 2
;; g(n) = 2^n

(define (h n) (A 2 n))
;; 2^2^2 or 2^h(n-1)
;; A(2, n - 0)
;; = A(1, A(2, n-1))
;; = A(1, A(1, A(2, n-2))
;; = A(1, A(1, A(1, ... A(1, A(2, n-(n-1))))
;; h(n) = 2^2^2....2 (2의 갯수는 n개)
;; h(n) = pow(2, h(n-1))

(define (k n) (* 5 n n))
;; k(n) = 5n^2


;; Primitive Recursive Function = 반복 횟수가 미리 정해져 있어서 for문 같은 단순 반복으로 구현 가능 (factorial같은거)
;; Ackermann은 'for' 문 같은 구조로는 표현할 수 없는 함수도 있다는걸 보여주기 위해 Ackermann함수를 만듬.
;; 재귀 깊이가 입력값에 따라 아주 빠르게 늘어나서, 고정된 반복 횟수로 미리 제한하는 'for'문으로는 표현하기 힘듬.
;;
;; ref:
;;   - https://en.wikipedia.org/wiki/Ackermann_function
;;   - https://plato.stanford.edu/Entries/recursive-functions/ackermann-peter.html
;;   - https://sites.google.com/site/pointlesslargenumberstuff/home/2/ackermann

;; Ackermann original function
(define (φ x y z)
  ;; φ(x, y, 0) = x + y
  ;; φ(x, 0, z) = α(x, z-1)
  ;; φ(x, y, z) = φ(x, φ(x, y-1, z) z-1)
  (cond ((= z 0) (+ x y))
        ((= y 0) (α x (- z 1)))
        (else    (φ x (φ x (- y 1) z) (- z 1)))))

(define (α x y)
  ;; α(x, 0) = 0
  ;; α(x, 1) = 1
  ;; α(x, y) = x
  (cond ((= y 0) 0)
        ((= y 1) 1)
        (else    x)))

;; Ackermann-Peter function
(define (C m n)
  ;; C(0, n) = n+1
  ;; C(m, 0) = C(m-1, 1)
  ;; C(m, n) = C(m-1, C(m, n-1))
  (cond ((= m 0) (+ n 1))
        ((= n 0) (C (- m 1) 1))
        (else    (C (- m 1) (C m (- n 1))))))

(trace:trace φ)
(trace:trace C)
(φ 1 2 3)
(C 2 1)

1_11

;; file: 1_11.rkt
(#%require (prefix racket: racket))
(#%require rackunit)

;; n <  3 : f(n) = n                        
;; n >= 3 : f(n) = f(n-1) + 2f(n-2) + 3f(n-3)   

(define (f-recur n)
  (cond ((< n 3) n)
        (else    (+ (f-recur (- n 1))
                    (* 2 (f-recur (- n 2)))
                    (* 3 (f-recur (- n 3)))))))



;;      |  p1    |   p2    |   p3   |
;; f(n) = f(n-1) + 2f(n-2) + 3f(n-3)
;; ...
;; f(4) = f(3) + 2f(2) + 3f(1) = (2 + 2*1 + 3*0) + 2*2 + 3*1 = 11
;; f(3) = f(2) + 2f(1) + 3f(0) =  2              + 2*1 + 3*0 = 4
;; f(2) = 2
;; f(1) = 1
;; f(0) = 0

(define (iter curr-n target-n fn-1 fn-2 fn-3)
  (let ((next-fn-1 (+ fn-1 (* 2 fn-2) (* 3 fn-3)))
        (next-fn-2 fn-1)
        (next-fn-3 fn-2))
    (if (= curr-n target-n)
        next-fn-1
        (iter (inc curr-n) target-n next-fn-1 next-fn-2 next-fn-3))))

(define (f-iter n)
  (if (< n 3)
      n
      (iter 3 n 2 1 0)))

(racket:for ([i 20])
            (check-eq? (f-recur i)(f-iter i)))

1_12

;; file: 1_12.rkt
(#%require (prefix racket: racket))

;; 파스칼 삼각형

(define (P x y)
  (cond ((zero? x) 1)
        ((= x y)   1)
        (else      (+ (P (- x 1) y)
                      (P (- x 1) (- y 1))))))


(racket:for ([y (racket:in-inclusive-range 0 5)])
            (display y)
            (display ": ")
            (racket:for ([x (racket:in-inclusive-range 0 y)])
                        (display (P x y))
                        (display " "))
            (newline))
;;>> 0: 1 
;;>> 1: 1 1 
;;>> 2: 1 2 1 
;;>> 3: 1 2 4 1 
;;>> 4: 1 2 4 8 1 
;;>> 5: 1 2 4 8 16 1

1_13

;; file: 1_13.rkt

(#%require (prefix racket: racket))
(#%require threading)
(#%require rackunit)

;; ==============================================================
;; - 특성방정식(Characteristic equation)
;;   - https://en.wikipedia.org/wiki/Characteristic_equation_(calculus)
;;   - 선형 점화식의 일반해를 구하기 위해 도입하는 보조적인 다항방정식
;;     - 즉, 쉽게 구할 수 있는걸로 바꿔 계산하자임.
;;   - 제약조건
;;     - 선형(linear)
;;       - 곱하기, 더하기만 있음.(항들 사이에 곱하거나 제곱하지 않음)
;;       - 안되는 경우: F(n)=F(n−1)*F(n−2) (항 들 사이에 곱했음)
;;     - 상수 계수(with constant coefficients)
;;       - 계수들이 모두 상수여야 함 (즉, n에 따라 변하면 안 됨)
;;       - 안되는 경우: F(n)=n*F(n−1)+F(n−2) (n에 따라 변함)
;;     - 동차(homogeneous)
;;       - 오른쪽에 독립적인 항이 없음
;;       - 안되는 경우: F(n)=F(n−1)+F(n−2)+1 (오른쪽에 상수, n, 2^n, +5 같은 추가적인 항이 붙어 있으면 비동차)
;; - 근의 공식(quadratic equation)
;;   - https://en.wikipedia.org/wiki/Quadratic_equation
;; - (1+√5)/2
;;   - 황금비(golden ratio): https://en.wikipedia.org/wiki/Golden_ratio
;; - 비넷공식(binet formula)
;;   - https://en.wikipedia.org/wiki/Fibonacci_sequence#Binet's_formula
;; - 귀납법(induction)
;;   - https://en.wikipedia.org/wiki/Mathematical_induction
;;   - 歸納(돌아갈 귀, 들일 납)
;;   - 개별적인 사실들로부터 일반적인 결론을 이끌어내는  
;;   - 기저 사례(Base Case): 증명하고자 하는 명제가 특정 초기 값에 대해 참임을 보이는 단계
;;   - 귀납 단계(Induction Step): 특정 수 n에 대해 명제가 참이라고 가정하고 (귀납 가설), 이를 이용하여 n+1에 대해서도 명제가 참임을 증명.


;; ==============================================================
;; 1. Fib(n)이 (φ^n)/√5에 가까운 정수임을 증명해라. (φ = (1+√5)/2, ψ = (1−√5)/2)
;;
;; # 1.1: 일반적인 접근법
;;
;; ## Fib는 특성방정식을 만족함.(선형/상수계수/동차를 만족함)
;; F(n) = F(n−1) + F(n−2)
;;
;; Fib(n) = x^n 이라 바꿔 계산하면.
;; x^n           = x^(n-1)         + x^(n-2)
;; x^n / x^(n-2) = x^(n-1)/x^(n-2) + x^(n-2)/x^(n-2)
;;
;; x^2         = x + 1
;; x^2 - x - 1 = 0
;;
;; 근의 공식으로 풀면
;; x = (1+√5)/2 = φ
;; x = (1-√5)/2 = ψ
;;
;;
;; ## Binet공식: F(n)= (φ^n - ψ^n)/√5
;; 앞서구한 해 φ와 ψ로 F(n)을 나타내면
;; F(n)     = Aφ^n + Bψ^n
;; F(0) = 0 = A + B       | 즉, A = -B
;; F(1) = 1 = Aφ + Bψ
;;          = Aφ - Aψ
;;          = A(φ - ψ)
;;
;; A =  1/(φ - ψ)
;; B = -1/(φ - ψ)
;;
;; φ - ψ = (1+√5)/2 - (1-√5)/2
;;       = 2√5/2
;;       = √5
;;
;; A =  1/√5
;; B = -1/√5
;;
;; F(n) = Aφ^n     + Bψ^n
;;      = 1/√5*φ^n - 1/√5*ψ^n
;;      = (φ^n - ψ^n)/√5
;;
;;
;; # 1.2: G(n)을 도입한 다른 접근법
;;
;; φ + ψ = 1
;; φ - ψ = √5
;; φ * ψ = -1
;; 
;; F(n+2)            = (φ+ψ)*F(n+1) - (φ*ψ)*F(n)
;; F(n+2) - φ*F(n+1) = ψ*(F(n+1) - φ*F(n))
;;
;;
;; ## G(n) 정의
;;
;; G(n  ) = F(n+1) - φ*F(n)
;; G(n+1) = ψ*G(n)
;; G(0)   = F(1)   - φ*F(0)
;;        = 1      - φ*0
;;        = 1
;;        = ψ^0
;; G(1)   = ψ*G(0)
;;        = ψ^1
;; G(n)   = ψ^n
;;        = F(n+1) - φ*F(n)
;;
;; ## 역전개하여 F(n+1) 유도
;; F(n+1) - φ*F(n) = ψ^n
;;
;; F(n+1) = φ*F(n)                             + ψ^n
;;        = φ(φ*F(n-1)             + ψ^(n-1))  + ψ^n
;;        = φ^2*F(n-1)                         + ψ^n + φ*ψ^(n-1)
;;        = φ^3*F(n-2)                         + ψ^n + φ*ψ^(n-1) + φ*ψ^(n-2)
;;        = ...
;;        = φ^(n+1)*F(0)                       + sum(k=0~n, φ^(n-k)*ψ^k)
;;        = φ^(n+1)*0                          + sum(k=0~n, φ^(n-k)*ψ^k)
;;        = sum(k=0~n, φ^(n-k)*ψ^k)
;;        = φ^n * sum(k=0~n, (ψ/φ)^k)                                |  sum(k=0~n, r^k) = (1-r^(n+1)) / (1-r)
;;        = φ^n * (1-(ψ/φ)^(n+1))            / (1-(ψ/φ))
;;        = φ^n * (1-(ψ/φ)^(n+1)) * φ^(n+1)  / (1-(ψ/φ)) * φ^(n+1)
;;        = φ^n * (φ^(n+1) - ψ^(n+1))        / (φ^(n+1) - (ψ * φ^n))
;;        = (φ^(n+1) - ψ^(n+1)) / (φ - ψ)
;;        = (φ^(n+1) - ψ^(n+1)) / √5
;;
;; 따라서
;; F(n)   = (φ^n - ψ^n) / √5
;;
;;
;; ## 1.3: Fib(n)이 (φ^n)/√5에 가까운 정수임을 증명.
;;
;; ψ = (1-√5)/2
;;   = −0.6180339887...
;; |ψ^0|/√5 = 0.447....  | 1/2 보다 작음.
;; |ψ^1|/√5 = 0.276....
;; ...
;; |ψ^n|/√5 = 0.000....  | 0으로 수렴
;; |ψ^n|/√5 = 1/2보다 작고 0으로 수렴.
;;
;; F(n)  = (φ^n     -  ψ^n)/√5
;;       = (φ^n)/√5 - (ψ^n)/√5
;;      ~= (φ^n)/√5            | (ψ^n)/√5 은 0으로 수렴함으로.
;;      ~= (φ^n)/√5            | 따라서 F(n)은 (φ^n)/√5에 가까운 정수.
;;
;; 더 나가자면 |ψ^n|/√5 는 항상 1/2보다 작고 0으로 수렴하므로,
;; 오차는 round 함수의 오차 허용 한계인 0.5보다 항상 작다.
;; 따라서
;;
;; F(n) = round((φ^n)/√5)
;;

;; ==============================================================
;; 2. Fib의 정의로 Fib(n) = (φ^n – ψ^n)/√5 임을 induction으로 밝혀라
;;
;; ## 기저 사례(Base case)
;;
;; n = 0 일때 성립
;; (φ^0 – ψ^0)/√5 = (1 - 1)/√5
;;                = 0
;;
;; n = 1 일때 성립
;; (φ^1 – ψ^1)/√5 = (φ – ψ)/√5
;;                = ((1+√5)/2) - (1-√5)/2) /√5
;;                = (√5/2 + √5/2)/√5
;;                = 1
;;
;; ## 귀납단계(Induction Step)
;;
;; Fib(n  ) = (φ^(n-0) – ψ^(n-0))/√5
;; Fib(n-1) = (φ^(n-1) – ψ^(n-1))/√5
;; Fib(n+1) = Fib(n)         + Fib(n-1)
;;          = (φ^n – ψ^n)/√5 + (φ^(n-1) – ψ^(n-1))/√5
;;          = (φ^n + φ^(n-1)) – (ψ^n + ψ^(n-1)) /√5
;;
;; φ   =  (1+√5)/2
;; φ^2 =  (1 + 2√5 + 5)/4
;;     =  (6 + 2√5)/4
;;     = 2(3 + √5)/4
;;     =  (3 + √5)/2
;;     = (1+√5)/2 + 1
;;     = φ + 1
;;
;; (φ^n + φ^(n-1)) = φ^(n-1) * (φ + 1)
;;                 = φ^(n-1) * φ^2
;;                 = φ^(n+1)
;; (ψ^n + ψ^(n-1)) = ψ^(n+1)
;;
;; 따라서 Fib(n+1) = (φ^(n+1) - ψ^(n+1)) /√5
;;
;; ## 결론.
;; 기저 사례와 귀납 단계를 통해 Fib(n) = (φ^n – ψ^n)/√5 이다.





(define (fib n)
  (fib-iter 1 0 n))

(define (fib-iter a b count)
  (if (= count 0)
      b
      (fib-iter (+ a b) a (- count 1))))

(define (fib-binet n)
  (let* ((root-5 (sqrt 5))
         (φ (/ (+ 1 root-5) 2))
         (ψ (/ (- 1 root-5) 2)))
    (~> (- (expt φ n) (expt ψ n))
        (/ root-5)
        (round-half-up))))

(define (round-half-up x)
  ;; racket:exact-floor는 IEEE-754 방식(일명 "round half to even" 또는 bankers' rounding)을 사용
  ;; Round half up은 0.5이상 일때 무조건 올림.
  (cond ((zero? x) 0)
        ((positive? x) (racket:exact-floor (+ x 0.5)))
        (else          (racket:exact-floor (- x 0.5)))))

(racket:for ([x (racket:in-inclusive-range 1 75)])
            ;; 부동소수점 정밀도의 한계로 에러가 발생.
            (check-eq? (fib x) (fib-binet x) (racket:~a x)))

1_14

  • 1.2.2에서 나온 count-change 함수가 11 센트(cent)에 맞게 잔돈을 만들어내는 트리를 그려보아라.
%%{init: {'flowchart' : {'curve' : 'monotoneX'}}}%%
graph TD
  cc_11_05_a["(cc 11 5)"] --> cc_11_04_a["(cc 11 4)"]
  cc_11_04_a --> cc_11_03_a["(cc 11 3)"]
  cc_11_03_a --> cc_11_02_a["(cc 11 2)"]
  cc_11_02_a --> cc_11_01_a["(cc 11 1)"]
  cc_11_01_a --> cc_11_00_a["(cc 11 0)"]
  cc_11_01_a --> cc_10_01_a["(cc 10 1)"]
  cc_10_01_a --> cc_10_00_a["(cc 10 0)"]
  cc_10_01_a --> cc_09_01_a["(cc 9 1)"]
  cc_09_01_a --> cc_09_00_a["(cc 9 0)"]
  cc_09_01_a --> cc_08_01_a["(cc 8 1)"]
  cc_08_01_a --> cc_08_00_a["(cc 8 0)"]
  cc_08_01_a --> cc_07_01_a["(cc 7 1)"]
  cc_07_01_a --> cc_07_00_a["(cc 7 0)"]
  cc_07_01_a --> cc_06_01_a["(cc 6 1)"]
  cc_06_01_a --> cc_06_00_a["(cc 6 0)"]
  cc_06_01_a --> cc_05_01_a["(cc 5 1)"]
  cc_05_01_a --> cc_05_00_a["(cc 5 0)"]
  cc_05_01_a --> cc_04_01_a["(cc 4 1)"]
  cc_04_01_a --> cc_04_00_a["(cc 4 0)"]
  cc_04_01_a --> cc_03_01_a["(cc 3 1)"]
  cc_03_01_a --> cc_03_00_a["(cc 3 0)"]
  cc_03_01_a --> cc_02_01_a["(cc 2 1)"]
  cc_02_01_a --> cc_02_00_a["(cc 2 0)"]
  cc_02_01_a --> cc_01_01_a["(cc 1 1)"]
  cc_01_01_a --> cc_01_00_a["(cc 1 0)"]
  cc_01_01_a --> cc_00_01_a["(cc 0 1)"]

  cc_11_02_a --> cc_06_02_a["(cc 6 2)"]
  cc_06_02_a --> cc_06_01_b["(cc 6 1)"]
  cc_06_01_b --> cc_06_00_b["(cc 6 0)"]
  cc_06_01_b --> cc_05_01_b["(cc 5 1)"]
  cc_05_01_b --> cc_05_00_b["(cc 5 0)"]
  cc_05_01_b --> cc_04_01_b["(cc 4 1)"]
  cc_04_01_b --> cc_04_00_b["(cc 4 0)"]
  cc_04_01_b --> cc_03_01_b["(cc 3 1)"]
  cc_03_01_b --> cc_03_00_b["(cc 3 0)"]
  cc_03_01_b --> cc_02_01_b["(cc 2 1)"]
  cc_02_01_b --> cc_02_00_b["(cc 2 0)"]
  cc_02_01_b --> cc_01_01_b["(cc 1 1)"]
  cc_01_01_b --> cc_01_00_b["(cc 1 0)"]
  cc_01_01_b --> cc_00_01_b["(cc 0 1)"]

  cc_06_02_a --> cc_01_02_a["(cc 1 2)"]
  cc_01_02_a --> cc_01_01_c["(cc 1 1)"]
  cc_01_01_c --> cc_01_00_c["(cc 1 0)"]
  cc_01_01_c --> cc_00_01_c["(cc 0 1)"]
  cc_01_02_a --> cc_m4_02["(cc -4 2)"]

  cc_11_03_a --> cc_01_03_a["(cc 1 3)"]
  cc_01_03_a --> cc_01_02_b["(cc 1 2)"]
  cc_01_02_b --> cc_01_01_d["(cc 1 1)"]
  cc_01_01_d --> cc_01_00_d["(cc 1 0)"]
  cc_01_01_d --> cc_00_01_d["(cc 0 1)"]
  cc_01_02_b --> cc_m4_02_b["(cc -4 2)"]

  cc_01_03_a --> cc_m9_03["(cc -9 3)"]

  cc_11_04_a --> cc_m14_04["(cc -14 4)"]

  cc_11_05_a --> cc_m39_05["(cc -39 5)"]

  classDef highlightNode fill:#ffcccc,stroke:#cc0000,stroke-width:2px;
  class cc_00_01_a highlightNode;
  class cc_00_01_b highlightNode;
  class cc_00_01_c highlightNode;
  class cc_00_01_d highlightNode;

;; file: 1_14.rkt
(#%require (prefix trace: racket/trace))

;; 1.2.2: count-change
(define (count-change amount)
  (cc amount 5))

(define (cc amount kinds-of-coins)
  (cond ((= amount 0)
         1)
        ((or (< amount 0) (= kinds-of-coins 0))
         0)
        (else
         (+ (cc amount (- kinds-of-coins 1))
            (cc (- amount (first-denomination kinds-of-coins)) kinds-of-coins)))))

(define (first-denomination kinds-of-coins)
  (cond ((= kinds-of-coins 1) 1)
        ((= kinds-of-coins 2) 5)
        ((= kinds-of-coins 3) 10)
        ((= kinds-of-coins 4) 25)
        ((= kinds-of-coins 5) 50)))

(count-change 100)
;;=> 292

(trace:trace cc)
(count-change 11)
;;=> 4
;;
;; 1. 10x 1 +  1x 1
;; 2.  5x 1 +  1x 6
;; 3.  5x 2 +  1x 1
;; 4.  1x11

;; amount가 증가함에 따라 사용되는 공간과 수행 단계의 증가 차수는?
;;
;; 1. 수행 단계 수 (시간 복잡도)
;; - https://en.wikipedia.org/wiki/Time_complexity
;;
;; - 얼핏보면: O(2^n)
;;   - cc안에서 cc가 두번 호출. 호출 트리가 이진 트리처럼 보임
;; - 사실은: O(n^5)
;;   - amount뿐만 아니라 동전 종류도 고려되야함.
;;   - 그리고 cc를 보면 중복호출하는데 이 중복 계산도 포함하게 되면 - O(n^k)
;;   - 메모이제이션이나 동적 계획법으로 풀면 O(n*k) 복잡도는 줄어들 수 있음.
;;
;; 2. 공간 사용량 (공간 복잡도)
;; - https://en.wikipedia.org/wiki/Space_complexity
;;
;; - 선형 O(n)
;;   - amount가 지속적 감소 ( 최대 호출 스택 깊이 )

1_15

;; file: 1_15.rkt
(#%require (prefix trace: racket/trace))

(define (cube x)
  (* x x x))

(define (p x)
  (- (* 3 x)
     (* 4 (cube x))))

(define (sine angle)
  (if (not (> (abs angle) 0.1))
      angle
      (p (sine (/ angle 3.0)))))

(trace:trace p)
(trace:trace sine)

;; 1. (sine 12.15)가 호출되면 p가 몇번 호출되나?
;; sine에서 angle을 3.0으로 계속 나누고 탈출조건은 |angle| < 0.1이니
;;
;; |12.15/3^(x - 1)} < 0.1
;; |3^(x - 1)|       < 121.5
;; 3^4=81
;; 3^5=243
;; 따라서 x = 5

;; (/ 12.15 3)               4.05
;; (/ 4.05 3)                1.3499999999999999
;; (/ 1.3499999999999999 3)  0.44999999999999996
;; (/ 0.44999999999999996 3) 0.15
;; (/ 0.15 3)                0.049999999999999996

(sine 12.15)
;;>> >{sine 12.15}
;;>> > {sine 4.05}
;;>> > >{sine 1.3499999999999999}
;;>> > > {sine 0.44999999999999996}
;;>> > > >{sine 0.15}
;;>> > > > {sine 0.049999999999999996}
;;>> < < < 0.049999999999999996
;;>> > > >{p 0.049999999999999996}        --- 1
;;>> < < <0.1495
;;>> > > {p 0.1495}                       --- 2
;;>> < < 0.4351345505
;;>> > >{p 0.4351345505}                  --- 3
;;>> < <0.9758465331678772
;;>> > {p 0.9758465331678772}             --- 4
;;>> < -0.7895631144708228
;;>> >{p -0.7895631144708228}             --- 5
;;>> <-0.39980345741334
;;=> -0.39980345741334


;; 2. (sine a)를 계산시 시간 복접도와 공간 복잡도를 a로 표현.
;;
;; 깊이 - 여기선 시간복잡도, 공간사용량도 깊이랑 같음.
;; a/3^n < 0.1
;; 3^n   > 10a
;; n     > log3(10a)
;;
;; - 수행 단계 수 (시간 복잡도): O(log(a))
;; - 공간 사용량  (공간 복잡도): O(log(a))

1_16

;; file: 1_16.rkt
;; 1_16 / 1_17 / 1_18
(#%require threading)
(#%require rackunit)
(#%require profile)

;; fast-expt를 iterate하게 바꿔라


(define (square x)
  (* x x))

(define (fast-expt b n)
  (cond (( = n 0)
         1)
        ((even? n)
         (square (fast-expt b (/ n 2))))
        (else
         (* b (fast-expt b (- n 1))))))

(define (fast-expt-iter b n)
  (define (iter acc b n)
    (cond (( = n 0)
           acc)
          ((even? n)
           (iter acc (square b) (/ n 2)))
          (else
           (iter (* acc b) b (- n 1)))))
  (iter 1 b n))

(~> (fast-expt 2 0)
    (check-equal? 1))
(~> (fast-expt 2 1)
    (check-equal? 2))
(~> (fast-expt 2 5)
    (check-equal? 32))
(~> (fast-expt 2 10)
    (check-equal? 1024))


(~> (fast-expt-iter 2 0)
    (check-equal? 1))
(~> (fast-expt-iter 2 1)
    (check-equal? 2))
(~> (fast-expt-iter 2 5)
    (check-equal? 32))
(~> (fast-expt-iter 2 10)
    (check-equal? 1024))

1_17

;; file: 1_17.rkt
;; 1_16 / 1_17 / 1_18

(#%require rackunit)

;; Mul구현. fast-expt처럼 계산단계가 로그로 자라도록 짜라.

(define (double x)
  (* 2 x))

(define (halve x)
  (/ x 2))

(define (mul a b)
  (if (= b 0)
      0
      (+ a (mul a (- b 1)))))

(define (fast-mul a b)
  (cond ((= b 0)
         0)
        ((even? b)
         (double (fast-mul a (halve b))))
        (else
         (+ a (fast-mul a (- b 1))))))


(check-equal? (mul 2 0)  0)
(check-equal? (mul 2 1)  2)
(check-equal? (mul 2 2)  4)
(check-equal? (mul 2 10) 20)
(check-equal? (mul 2 11) 22)

(check-equal? (fast-mul 2 0)  0)
(check-equal? (fast-mul 2 1)  2)
(check-equal? (fast-mul 2 2)  4)
(check-equal? (fast-mul 2 10) 20)
(check-equal? (fast-mul 2 11) 22)

1_18

;; file: 1_18.rkt
;; 1_16 / 1_17 / 1_18

(#%require rackunit)

;; Mul구현. 1.16와 1.17를 합쳐 계산 단계가 로그로 자라되 iterative형태로 짜라.

(define (double x)
  (* 2 x))

(define (halve x)
  (/ x 2))


(define (fast-mul-iter a b)
  (define (iter acc a b)
    (cond ((= b 0)
           acc)
          ((even? b)
           (iter acc (double a) (halve b)))
          (else
           (iter (+ acc a) a (- b 1)))))
  (iter 0 a b))


(check-equal? (fast-mul-iter 2 0)  0)
(check-equal? (fast-mul-iter 2 1)  2)
(check-equal? (fast-mul-iter 2 2)  4)
(check-equal? (fast-mul-iter 2 10) 20)
(check-equal? (fast-mul-iter 2 11) 22)

1_19

;; file: 1_19.rkt
(#%require racket/trace)

;; 빈칸체우기
#|
T(a, b) - p/q에 대해서
a' = bq + aq + ap
b' = bp + aq

T(T(a, b)) - p/q에 대해서
a'' =         b'q +             a'q +             a'p
    = ((bp + aq)q + (bq + aq + ap)q + (bq + aq + ap)p
    =  bpq + aq^2 + bq^2 + aq^2 + aqp + bqp + aqp + ap^2
    = b(2qp + q^2)+    a(q^2 + p^2) +    a(2qp + q^2)
b'' =          b'p +             a'q
    =   (bp + aq)p + (bq + aq + ap)q
    =   bp^2 + aqp + bq^2 + aq^2 + aqp
    = b(p^2 + q^2) +    a(2qp + q^2)

p' = p^2 + q^2
q' = 2qp + q^2

|#


(define (fib-recur n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fib-recur (- n 1))
                 (fib-recur (- n 2))))))

(define (fast-fib-iter n)
  (fib-iter 1 0 0 1 n))

(define (fib-iter a b p q count)
  (cond ((= count 0)
         b)
        ((even? count)
         (fib-iter a
                   b
                   (+ (* p p) (* q q))   ; p' = p^2 + q^2
                   (+ (* 2 p q) (* q q)) ; q' = 2qp + q^2
                   (/ count 2)))
        (else 
         (fib-iter (+ (* b q) (* a q) (* a p)) ; a = bq + aq + ap
                   (+ (* b p) (* a q))         ; b = bp + aq
                   p
                   q
                   (- count 1)))))
#|

| fib | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10|
|-----|---|---|---|---|---|---|---|---|---|---|---|
| res | 0 | 1 | 1 | 2 | 3 | 5 | 8 | 13| 21| 34| 55|

|#

(fib-recur 10)

(fast-fib-iter 10)

#|
(trace fib-iter)

>{fib-iter 1 0 0 1 10}
>{fib-iter 1 0 1 1 5}
>{fib-iter 2 1 1 1 4}
>{fib-iter 2 1 2 3 2}
>{fib-iter 2 1 13 21 1}
>{fib-iter 89 55 13 21 0}
<55
|#

1_20

;; file: 1_20.rkt

1_21

;; file: 1_21.rkt

1_22

;; file: 1_22.rkt

1_23

;; file: 1_23.rkt

1_24

;; file: 1_24.rkt

1_25

;; file: 1_25.rkt

1_26

;; file: 1_26.rkt

1_27

;; file: 1_27.rkt

1_28

;; file: 1_28.rkt

1_29

;; file: 1_29.rkt

1_30

;; file: 1_30.rkt

1_31

;; file: 1_31.rkt

1_32

;; file: 1_32.rkt

1_33

;; file: 1_33.rkt

1_34

;; file: 1_34.rkt

1_35

;; file: 1_35.rkt

1_36

;; file: 1_36.rkt

1_37

;; file: 1_37.rkt

1_38

;; file: 1_38.rkt

1_39

;; file: 1_39.rkt

1_40

;; file: 1_40.rkt

1_41

;; file: 1_41.rkt

1_42

;; file: 1_42.rkt

1_43

;; file: 1_43.rkt

1_44

;; file: 1_44.rkt

1_45

;; file: 1_45.rkt

1_46

;; file: 1_46.rkt

연습문제 풀이 02

2_01

;; file: 2_01.rkt

2_02

;; file: 2_02.rkt

2_03

;; file: 2_03.rkt

2_04

;; file: 2_04.rkt

2_05

;; file: 2_05.rkt

2_06

;; file: 2_06.rkt

2_07

;; file: 2_07.rkt

2_08

;; file: 2_08.rkt

2_09

;; file: 2_09.rkt

2_10

;; file: 2_10.rkt

2_11

;; file: 2_11.rkt

2_12

;; file: 2_12.rkt

2_13

;; file: 2_13.rkt

2_14

;; file: 2_14.rkt

2_15

;; file: 2_15.rkt

2_16

;; file: 2_16.rkt

2_17

;; file: 2_17.rkt
;; 2_17 / 4_62 / 4_63 / 4_69

2_18

;; file: 2_18.rkt

2_19

;; file: 2_19.rkt

2_20

;; file: 2_20.rkt

2_21

;; file: 2_21.rkt

2_22

;; file: 2_22.rkt

2_23

;; file: 2_23.rkt

2_24

;; file: 2_24.rkt

2_25

;; file: 2_25.rkt

2_26

;; file: 2_26.rkt

2_27

;; file: 2_27.rkt

2_28

;; file: 2_28.rkt

2_29

;; file: 2_29.rkt

2_30

;; file: 2_30.rkt

2_31

;; file: 2_31.rkt

2_32

;; file: 2_32.rkt

2_33

;; file: 2_33.rkt

2_34

;; file: 2_34.rkt

2_35

;; file: 2_35.rkt

2_36

;; file: 2_36.rkt

2_37

;; file: 2_37.rkt

2_38

;; file: 2_38.rkt

2_39

;; file: 2_39.rkt

2_40

;; file: 2_40.rkt

2_41

;; file: 2_41.rkt

2_42

;; file: 2_42.rkt
;; 2_42 / 4_44

;; TODO

2_43

;; file: 2_43.rkt

2_44

;; file: 2_44.rkt

2_45

;; file: 2_45.rkt

2_46

;; file: 2_46.rkt

2_47

;; file: 2_47.rkt

2_48

;; file: 2_48.rkt

2_49

;; file: 2_49.rkt

2_50

;; file: 2_50.rkt

2_51

;; file: 2_51.rkt

2_52

;; file: 2_52.rkt

2_53

;; file: 2_53.rkt

2_54

;; file: 2_54.rkt

2_55

;; file: 2_55.rkt

2_56

;; file: 2_56.rkt

2_57

;; file: 2_57.rkt

2_58

;; file: 2_58.rkt

2_59

;; file: 2_59.rkt

2_60

;; file: 2_60.rkt

2_61

;; file: 2_61.rkt

2_62

;; file: 2_62.rkt

2_63

;; file: 2_63.rkt

2_64

;; file: 2_64.rkt

2_65

;; file: 2_65.rkt

2_66

;; file: 2_66.rkt

2_67

;; file: 2_67.rkt

2_68

;; file: 2_68.rkt

2_69

;; file: 2_69.rkt

2_70

;; file: 2_70.rkt

2_71

;; file: 2_71.rkt

2_72

;; file: 2_72.rkt

2_73

;; file: 2_73.rkt

2_74

;; file: 2_74.rkt

2_75

;; file: 2_75.rkt

2_76

;; file: 2_76.rkt

2_77

;; file: 2_77.rkt

2_78

;; file: 2_78.rkt

2_79

;; file: 2_79.rkt

2_80

;; file: 2_80.rkt

2_81

;; file: 2_81.rkt

2_82

;; file: 2_82.rkt

2_83

;; file: 2_83.rkt

2_84

;; file: 2_84.rkt

2_85

;; file: 2_85.rkt

2_86

;; file: 2_86.rkt

2_87

;; file: 2_87.rkt

2_88

;; file: 2_88.rkt

2_89

;; file: 2_89.rkt

2_90

;; file: 2_90.rkt

2_91

;; file: 2_91.rkt

2_92

;; file: 2_92.rkt

2_93

;; file: 2_93.rkt

2_94

;; file: 2_94.rkt

2_95

;; file: 2_95.rkt

2_96

;; file: 2_96.rkt

2_97

;; file: 2_97.rkt

연습문제 풀이 03

3_01

;; file: 3_01.rkt

(#%require rackunit)

(define (make-accumulator initial-value)
  (let ((cached initial-value))
    (lambda (x)
      (set! cached (+ x cached))
      cached)))

(define A (make-accumulator 5))

(check-equal? (A 10) 15)
(check-equal? (A 10) 25)

3_02

;; file: 3_02.rkt

(#%require rackunit)

(define (make-monitored fn)
  (let ((call-count 0))
    (lambda (x)
      (if (eq? x 'how-many-calls?)
          call-count
          (let ((result (fn x)))
            (set! call-count (inc call-count))
            result)))))

(define s (make-monitored sqrt))

(check-equal? (s 100) 10)

(check-equal? (s 'how-many-calls?) 1)

3_03

;; file: 3_03.rkt
;; 3_03 / 3_04 / 3_07

(#%require rackunit)
(#%require (prefix racket: racket))
(racket:provide make-account)

(define (make-account balance initial-password)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (dispatch m)
    (cond ((eq? m 'withdraw) withdraw)
          ((eq? m 'deposit) deposit)
          (else (error "Unknown request -- MAKE-ACCOUNT"
                       m))))
  (define (password-dispatch password m)
    (if (not (eq? password initial-password))
        (lambda (amount)
          "Incorrect password")
        (dispatch m)))
  password-dispatch)

(define acc (make-account 100 'secret-password))

(check-equal? ((acc 'secret-password 'withdraw) 40) 60)

(check-equal? ((acc 'some-other-password 'deposit) 50) "Incorrect password")

3_04

;; file: 3_04.rkt
;; 3_03 / 3_04 / 3_07


(#%require rackunit)

(define (make-account balance initial-password)
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (call-the-cops amount)
    'call-the-cops)
  (define (dispatch m)
    (cond ((eq? m 'withdraw) withdraw)
          ((eq? m 'deposit) deposit)
          ((eq? m 'call-the-cops) call-the-cops)
          (else (error "Unknown request -- MAKE-ACCOUNT"
                       m))))
  (let ((wrong-password-count 0))
    (define (password-dispatch password m)
      (if (not (eq? password initial-password))
          (begin
            (set! wrong-password-count (inc wrong-password-count))
            (if (>= wrong-password-count 7)
                (dispatch 'call-the-cops)
                (lambda (amount)
                  "Incorrect password")))
          (dispatch m)))
    
    password-dispatch))

(define acc (make-account 100 'secret-password))

(check-equal? ((acc 'secret-password 'withdraw) 40) 60)

(check-equal? ((acc 'some-other-password 'deposit) 50) "Incorrect password")
(check-equal? ((acc 'some-other-password 'deposit) 50) "Incorrect password")
(check-equal? ((acc 'some-other-password 'deposit) 50) "Incorrect password")
(check-equal? ((acc 'some-other-password 'deposit) 50) "Incorrect password")
(check-equal? ((acc 'some-other-password 'deposit) 50) "Incorrect password")
(check-equal? ((acc 'some-other-password 'deposit) 50) "Incorrect password")
(check-equal? ((acc 'some-other-password 'deposit) 50) 'call-the-cops)

3_05

;; file: 3_05.rkt

3_06

;; file: 3_06.rkt
(#%require rackunit)

(define (rand-update x)
  (let ((a 27) (b 26) (m 127))
    (modulo (+ (* a x) b) m)))

(define random-init 7)

(define rand
  (let ((x random-init))
    (define (reset new-value)
      (set! x new-value))
    (define (generate)
      (set! x (rand-update x))
      x)
    (define (dispatch m)
      (cond ((eq? m 'generate)
             (generate))
            ((eq? m 'reset)
             reset)))
    dispatch))


(check-equal? (rand 'generate) 88)
(check-equal? (rand 'generate) 116)
(check-equal? (rand 'generate) 110)

((rand 'reset) 7)

(check-equal? (rand 'generate) 88)
(check-equal? (rand 'generate) 116)
(check-equal? (rand 'generate) 110)

3_07

;; file: 3_07.rkt
;; 3_03 / 3_04 / 3_07
(#%require rackunit)
(#%require (prefix racket: racket))
(racket:require (racket:only-in "3_03.rkt" make-account))


(define (make-joint account account-password new-password)
  (define (dispatch password m)
    (if (not (eq? password new-password))
        (lambda (amount)
          "Incorrect password")
        (account account-password m)))
  dispatch)

(define peter-acc (make-account 100 'open-sesame))
(check-equal? ((peter-acc 'open-sesame 'withdraw) 40) 60)

(define paul-acc
  (make-joint peter-acc 'open-sesame 'rosebud))

(check-equal? ((paul-acc 'rosebud 'withdraw) 40) 20)

3_08

;; file: 3_08.rkt

(#%require rackunit)
(define make-f nil)
(define f nil)

(define (make-f-1)
  (let ((cached 'undefined))
    (define (inner-f x)
      (if (eq? cached 'undefined)
          (begin
            (set! cached x)
            x)
          0))
    inner-f))

(set! make-f make-f-1)
(set! f (make-f))
(check-equal? (let ((x (f 0))
                    (y (f 1)))
                (+ x y))
              0)
(set! f (make-f))
(check-equal? (let ((y (f 1))
                    (x (f 0)))
                (+ x y))
              1)


(define (make-f-2)
  ((lambda (old)
     (define (inner-f x)
       (let ((temp old))
         (set! old x)
         temp))
     inner-f)
   0))

(set! make-f make-f-2)
(set! f (make-f))
(check-equal? (let ((x (f 0))
                    (y (f 1)))
                (+ x y))
              0)
(set! f (make-f))
(check-equal? (let ((y (f 1))
                    (x (f 0)))
                (+ x y))
              1)

3_09

;; file: 3_09.rkt

3_10

;; file: 3_10.rkt

3_11

;; file: 3_11.rkt

3_12

;; file: 3_12.rkt
;; 3_12 / 5_22
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

;; TODO

(define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))

(define (append! x y)
  (set-cdr! (last-pair x) y)
  x)

(define (last-pair x)
  (if (null? (cdr x))
      x
      (last-pair (cdr x))))

(define x1 '(1 2))
(define y1 '(3 4))
(check-equal? (append x1 y1)
              '(1 2 3 4))
(check-equal? x1 '(1 2))
(check-equal? y1 '(3 4))

(define x2 '(1 2))
(define y2 '(3 4))
(check-equal? (append! x2 y2)
              '(1 2 3 4))
(check-equal? x2 '(1 2 3 4))
(check-equal? y2 '(3 4))

3_13

;; file: 3_13.rkt

3_14

;; file: 3_14.rkt

3_15

;; file: 3_15.rkt

3_16

;; file: 3_16.rkt

3_17

;; file: 3_17.rkt

3_18

;; file: 3_18.rkt

3_19

;; file: 3_19.rkt

3_20

;; file: 3_20.rkt

3_21

;; file: 3_21.rkt

3_22

;; file: 3_22.rkt

3_23

;; file: 3_23.rkt

3_24

;; file: 3_24.rkt

3_25

;; file: 3_25.rkt

3_26

;; file: 3_26.rkt

3_27

;; file: 3_27.rkt

3_28

;; file: 3_28.rkt

3_29

;; file: 3_29.rkt

3_30

;; file: 3_30.rkt

3_31

;; file: 3_31.rkt

3_32

;; file: 3_32.rkt

3_33

;; file: 3_33.rkt

3_34

;; file: 3_34.rkt

3_35

;; file: 3_35.rkt

3_36

;; file: 3_36.rkt

3_37

;; file: 3_37.rkt

3_38

;; file: 3_38.rkt

3_39

;; file: 3_39.rkt

3_40

;; file: 3_40.rkt

3_41

;; file: 3_41.rkt

3_42

;; file: 3_42.rkt

3_43

;; file: 3_43.rkt

3_44

;; file: 3_44.rkt

3_45

;; file: 3_45.rkt

3_46

;; file: 3_46.rkt

3_47

;; file: 3_47.rkt

3_48

;; file: 3_48.rkt

3_49

;; file: 3_49.rkt

3_50

;; file: 3_50.rkt

3_51

;; file: 3_51.rkt

3_52

;; file: 3_52.rkt

3_53

;; file: 3_53.rkt

3_54

;; file: 3_54.rkt

3_55

;; file: 3_55.rkt

3_56

;; file: 3_56.rkt

3_57

;; file: 3_57.rkt

3_58

;; file: 3_58.rkt

3_59

;; file: 3_59.rkt

3_60

;; file: 3_60.rkt

3_61

;; file: 3_61.rkt

3_62

;; file: 3_62.rkt

3_63

;; file: 3_63.rkt

3_64

;; file: 3_64.rkt

3_65

;; file: 3_65.rkt

3_66

;; file: 3_66.rkt

3_67

;; file: 3_67.rkt

3_68

;; file: 3_68.rkt

3_69

;; file: 3_69.rkt

3_70

;; file: 3_70.rkt

3_71

;; file: 3_71.rkt

3_72

;; file: 3_72.rkt

3_73

;; file: 3_73.rkt

3_74

;; file: 3_74.rkt

3_75

;; file: 3_75.rkt

3_76

;; file: 3_76.rkt

3_77

;; file: 3_77.rkt

3_78

;; file: 3_78.rkt

3_79

;; file: 3_79.rkt

3_80

;; file: 3_80.rkt

3_81

;; file: 3_81.rkt

3_82

;; file: 3_82.rkt

연습문제 풀이 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 $를 추론할 수 있을 것이다”와 같은 문맥에서의 추론 문제를 해결하는 방법과 연관 지을 수 있습니까?
  (이 문제는 개방형입니다. 좋은 답변은 아마도 박사 학위 수준의 가치를 가질 것입니다.)

|#

연습문제 풀이 05

5_01

;; file: 5_01.rkt
;; 5_01 / 5_02

;;
;; ref:
;; Figure 5.3: A specification of the GCD machine. (data-path + controller)
;; Figure 5.4: A GCD machine that reads inputs and prints results. (gdc + read / print)
;; 5.2 A Register-Machine Simulator - (define gcd-machine ...)


;; TODO Draw data-path and controller diagrams for this machine.
'(define (factorial n)
   (define (iter product counter)
     (if (> counter n)
         product
         (iter (* counter product)
               (+ counter 1))))
   (iter 1 1))

5_02

;; file: 5_02.rkt
;; 5_01 / 5_02

;; register-machine언어를 사용하여 iterative factorial 머신을 기술하라(연습문제 5.1에서  만든)

'(define (factorial n)
   (define (iter product counter)
     (if (> counter n)
         product
         (iter (* counter product)
               (+ counter 1))))
   (iter 1 1))

'(data-paths
  (registers
   ((name n))
   ((name product)
    (buttons ((name product<-1) 
              (source (constant 1)))
             ((name product<-mul) 
              (source (operation *)))))
   ((name count)
    (buttons ((name counter<-1) 
              (source (constant 1)))
             ((name counter<-add)
              (source (operation +))))))
  (operations
   ((name factorial)
    (inputs (register n)))
   ((name iter)
    (inputs (constant 1) (constant 1)))
   ((name >)
    (inputs (register a) (register b)))
   ((name *)
    (inputs (register a) (register b)))
   ((name +)
    (inputs (register a) (constant 0)))))

'(controller
  (assign n (op read))
  
  (assign product (const 1))
  (assign counter (const 1))
  
  loop-iter
  (test (op =) (reg counter) (reg n))
  (branch
   (label done-iter))
  
  (assign product (op *) (reg counter) (reg product))
  (assign counter (op +) (reg counter) (const 1))
  (goto
   (label loop-iter))
  
  done-iter
  ;; (read product)
  )

5_03

;; file: 5_03.rkt

#|
(define (sqrt x)
  (define (good-enough? guess)
    (< (abs (- (square guess) x)) 0.001))
  (define (improve guess)
    (average guess (/ x guess)))
  (define (sqrt-iter guess)
    (if (good-enough? guess)
        guess
        (sqrt-iter (improve guess))))
  (sqrt-iter 1.0))


- sqrt 각 버전의 머신 설계를 data-path 다이어그램으로, 레지스터 머신 언어로 controller 정의를 작성하여 설명.
|#


;; - good-enough?와 improve 연산자는 primitive로 사용 가능하다고 가정.
'(controller
  (assign x (op read))
  
  (assign guess (constant 1.0))
  
  loop-sqrt-iter
  (test (op good-enough?) (reg guess) (reg x))
  (branch
   (label done-loop-sqrt-iter))
  
  (assign guess (op improve) (reg guess) (reg x))
  (goto
   (label loop-sqrt-iter))
  
  done-loop-sqrt-iter
  ;; (read guess)
  )


;; - 두 연산자를 산술 연산으로 확장하여 구현
'(controller
  (assign x (op read))
  
  (assign guess (constant 1.0))
  
  loop

  ;; (define (good-enough? guess)
  ;;   (< (abs (- (square guess) x)) 0.001)) 
  (assign good-enough-s   (op square) (reg guess))                  ; (square guess)
  (assign good-enough-m   (op -)      (reg good-enough-s) (reg x))  ; (- x)
  (assign good-enough-abs (op abs)    (reg good-enough-m))          ; (abs)
  (test (op <) (register good-enough-abs) (constant 0.001))         ; (< 0.001)
  (branch
   (label done))

  ;; (define (improve guess)
  ;;   (average guess (/ x guess)))
  (assign improve-d   (op /)       (reg x)     (reg guess))          ; (/ x guess)
  (assign guess       (op average) (reg guess) (reg improve-d))      ; (average)
  (goto
   (label loop))
  
  done
  ;; (read guess)
  )

5_04

;; file: 5_04.rkt
;; 5_04 / 5_07
(#%require (prefix racket: racket))

(racket:provide
 expt-recur-controller
 expt-iter-controller)

;; ref:
;;  - Figure 5.11 - factorial

;; controller 랑 data-path다이어그램

;; Recursive exponentiation:
#|
(define (expt b n)
  (if (= n 0)
      1
      (* b (expt b (- n 1)))))
|#

(define expt-recur-data-path
  '(data-paths
    (registers
     ((name b)
      (buttons ((name b<-b) 
                (source (register b)))))
     ((name n)
      (buttons ((name n<-n-1) 
                (source (operator -)))))
     ((name val)
      (buttons ((name val<-expt-n-1)
                (source (operator expt)))))
     ((name continue)
    
      ))
    (operations
     ((name expt)
      (inputs (register b) (register n)))
     ((name =)
      (inputs (register n) (constant 0)))
     ((name -)
      (inputs (register n) (constant 1)))
     ((name *)
      (inputs (register b) (register val))))))

(define expt-recur-controller
  '(controller
    ;; (assign b (op read))
    ;; (assign n (op read))

    (assign continue
            (label done))
  
    loop
    (test (op =) (reg n) (const 0))      ;   (if (= n 0)
    (branch
     (label base-case))

    (save continue)
    ;;(save n)
    (assign n (op -) (reg n) (const 1))
    (assign continue
            (label after))
    (goto
     (label loop))

    after
    ;;(restore n)
    (restore continue)
    (assign val (op *) (reg b) (reg val)) ;       (* b (expt b (- n 1)))))
    (goto
     (reg continue))
  
    base-case
    (assign val (const 1))                ; 1
    (goto
     (reg continue))
  
    done
    ;; (read val)
    ))

;; Iterative exponentiation:
#|
(define (expt b n)
  (define (expt-iter counter product)
    (if (= counter 0)
        product
        (expt-iter (- counter 1)
                   (* b product))))
  (expt-iter n 1))
|#

(define expt-iter-data-path
  '(data-paths
    (registers
     ((name b))
     ((name n))
     ((name counter)
      (buttons ((name counter<-n) 
                (source (register n)))
               ((name counter<-minus)
                (source (operation -)))))
     ((name product)
      (buttons ((name product<-1) 
                (source (constant 1)))
               ((name counter<-mul)
                (source (operation *))))))
    (operations
     ((name expt)
      (inputs (register b) (register n)))
     ((name expt-iter)
      (inputs (register n) (constant 1)))
     ((name =)
      (inputs (register counter) (constant 0)))
     ((name -)
      (inputs (register counter) (constant 1)))
     ((name *)
      (inputs (register b) (register product))))))

(define expt-iter-controller
  '(controller
    ;; (assign b (op read))
    ;; (assign n (op read))

    (assign counter (reg n))
    (assign product (const 1))
  
    loop-iter
    (test (op =) (reg counter) (const 0))
    (branch
     (label done-iter))

    (assign counter (op -) (reg counter) (const 1))
    (assign product (op *) (reg b) (reg product))
  
    (goto
     (label loop-iter))
  
    done-iter
    ;; (read product)
    ))

5_05

;; file: 5_05.rkt

;; ref:
;;  - Figure 5.11 - factorial
;;  - Figure 5.12 - fibonacchi

#|
TOOD 팩토리얼(factorial)과 피보나치(Fibonacci) 머신을 손으로 시뮬레이션하시오.
이때, 최소한 한 번의 재귀 호출이 실행되는 nontrivial 입력을 사용하시오.
실행의 각 중요한 지점에서 스택의 내용을 보여주시오.
|#

5_06

;; file: 5_06.rkt

;; ref:
;;   - Figure 5.12
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)

#|
Ben Bitdiddle 은 피보나치 머신의 컨트롤러 시퀀스에 불필요한 save와 restore 명령이 포함되어 있으며,
이를 제거하면 더 빠른 머신을 만들 수 있는 것을 알아차렸습니다.
이 명령들은 어디에 있습니까?
|#

(#%require "../allcode/ch5-regsim.rkt")

'(define (fib n)
   (if (< n 2) 
       n 
       (+ (fib (- n 1)) (fib (- n 2)))))


(define fib-controller
  '(controller
    (assign continue
            (label fib-done))
   
    fib-loop
    (test (op <) (reg n) (const 2))
    (branch (label immediate-answer))
    ;; set up to compute Fib(n - 1)
    (save continue)                                          ; - save1   continue
    (assign continue
            (label afterfib-n-1))
    (save n)           ; save old value of n                 ; - save2   n
    (assign n 
            (op -)
            (reg n)
            (const 1)) ; clobber n to n-1
    (goto 
     (label fib-loop)) ; perform recursive call
   
    afterfib-n-1 ; upon return, val contains Fib(n - 1)
    (restore n)                                             ; - restore1 n
    ;;(restore continue)                                      ; - restore2 continue <<------
    ;; set up to compute Fib(n - 2)
    (assign n (op -) (reg n) (const 2))
    ;;(save continue)                                         ; - save3    continue  <<------
    (assign continue
            (label afterfib-n-2))
    (save val)         ; save Fib(n - 1)                    ; - save4    val
    (goto (label fib-loop))
   
    afterfib-n-2 ; upon return, val contains Fib(n - 2)
    (assign n 
            (reg val)) ; n now contains Fib(n - 2)
    (restore val)      ; val now contains Fib(n - 1)        ; - restore3 val
    (restore continue)                                      ; - restore4 continue
    (assign val        ; Fib(n - 1) + Fib(n - 2)
            (op +) 
            (reg val)
            (reg n))
    (goto              ; return to caller,
     (reg continue))   ; answer is in val
   
    immediate-answer
    (assign val 
            (reg n))   ; base case: Fib(n) = n
    (goto
     (reg continue))
   
    fib-done))

(define fib-machine
  (make-machine
   '(n continue val)
   (list (list '< <)
         (list '- -)
         (list '+ +))
   (rest fib-controller)
   ))

(define (fib n)
  (set-register-contents! fib-machine 'n n)
  (start fib-machine)
  (get-register-contents fib-machine 'val))

(check-equal? (fib 0)
              0)
(check-equal? (fib 1)
              1)
(check-equal? (fib 2)
              1)
(check-equal? (fib 3)
              2)
(check-equal? (fib 10)
              55)

5_07

;; file: 5_07.rkt
;; 5_04 / 5_07

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require threading)

;; simulator를 사용해여 머신을 테스트라하(연습문제 5.4에서 디자인한)
(#%require "../allcode/ch5-regsim.rkt")
(#%require "5_04.rkt")

(define add-machine
  (make-machine
   ;; 레지스터 목록
   '(n val sum continue)

   ;; 연산 목록
   (list (list '+ +)
         (list '- -)
         (list '= =))
   
   ;; 컨트롤러
   '(
     #;(assign continue (label done))
     
     loop
     (test (op =) (reg n) (const 0))         ; if n == 0
     (branch (label done))                   ;    break
     (assign sum (op +) (reg sum) (reg val)) ; sum += val
     (assign n (op -) (reg n) (const 1))     ; n -= 1
     (goto (label loop))
     
     done)))

(~> add-machine
    (set-register-contents! 'val 3)
    (check-equal? 'done))
(~> add-machine
    (set-register-contents! 'n 5)
    (check-equal? 'done))
(~> add-machine
    (set-register-contents!'sum 0)  ; 결과 저장용
    (check-equal? 'done))
(~> add-machine
    (start)
    (check-equal? 'done))
(~> add-machine 
    (get-register-contents 'sum)
    (check-equal? 15))


(define gcd-machine
  (make-machine
   '(a b t)
   (list (list 'rem remainder) (list '= =))
   '(test-b
     (test (op =) (reg b) (const 0))
     (branch (label gcd-done))
     (assign t (op rem) (reg a) (reg b))
     (assign a (reg b))
     (assign b (reg t))
     (goto (label test-b))
     gcd-done)))

(~> gcd-machine
    (set-register-contents! 'a 206)
    (check-equal? 'done))
(~> gcd-machine
    (set-register-contents! 'b 40)
    (check-equal? 'done))
(~> gcd-machine 
    (start)
    (check-equal? 'done))
(~> gcd-machine 
    (get-register-contents 'a)  ; 결과: 2 (206과 40의 GCD)
    (check-equal? 2))

;; ================
(define expt-recur-machine
  (make-machine
   '(b n continue val)
   (list (list '= =)
         (list '- -)
         (list '* *))
   (rest expt-recur-controller)))

(define (expr-recur b n)
  (set-register-contents! expt-recur-machine 'b b)
  (set-register-contents! expt-recur-machine 'n n)
  (start expt-recur-machine)
  (get-register-contents expt-recur-machine 'val))


(check-equal? (expr-recur 2 0)
              1)
(check-equal? (expr-recur 2 10)
              1024)

;; ================
(define expt-iter-machine
  (make-machine
   '(b n counter product)
   (list (list '= =)
         (list '- -)
         (list '* *))
   (rest expt-iter-controller)
   ))

(define (expr-iter b n)
  (set-register-contents! expt-iter-machine 'b b)
  (set-register-contents! expt-iter-machine 'n n)
  (start expt-iter-machine)
  (get-register-contents expt-iter-machine 'product))

(check-equal? (expr-iter 2 0)
              1)
(check-equal? (expr-iter 2 10)
              1024)

5_08

;; file: 5_08.rkt

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
                                  (_extract-labels origin-extract-labels)))

;; 시율레이터에서 there까지 돌렸을 때 레지스터 a 값은?
(define expr
  '(start
    (goto (label here))
    here
    (assign a (const 3))
    (goto (label there))
    here
    (assign a (const 4))
    (goto (label there))
    there))

(define add-machine
  (make-machine
   '(a)
   '()
   expr))

(~> add-machine
    (start)
    (check-equal? 'done))
(~> add-machine 
    (get-register-contents 'a)
    (check-equal? 3))

;; 어셈블러가 서로 다른 위치에 같은 레이블 이름을 썼을 때 에러를 나타내도록 extract-labels 프로시저를 고쳐라.
(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
                      (lambda (insts labels)
                        (let ((next-inst (car text)))
                          (if (symbol? next-inst)
                              ;; before
                              ;; (receive insts
                              ;;          (cons (make-label-entry next-inst
                              ;;                                  insts)
                              ;;                labels))
                              ;;
                              ;; after
                              (if (assoc next-inst labels)
                                  (error "duplicate labels:" next-inst)
                                  (receive insts
                                           (cons (make-label-entry next-inst
                                                                   insts)
                                                 labels)))
                              
                              (receive (cons (make-instruction next-inst)
                                             insts)
                                       labels)))))))

(override-extract-labels! extract-labels)

(check-exn
 #rx"duplicate labels: here"
 (lambda ()
   (extract-labels expr (lambda (insts labels) nil))))

5_09

;; file: 5_09.rkt

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

#|
machine operation을 다룰때 (constant / register 뿐만 아니라) label에도 다룰 수 있도록 되었는데,
expression을 처리하는 프로시져를 수정하여  constant / register 에만 사용 가능하도록 조건을 강제해라.
|#

(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
                                  (_make-operation-exp origin-make-operation-exp)))

(define (is-operation-operand-exp? exp)
  (cond ((constant-exp? exp)
         true)
        ((register-exp? exp)
         true)
        ((label-exp? exp)
         false)
        (else
         false)))

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                ;; before
                ;; (make-primitive-exp e machine labels)
                ;;
                ;; after
                (if (not (is-operation-operand-exp? e))
                    (error "is not operation operand exp:" e)
                    (make-primitive-exp e machine labels))
                )
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

(override-make-operation-exp! make-operation-exp)


(check-exn
 #rx"is not operation operand exp: \\(label hello\\)"
 (lambda ()
  
   (make-machine
    '(a b c x)
    (list (list '+ +))
    '(
      hello
     
      (assign x (const 1))
     
      (assign a (op +) (reg x) (reg x))
      (assign b (op +) (const 1) (const 2))
      (assign c (op +) (label hello) (label hello))
     
      ))
   ))

5_10

;; file: 5_10.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

#|
새로운 문법을 추가할 수 있으면 추가해봐라.
|#

(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
                                  (_make-execution-procedure origin-make-execution-procedure)))

(define (make-inc inst machine labels operations pc)
  (display (second inst))
  (newline)
  (let* ((register-name (second inst))
         (target (get-register machine register-name))
         (r (get-register machine register-name)))
    (lambda ()
      (set-contents! target (inc (get-contents r)))
      (advance-pc pc))))


(define (make-execution-procedure inst labels machine
                                  pc flag stack ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))
        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))
        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag pc))
        ((eq? (car inst) 'goto)
         (make-goto inst machine labels pc))
        ((eq? (car inst) 'save)
         (make-save inst machine stack pc))
        ((eq? (car inst) 'restore)
         (make-restore inst machine stack pc))
        ((eq? (car inst) 'perform)
         (make-perform inst machine labels ops pc))
        ((eq? (first inst) 'inc)
         (make-inc inst machine labels ops pc))
        (else (error "Unknown instruction type -- ASSEMBLE"
                     inst))))

(override-make-execution-procedure! make-execution-procedure)

(define dummy-machine 
  (make-machine
   '(x)
   '()
   '((assign x (const 1))
     
     (inc x)
     (inc x)
     )))

(~> dummy-machine
    (start)
    (check-equal? 'done))
(~> dummy-machine 
    (get-register-contents 'x)
    (check-equal? 3))

5_11

;; file: 5_11.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

(racket:provide
 make-kv-stack)
#|
a)

(restore y)는 스택에 저장된 마지막 값을, 그 값이 어떤 레지스터에서 왔는지 상관없이 y에 넣습니다.
이것이 우리 시뮬레이터의 동작 방식입니다.
이 동작을 활용하여 5.1.4의 피보나치 머신(그림 5.12)에서 하나의 명령어를 제거하는 방법을 보여주세요.
|#

(racket:require (racket:rename-in "../allcode/ch5-regsim.rkt"
                                  (_make-save origin-make-save)
                                  (_make-restore origin-make-restore)))


(define (dummy-machine-maker)
  (make-machine
   '(x y)
   '()
   '((assign x (const 1))
     (assign y (const 2))

     (save y)
     (save x)
     (restore y)
     )
   ))

(define dummy-machine (dummy-machine-maker))

(~> dummy-machine
    (start)
    (check-equal? 'done))
(~> dummy-machine
    (get-register-contents 'x)
    (check-equal? 1))
(~> dummy-machine
    (get-register-contents 'y)
    (check-equal? 1))



;; a) (restore y)는 스택에 마지막 저장한 값으로 y를 설정.

(define fib-controller
  '(controller
    (assign continue
            (label fib-done))
   
    fib-loop
    (test (op <) (reg n) (const 2))
    (branch (label immediate-answer))
    ;; set up to compute Fib(n - 1)
    (save continue)                                          ; - save1   continue
    (assign continue
            (label afterfib-n-1))
    (save n)           ; save old value of n                 ; - save2   n
    (assign n 
            (op -)
            (reg n)
            (const 1)) ; clobber n to n-1
    (goto 
     (label fib-loop)) ; perform recursive call
   
    afterfib-n-1 ; upon return, val contains Fib(n - 1)
    (restore n)                                             ; - restore1 n
    (restore continue)                                      ; - restore2 continue
    ;; set up to compute Fib(n - 2)
    (assign n (op -) (reg n) (const 2))
    (save continue)                                         ; - save3    continue
    (assign continue
            (label afterfib-n-2))
    (save val)         ; save Fib(n - 1)                    ; - save4    val
    (goto (label fib-loop))
   
    afterfib-n-2 ; upon return, val contains Fib(n - 2)

    ;; before a)
    ;; (assign n (reg val)) ; n now contains Fib(n - 2)
    ;; (restore val)      ; val now contains Fib(n - 1)        ; - restore3 val
    ;;
    ;; after a)
    (restore n) ; <<<<<<<
    
    (restore continue)                                      ; - restore4 continue
    (assign val        ; Fib(n - 1) + Fib(n - 2)
            (op +) 
            (reg val)
            (reg n))
    (goto              ; return to caller,
     (reg continue))   ; answer is in val
   
    immediate-answer
    (assign val 
            (reg n))   ; base case: Fib(n) = n
    (goto
     (reg continue))
   
    fib-done))

(define fib-machine
  (make-machine
   '(n continue val)
   (list (list '< <)
         (list '- -)
         (list '+ +))
   (rest fib-controller)
   ))

(define (fib n)
  (set-register-contents! fib-machine 'n n)
  (start fib-machine)
  (get-register-contents fib-machine 'val))

(check-equal? (fib 0)
              0)
(check-equal? (fib 1)
              1)
(check-equal? (fib 2)
              1)
(check-equal? (fib 3)
              2)
(check-equal? (fib 10)
              55)

#|
b)

(restore y)는 스택에 저장된 마지막 값을 y에 넣지만, 그 값이 y에서 저장된 경우에만 해당됩니다.
그렇지 않으면 오류를 표시합니다.
시뮬레이터를 이 방식으로 동작하도록 수정하세요.
save를 변경하여 값과 함께 레지스터 이름을 스택에 저장해야 합니다.
|#

(define (make-save-b inst machine stack pc)
  (let* ((reg-name (stack-inst-reg-name inst))
         (reg (get-register machine reg-name)))
    (lambda ()
      (push stack (cons reg-name (get-contents reg)))
      (advance-pc pc))))

(define (make-restore-b inst machine stack pc)
  (let* ((restore-reg-name (stack-inst-reg-name inst))
         (reg (get-register machine restore-reg-name)))
    (lambda ()
      (let* ((poped (pop stack))
             (pop-reg-name (first poped))
             (pop-reg-val  (rest poped)))
        (if (not (eq? restore-reg-name pop-reg-name))
            (error "restore-reg-name:" restore-reg-name 'pop-reg-name: pop-reg-name))
        (set-contents! reg pop-reg-val)
        (advance-pc pc)))))

(override-make-save! make-save-b)
(override-make-restore! make-restore-b)


(set! dummy-machine (dummy-machine-maker))
(check-exn
 #rx"restore-reg-name: y pop-reg-name: x"
 (lambda ()
   (start dummy-machine)))

#|
c)

(restore y)는 y 이후에 다른 레지스터들이 저장되고 복원되지 않았더라도, y에서 저장된 마지막 값을 y에 넣습니다.
시뮬레이터를 이 방식으로 동작하도록 수정하세요.
각 레지스터에 별도의 스택을 연결해야 합니다.
initialize-stack 작업이 모든 레지스터 스택을 초기화하도록 해야 합니다.
|#
(reset!)

(define (make-kv-stack)
  (define (kv-stack-init!)
    (list 'kv-stack))
  
  (define (kv-stack-push! kv-pop key new-value)
    (define (last-pair lst)
      (if (null? (rest lst))
          lst
          (last-pair (rest lst))))
    (let ((rest-kv-pop (rest kv-pop)))
      (if (null? rest-kv-pop)
          (begin
            (set-cdr! kv-pop (list (list key (list new-value))))
            kv-pop)
          (let loop ((current rest-kv-pop))
            (cond
              ((null? current)
               (set-cdr! (last-pair rest-kv-pop)
                         (list (list key (list new-value))))
               kv-pop)
              (else
               (let* ((key-stack (first current))
                      (k (first key-stack))
                      (stack (second key-stack)))
                 (if (eq? k key)
                     (begin
                       (set-car! (rest key-stack) (cons new-value stack))
                       kv-pop)
                     (loop (rest current))))))))))

  (define (kv-stack-pop! kv-pop key)
    (let ((rest-kv-pop (rest kv-pop)))
      (let loop ((current rest-kv-pop))
        (cond
          ((null? current)
           (error "Key not found:" key))
          (else
           (let* ((key-stack (first current))
                  (k (first key-stack))
                  (stack (second key-stack)))
             (if (eq? k key)
                 (if (null? (second key-stack))
                     (error "Value list is empty for key:" key)
                     (let ((value (first stack)))
                       (set-car! (rest key-stack) (rest stack))
                       value))
                 (loop (rest current)))))))))
  
  (let ((s (kv-stack-init!)))
    (define (push x)
      (let ((k (first x))
            (v (rest x)))
        (kv-stack-push! s k v)))
    (define (pop k)
      (kv-stack-pop! s k))
    (define (initialize)
      (set! s (kv-stack-init!))
      'done)
    (define (stack)
      s)
    (define (dispatch message)
      (cond ((eq? message 'push) push)
            ((eq? message 'pop) pop)
            ((eq? message 'initialize) (initialize))
            ((eq? message 'stack) (stack))
            (else (error "Unknown request -- STACK"
                         message))))
    dispatch))

(define (make-save-c inst machine stack pc)
  (let* ((reg-name (stack-inst-reg-name inst))
         (reg (get-register machine reg-name)))
    (lambda ()
      (push stack (cons reg-name (get-contents reg)))
      (advance-pc pc))))

(define (make-restore-c inst machine stack pc)
  (let* ((restore-reg-name (stack-inst-reg-name inst))
         (reg (get-register machine restore-reg-name)))
    (lambda ()
      ;; (pop stack) 함수를 호출하는 곳이 여기에만 있음.
      ;; (pop stack)함수를 override 할 수 있게 수정하는 대신
      ;; (stack 'pop)으로 직접 콜하는 방식으로 대신함.
      (let* ((poped ((stack 'pop) restore-reg-name)))
        (set-contents! reg poped)
        (advance-pc pc)))))

(override-make-stack! make-kv-stack)
(override-make-save! make-save-c)
(override-make-restore! make-restore-c)

(set! dummy-machine (dummy-machine-maker))

(~> dummy-machine
    (start)
    (check-equal? 'done))
(~> dummy-machine
    (get-register-contents 'x)
    (check-equal? 1))
(~> dummy-machine
    (get-register-contents 'y)
    (check-equal? 2))
(~> ((dummy-machine 'stack) 'stack)
    (check-equal? 
     '(kv-stack (y ()) (x (1)))))

5_12

;; file: 5_12.rkt
;; ref:
;;    - Figure 5.11: A recursive factorial machine.
;;    - Figure 5.12: Controller for a machine to compute Fibonacci numbers.

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

(racket:provide
 make-set
 make-kv-set)

#|
어셈블러를 확장하여 기계 모델에 다음 정보를 저장하도록 하세요:

1. 모든 명령어의 목록(중복 제거, 명령어 유형(assign, goto 등)으로 정렬됨).
2. 진입점(entry point)을 저장하는 데 사용되는 레지스터의 목록(중복 없이, goto 명령어에서 참조된 레지스터).
3. save되거나 restore되는 레지스터의 목록(중복 없이).
4. 각 레지스터에 대해, 해당 레지스터에 할당되는 소스(source)의 목록(중복 없이).
  - 예를 들어, 그림 5.11의 팩토리얼 기계에서 레지스터 val의 소스는 (const 1)과 ((op *) (reg n) (reg val))입니다.

기계의 메시지 패싱 인터페이스를 확장하여 이 새로운 정보에 접근할 수 있도록 하세요.
분석기를 테스트하기 위해 그림 5.12의 피보나치 기계를 정의하고, 생성한 목록들을 확인하세요.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))


#|
중복 안되며서 추가가능한 자료구조가 필요함.
set / 그리고 kv-set

1~4 이름 짓고
1. instruction-set
2. entry-register-set
3. save-restore-register-set
4. register-source-kv-set

그리고 controller-text처리하는 곳을 따라가야함

- 호출부 make-machine
- 정보 저장하려면 make-new-machine
- 그리고 참고용 install-instruction-sequence를 처리하는
  -(assemble controller-text machine)함수를 보면 extract-labels로 insts를 얻어올 수 있음.
|#



(define (make-set)
  (define (set-init!)
    (list 'set))
  (define (contains? set x)
    (member x (rest set)))
  (define (add! set x)
    (if (contains? set x)
        set
        (let ((y (rest set)))
          (set-cdr! set (cons x (rest set)))
          set)))
  (define (del! set x)
    (let loop ((prev set)
               (current (rest set)))
      (cond ((null? current) set)
            ((equal? (car current) x)
             (set-cdr! prev (cdr current))
             set)
            (else
             (loop current (cdr current))))))

  (let ((s (set-init!)))
    (define (add x)
      (add! s x))
    (define (del x)
      (del! s x))
    (define (set)
      s)
    (define (contains x)
      (contains? s x))
    (define (dispatch message)
      (cond ((eq? message 'set) (set))
            ((eq? message 'add) add)
            ((eq? message 'del) del)
            ((eq? message 'contains?) contains)
            (else (error "Unknown request -- SET" message))))
    dispatch))

(define my-set (make-set))
(check-equal? (my-set 'set) '(set))
(check-equal? ((my-set 'add) 1) '(set 1))
(check-equal? ((my-set 'add) 2) '(set 2 1))
(check-equal? ((my-set 'add) 2) '(set 2 1))
(check-equal? ((my-set 'del) 2) '(set 1))
(check-equal? ((my-set 'del) 2) '(set 1))

(define (make-kv-set)
  (define (kv-set-init!)
    (list 'kv-set))

  (define (contains? lst x)
    (member x lst))

  (define (kv-set-add! kv-set key value)
    (let ((rest-kv-set (rest kv-set)))
      (if (null? rest-kv-set)
          (begin
            (set-cdr! kv-set (list (list key (list value))))
            kv-set)
          (let loop ((current rest-kv-set))
            (cond
              ((null? current)
               (set-cdr! (last-pair rest-kv-set)
                         (list (list key (list value))))
               kv-set)
              (else
               (let* ((key-set (first current))
                      (k (first key-set))
                      (values (second key-set)))
                 (if (eq? k key)
                     (begin
                       (if (not (contains? values value))
                           (set-car! (rest key-set) (cons value values)))
                       kv-set)
                     (loop (rest current))))))))))

  (define (last-pair lst)
    (if (null? (rest lst))
        lst
        (last-pair (rest lst))))

  (let ((s (kv-set-init!)))
    (define (add k v)
      (kv-set-add! s k v))
    (define (set)
      s)
    (define (dispatch message)
      (cond ((eq? message 'add) add)
            ((eq? message 'set) (set))
            (else (error "Unknown request -- KV-SET" message))))
    dispatch))

(define my-kv-set (make-kv-set))
(check-equal? (my-kv-set 'set) '(kv-set))
(check-equal? ((my-kv-set 'add) 'k1 1) '(kv-set (k1 (1))))
(check-equal? ((my-kv-set 'add) 'k1 2) '(kv-set (k1 (2 1))))
(check-equal? ((my-kv-set 'add) 'k1 2) '(kv-set (k1 (2 1))))

;; ===========
(racket:require "../allcode/ch5-regsim.rkt")

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (instruction-set nil)                  ; 1.
        (entry-register-set nil)               ; 2.
        (save-restore-register-set nil)        ; 3.
        (register-source-kv-set (make-kv-set)) ; 4.
        )
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)

              ((eq? message 'instruction-set)           instruction-set)           ; 1.
              ((eq? message 'entry-register-set)        entry-register-set)        ; 2.
              ((eq? message 'save-restore-register-set) save-restore-register-set) ; 3.
              ((eq? message 'register-source-kv-set)    register-source-kv-set)    ; 4.
              
              ((eq? message 'install-instruction-set)            ; 1.
               (lambda (instructions)
                 (set! instruction-set instructions)))
              ((eq? message 'install-entry-register-set)         ; 2.
               (lambda (registers)
                 (set! entry-register-set registers)))
              ((eq? message 'install-save-restore-register-set)  ; 3.
               (lambda (save-restore-registers)
                 (set! save-restore-register-set save-restore-registers)))
              ((eq? message 'install-register-source-kv-set)     ; 4.
               (lambda (register-source-list)
                 (map (lambda (x)
                        (let ((k (first x))
                              (v (second x)))
                          ((register-source-kv-set 'add) k v)))
                      register-source-list)
                 (register-source-kv-set 'set)))
              
              
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))
(override-make-new-machine! make-new-machine)


(define (contains? lst x)
  (cond ((null? lst) false)
        ((equal? x (first lst)) true)
        (else (contains? (rest lst) x))))

(define (remove-duplicates lst)
  (define (iter acc lst)
    (cond ((null? lst)
           (reverse acc))
          ((contains? acc (first lst))
           (iter acc (rest lst)))
          (else
           (iter (cons (first lst) acc) (rest lst)))))
  (iter '() lst))

(define (filter predicate sequence)
  (cond ((null? sequence) nil)
        ((predicate (car sequence))
         (cons (car sequence)
               (filter predicate (cdr sequence))))
        (else (filter predicate (cdr sequence)))))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))


(define (get-all-instructions controller-text)
  (~> controller-text
      (extract-labels 
       (lambda (insts labels)
         (~>> insts
              (map first)
              (map (lambda (x) (first x))))))
      (remove-duplicates)))

(define (get-entry-registers controller-text)
  (~> controller-text
      (extract-labels
       (lambda (insts labels)
         (~>> insts
              (map first)
              (filter (lambda (x)
                        (eq? 'goto (first x))))
    
              (flatmap (lambda (x)
                         (filter (lambda (xx)
                                   (register-exp? xx))
                                 x)))
              (map second)
              (remove-duplicates))))))

(define (get-save-restore-registers controller-text)
  (~>  controller-text
       (extract-labels
        (lambda (insts labels)
          (~>>  insts
                (map first)
                (filter (lambda (x)
                          (or (eq? 'save (first x))
                              (eq? 'restore (first x)))))
                (map second ))))
       (remove-duplicates)))
(define (get-register-source-list controller-text)
  (~> controller-text
      (extract-labels 
       (lambda (insts labels)
         (~>> insts
              (map first)
              (filter (lambda (x)
                        (eq? 'assign (first x))))
              (map rest)
              )))
      (~>> 
       (map (lambda (x)
              (let ((reg (first x))
                    (source (rest x)))
                (list reg source)))))))
(check-equal?
 ; 1. all-instructions
 '(assign test branch save goto restore)
 
 (~> figure-5-11
     (rest)
     (get-all-instructions)))

(check-equal?
 ; 2. entry-register-set
 '(continue)

 (~> figure-5-11
     (rest)
     (get-entry-registers)))

(check-equal?
 ; 3. save-restore-registers
 '(continue n)
 
 (~>  figure-5-11
      (rest)
      (get-save-restore-registers)))

(check-equal?
 ; 4. register-source-list
 '((continue ((label fact-done)))
   (n ((op -) (reg n) (const 1)))
   (continue ((label after-fact)))
   (val ((op *) (reg n) (reg val)))
   (val ((const 1))))

 (~> figure-5-11
     (rest)
     (get-register-source-list)))


(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)    
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    
    ((machine 'install-instruction-set)           ; 1.
     (get-all-instructions controller-text))
    ((machine 'install-entry-register-set)        ; 2.
     (get-entry-registers controller-text))
    ((machine 'install-save-restore-register-set) ; 3.
     (get-save-restore-registers controller-text))
    ((machine 'install-register-source-kv-set)    ; 4.
     (get-register-source-list controller-text))
    
    machine))

(override-make-machine! make-machine)

(define machine-figure-5-11
  (make-machine
   '(n val continue)
   (list (list '= =)
         (list '- -)
         (list '* *))
   (rest figure-5-11)))

(check-equal? (machine-figure-5-11 'instruction-set)
              '(assign test branch save goto restore))
(check-equal? (machine-figure-5-11 'entry-register-set)
              '(continue))
(check-equal? (machine-figure-5-11 'save-restore-register-set)
              '(continue n))
(check-equal? ((machine-figure-5-11 'register-source-kv-set) 'set)
              '(kv-set
                (continue (((label after-fact))
                           ((label fact-done))))
                (n        (((op -) (reg n) (const 1))))
                (val      (((const 1))
                           ((op *) (reg n) (reg val))))))

(define machine-figure-5-12
  (make-machine
   '(n val continue)
   (list (list '< <)
         (list '- -)
         (list '+ +))
   (rest figure-5-12)))

(check-equal? (machine-figure-5-12 'instruction-set)
              '(assign test branch save goto restore))
(check-equal? (machine-figure-5-12 'entry-register-set)
              '(continue))
(check-equal? (machine-figure-5-12 'save-restore-register-set)
              '(continue n val))
(check-equal? ((machine-figure-5-12 'register-source-kv-set) 'set)
              '(kv-set
                (continue (((label afterfib-n-2))
                           ((label afterfib-n-1))
                           ((label fib-done))))
                (n        (((reg val))
                           ((op -) (reg n) (const 2))
                           ((op -) (reg n) (const 1))))
                (val      (((reg n))
                           ((op +) (reg val) (reg n))))))

5_13

;; file: 5_13.rkt

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

(racket:provide
 make-machine-5-13)

#|
레지스터 목록을 make-machine에 인자로 넘기는 대신 컨트롤러 시퀀스를 사용하도록 해라.
 make-machine에서 레지스터를 미리 할당하는 대신, 명령어 조립 중에 레지스터가 처음 등장할 때 하나씩 할당할 수 있다.
|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))

(racket:require "../allcode/ch5-regsim.rkt")

(define (contains? lst x)
  (cond ((null? lst) false)
        ((equal? x (first lst)) true)
        (else (contains? (rest lst) x))))

(define (remove-duplicates lst)
  (define (iter acc lst)
    (cond ((null? lst)
           (reverse acc))
          ((contains? acc (first lst))
           (iter acc (rest lst)))
          (else
           (iter (cons (first lst) acc) (rest lst)))))
  (iter '() lst))

(define (filter predicate sequence)
  (cond ((null? sequence) nil)
        ((predicate (car sequence))
         (cons (car sequence)
               (filter predicate (cdr sequence))))
        (else (filter predicate (cdr sequence)))))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (get-all-registers controller-text)
  (~> controller-text
      (extract-labels
       (lambda (insts labels)
         (~>> insts
              (map first)
              (flatmap (lambda (x)
                         (filter (lambda (xx)
                                   (register-exp? xx))
                                 x)))
              (map second)
              (remove-duplicates))))))


(define (make-new-machine-5-13)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              ;; 5.13
              ;;
              ;; before
              ;; (error "Unknown register:" name)
              ;;
              ;; after
              ;; make-machine에서 레지스터를 미리 할당하는 대신,
              ;; 명령어 조립 중에 레지스터가 처음 등장할 때 하나씩 할당할 수 있다.
              (begin
                (allocate-register name)
                (lookup-register name)))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(define (make-machine-5-13 ops controller-text)
  (let ((machine (make-new-machine-5-13)))
    
    ;; NOTE(pyoung): 이런 식으로 먼저 구문 분석해서 레지스터를 미리 추가할 수 도 있다.
    ;; (let ((register-names (get-all-registers controller-text)))
    ;;   (for-each (lambda (register-name)
    ;;               ((machine 'allocate-register) register-name))
    ;;             register-names))
    
    ((machine 'install-operations) ops)    
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

(define machine-figure-5-11
  (make-machine-5-13
   (list (list '= =)
         (list '- -)
         (list '* *))
   (rest figure-5-11)))

(~> machine-figure-5-11
    (set-register-contents! 'n 10)
    (check-equal? 'done))
(~> machine-figure-5-11
    (start)
    (check-equal? 'done))
(~> machine-figure-5-11
    (get-register-contents 'val)
    (check-equal? 3628800))

(define machine-figure-5-12
  (make-machine-5-13
   (list (list '< <)
         (list '- -)
         (list '+ +))
   (rest figure-5-12)))

(~> machine-figure-5-12
    (set-register-contents! 'n 10)
    (check-equal? 'done))
(~> machine-figure-5-12
    (start)
    (check-equal? 'done))
(~> machine-figure-5-12
    (get-register-contents 'val)
    (check-equal? 55))

5_14

;; file: 5_14.rkt
;; ref:
;; figure-5-11
;; figure-5-4

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)


#|

1. figure-5-11에 대해 다양한 n에 대한 필요한 푸시 횟수와 최대 스택 깊이를 측정하시오.

2. 임의의 n > 1 에 대해, n! 을 계산할 때 사용되는 총 푸시 연산 횟수와 최대 스택 깊이에 대한 n 의 함수로서의 공식을 구하라.
   - 각각은 n의 선형 함수이며, 따라서 두 개의 상수로 결정된다는 점에 유의하시오.
   - 통계 정보를 출력하려면, 팩토리얼 기계에 스택을 초기화하고 통계를 출력하는 명령어를 추가해야 합니다.
 
3. 또한, 기계를 수정하여 n 값을 반복적으로 읽고, 팩토리얼을 계산하며, 결과를 출력하도록 할 수 있습니다(그림 5.4의 GCD 기계에서 했던 것처럼).
   - 이렇게 하면 get-register-contents, set-register-contents!, start를 반복적으로 호출하지 않아도 됩니다.
|#

(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))

(racket:require "../allcode/ch5-regsim.rkt")



(override-make-stack! make-stack-5-2-4)

(define (run-machine-figure-5-11 n)
  
  (define machine-figure-5-11
    (make-machine
     '(n continue val)
     (list (list '= =)
           (list '- -)
           (list '* *))
     (rest figure-5-11)))

  (~> machine-figure-5-11
      (set-register-contents! 'n n))
  (~> machine-figure-5-11
      (start))
  ((machine-figure-5-11 'stack) 'print-statistics))


(check-output?
 "\n(total-pushes = 2 maximum-depth = 2)"
 ;; n 2
 ;; p 2
 ;; d 2

 (run-machine-figure-5-11 2))

(check-output?
 "\n(total-pushes = 8 maximum-depth = 8)"
 ;; n 5
 ;; p 8
 ;; d 8

 (run-machine-figure-5-11 5))

(check-output?
 "\n(total-pushes = 18 maximum-depth = 18)"
 ;; n 10
 ;; p 18
 ;; d 18
 
 (run-machine-figure-5-11 10))


#|

따라서 p = d = 2n - 2

|#

(define figure-5-11-loop
  ;; factorial
  '(controller
    (perform (op initialize-stack))         ; ** 5.14
    (assign n (op read))                    ; ** 5.14
    
    (assign continue (label fact-done))     ; set up final return address
    
    fact-loop
    (test (op =) (reg n) (const 1))
    (branch (label base-case))
    ;; Set up for the recursive call by saving n and continue.
    ;; Set up continue so that the computation will continue
    ;; at after-fact when the subroutine returns.
    (save continue)
    (save n)
    (assign n (op -) (reg n) (const 1))
    (assign continue (label after-fact))
    (goto (label fact-loop))
    
    after-fact
    (restore n)
    (restore continue)
    (assign val (op *) (reg n) (reg val))   ; val now contains n(n-1)!
    (goto (reg continue))                   ; return to caller
    
    base-case
    (assign val (const 1))                  ; base case: 1!=1
    (goto (reg continue))                   ; return to caller

    fact-done
    (perform (op print-stack-statistics))   ; ** 5.14
    (goto (label controller))               ; ** 5.14
    ))

(define (run-machine-figure-5-11-loop)
  (define machine-figure-5-11-loop
    (make-machine
     '(n continue val)
     (list (list '= =)
           (list '- -)
           (list '* *)
           (list 'read read)               ; ** 5.14
           )
     figure-5-11-loop))

  (~> machine-figure-5-11-loop
      (start)))

;; 루프 실행
;; (run-machine-figure-5-11-loop)

5_15

;; file: 5_15.rkt
;; 5_15 / 5_16 / 5_17 / 5_19

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)


#|
연습문제 5.15: 레지스터 머신 시뮬레이션에 명령어 카운팅 기능을 추가하시오.
즉, 머신 모델이 실행된 명령어의 수를 추적하도록 하시오.
머신 모델의 인터페이스를 확장하여 명령어 카운트 값을 출력하고 카운트를 0으로 재설정하는 새로운 메시지를 수락하도록 하시오.
|#

(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))

(racket:require "../allcode/ch5-regsim.rkt")
#;(override-make-stack! make-stack-5-2-4)

(define (make-new-machine-5-15)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (instruction-count 0))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))

                 ;; added : 5-15
                 (list 'initialize-instruction-count
                       (lambda ()
                         (set! instruction-count 0)))
                 (list 'print-instruction-count
                       (lambda ()
                         (newline)
                         (display (list 'print-instruction-count  '= instruction-count))))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                ;; added: 5-15
                (set! instruction-count (inc instruction-count))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))


(override-make-new-machine! make-new-machine-5-15)

(define dummy-machine
  (make-machine
   '(x y)
   '()
   '((assign x (const 1))                          ; 0 -> 1
     (assign y (const 2))                          ; 1 -> 2

     (perform (op print-instruction-count))        ; 출력(2) -> 3
     (perform (op print-instruction-count))        ; 출력(3) -> 4

     (perform (op initialize-instruction-count))   ; reset(0) -> 1
     
     (perform (op print-instruction-count))        ; 출력(1) -> 2
     )
   ))

(check-output?
 "
(print-instruction-count = 2)
(print-instruction-count = 3)
(print-instruction-count = 1)"
 
 (start dummy-machine))

5_16

;; file: 5_16.rkt
;; 5_15 / 5_16 / 5_17 / 5_19

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)


#|
연습문제 5.16: 시뮬레이터를 확장하여 명령어 추적 기능을 제공하시오.
 즉, 각 명령어가 실행되기 전에 시뮬레이터가 해당 명령어의 텍스트를 출력하도록 하시오.
 머신 모델이 trace-on과 trace-off 메시지를 수락하여 추적 기능을 켜고 끌 수 있도록 하시오.
|#

(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))

(racket:require "../allcode/ch5-regsim.rkt")


(define (make-new-machine-5-16)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (is-trace-on false) ; added : 5-16
        )
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))

                 ;; added : 5-16
                 (list 'trace-on
                       (lambda ()
                         (set! is-trace-on true)))
                 (list 'trace-off
                       (lambda ()
                         (set! is-trace-on false)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                 ;; added : 5-16
                (if is-trace-on
                    (begin
                      (newline)
                      (display (first (first insts)))))
                ((instruction-execution-proc (first insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))


(override-make-new-machine! make-new-machine-5-16)

(define dummy-machine
  (make-machine
   '(x y)
   '()
   '((assign x (const 1))
     (assign y (const 2))

     (perform (op trace-on))
     (assign x (const 1))
     (assign y (const 2))
     
     (perform (op trace-off))
     (assign x (const 1))
     (assign y (const 2))
     )
   ))

(check-output?
 "
(assign x (const 1))
(assign y (const 2))
(perform (op trace-off))"
 
 (start dummy-machine))

5_17

;; file: 5_17.rkt
;; 5_15 / 5_16 / 5_17 / 5_19

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)


#|
연습문제 5.17: 연습문제 5.16의 명령어 추적 기능을 확장하여,
명령어를 출력하기 전에 시뮬레이터가 컨트롤러 시퀀스에서 해당 명령어 바로 앞에 오는 레이블을 출력하도록 하시오.
이 작업이 명령어 카운팅(연습문제 5.15)과 간섭하지 않도록 주의해서 구현해야 합니다.
시뮬레이터가 필요한 레이블 정보를 유지하도록 해야 합니다.
|#

#|
extract-labels
 text를 insts랑 labels로 분리.

insts : ((insruction) ...)
labels: ((labelA instruction-A1 instruction-A2 ...) (labelB instruction-B1 instruction-B2 ...) ...)

assemble에서
  insts: ((insruction) ...)
  update-insts!
  insts : ((instruction . func) ...)
  insts가 바뀌면서 메모리를 공유하는 labels도 따라 바뀐다.
  labels: ((labelA (instruction-A1 . func) (instruction-A2 . func) ...) ...)
|#

#|
기존 코드에서 pc가 어셈의 instruction pointer처럼 index기반으로 동작했으면, 수정하기 보다 편했으려나...
인덱스 기반으로 싹 바꿀 마음도 있었지만, 대대적 수정이 있을꺼라 패스.

assemble / extract-labels / update-insts!에서 instruction안에 label정보를 찡겨 넣을까 생각해 봤지만,
대신 labels를 머신에 찡겨넣고, labels에서 instruction을 찾는 방식이 좋겠다.


- extract-labels에서 나온 labels 구조가 좀 골때림.
  - 처음에는 각 labels마다 instruction을 담는줄 알아서 find시 첫번째 label만 나오길레 이상해서 보니
  - labels 아레로 나온 Instruction전부를 포함하는 구조로 됨.
  - 그래서 미리 reverse를 시켜 줘서 find가 잘 찾도록 수정
|#


(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))

(racket:require "../allcode/ch5-regsim.rkt")

(override-make-stack! make-stack-5-2-4)

(define (assemble controller-text machine)
  (extract-labels controller-text
                  (lambda (insts labels)
                    (update-insts! insts labels machine)
                    (list insts labels))))

(override-assemble! assemble)

(define (contains? lst x)
  (cond ((null? lst) false)
        ((equal? x (first lst)) true)
        (else (contains? (rest lst) x))))

(define (find-label-name labels instruction)
  (if (null? labels)
      '**non-label-name**
      (let* ((label (first labels))
             (label-name (first label))
             (insts (rest label)))
        (if (contains? insts instruction)
            label-name
            (find-label-name (rest labels) instruction)))))

(define (make-new-machine-5-17)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (instruction-count 0) ; added : 5-15
        (is-trace-on false)   ; added : 5-16
        (the-labels nil)      ; added : 5-17
        )
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))

                 ;; added : 5-15
                 (list 'initialize-instruction-count
                       (lambda ()
                         (set! instruction-count 0)))
                 (list 'print-instruction-count
                       (lambda ()
                         (newline)
                         (display (list 'print-instruction-count  '= instruction-count))))
                 ;; added : 5-16
                 (list 'trace-on
                       (lambda ()
                         (set! is-trace-on true)))
                 (list 'trace-off
                       (lambda ()
                         (set! is-trace-on false)))
                 ))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ;; added : 5-17
                (if is-trace-on
                    (begin
                      (newline)
                      (let ((label-name (find-label-name the-labels (first insts))))
                        (display (list "==========================" label-name)))))
                
                ;; added : 5-16
                (if is-trace-on
                    (begin
                      (newline)
                      (display (first (first insts)))))
                
                ((instruction-execution-proc (car insts)))
                
                ;; added: 5-15
                (set! instruction-count (inc instruction-count))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               ;; before: 5-17
               ;; (lambda (seq)
               ;;   (set! the-instruction-sequence seq))
               ;; after: 5-17
               (lambda (insts-labels)
                 (let ((seq (first insts-labels))
                       (labels (second insts-labels)))
                   (set! the-instruction-sequence seq)
                   (set! the-labels (reverse labels)) ; // reverse를 한 것에 주의.
                   ))
               )
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(override-make-new-machine! make-new-machine-5-17)

(define dummy-machine
  (make-machine
   '(x y)
   '()
   '(label-A
     (assign x (const 1))
     (assign y (const 2))

     label-B
     (perform (op trace-on))
     (assign x (const 1))
     label-C
     (assign y (const 2))
     (save x)
     (restore x)
     
     label-D
     (perform (op trace-off))
     (assign x (const 1))
     (assign y (const 2))
     )
   ))

(check-output?
   "
(========================== label-B)
(assign x (const 1))
(========================== label-C)
(assign y (const 2))
(========================== label-C)
(save x)
(========================== label-C)
(restore x)
(========================== label-D)
(perform (op trace-off))
(total-pushes = 1 maximum-depth = 1)"
 
   (start dummy-machine)
   ((dummy-machine 'stack) 'print-statistics))

5_18

;; file: 5_18.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

#|
연습문제 5.18: 5.2.1절의 make-register 프로시저를 수정하여 레지스터를 추적할 수 있도록 하세요.

1. 레지스터는 추적을 켜고 끄는 메시지를 받아들여야 합니다.
2. 레지스터가 추적 중일 때, 레지스터에 값을 할당하면 레지스터의 이름, 기존 내용, 그리고 새로 할당되는 내용을 출력해야 합니다.
3. 기계 모델의 인터페이스를 확장하여 지정된 기계 레지스터에 대해 추적을 켜고 끌 수 있도록 하세요.

|#
(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))

(racket:require "../allcode/ch5-regsim.rkt")


(define (make-register name)
  (let ((contents '*unassigned*)
        (is-tracking false) ; added: 5-18 - 1.
        )
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value)
               ;; added: 5-18 - 2.
               (if is-tracking
                   (begin
                     (newline)
                     (display (list 'register "(" name ")" contents '>>>>> value))))
               (set! contents value)))
            ;; added: 5-18 - 1.
            ((eq? message 'set-is-tracking)
             (lambda (value) (set! is-tracking value)))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

(override-make-register! make-register)

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              ;; added: 5-18 - 3.
              ((eq? message 'register-track)
               (lambda (reg-name is-tracking)
                 (let ((reg (lookup-register reg-name)))
                   ((reg 'set-is-tracking) is-tracking))))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(override-make-new-machine! make-new-machine)

(define dummy-machine
  (make-machine
   '(x y)
   '()
   '((assign x (const 1))
     (assign y (const 2))

     (assign x (reg y))
     (assign y (reg x))
     
     (assign x (const 3))
     )
   ))

(check-output?
 "
(register ( x ) *unassigned* >>>>> 1)
(register ( x ) 1 >>>>> 2)
(register ( x ) 2 >>>>> 3)"

 ((dummy-machine 'register-track) 'x true)
 (start dummy-machine))

5_19

;; file: 5_19.rkt
;; 5_15 / 5_16 / 5_17 / 5_19

(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

#|
(set-breakpoint ⟨machine⟩ ⟨label⟩ ⟨n⟩)    : 1. label에서 n만큼 떨어진 곳에 breakpoint 설정
(proceed-machine ⟨machine⟩)               ; 2. 실행 이어가기
(cancel-breakpoint ⟨machine⟩ ⟨label⟩ ⟨n⟩) ; 3. breakpoint 제거
(cancel-all-breakpoints ⟨machine⟩)        ; 4. 모든 breakpoints 제거
|#

#|

1.
- n번째 찾는건 5_17 에서처럼 labels를 들고있다가 거기서 인덱스 만큼 떨어진 곳에 instruction을 찾을 수 있을거임.
- breakpoint table같은걸 만들어서 거기에 해당 instruction을 키로 해서 넣으면 될듯.
- 머신을 실행을 지속시키는것은 (execute) 루프
- breakpoint를 만나면 루프를 중지시키면 됨.


2.
- proceed-machine은 단순이 execute를 시켜주면 알아서 진행될꺼임.
- 단 첫 실행시 breakpoint 우회 방법 필요.

3.
- 1.에서 처럼 labels에서 instruction을 찾은 후 breakpoint 테이블에서 지우면 될꺼고

4.
- breakpoint 테이블 자체를 클리어 시키면 됨.

|#

(racket:require (racket:only-in "../allcode/ch5.rkt"
                                figure-5-11
                                figure-5-12))
(racket:require "../allcode/ch5-regsim.rkt")
(racket:require (racket:only-in "5_12.rkt"
                                make-set))
(reset!)

(define (assemble controller-text machine)
  (extract-labels controller-text
                  (lambda (insts labels)
                    (update-insts! insts labels machine)
                    (list insts labels))))
(override-assemble! assemble)

(define (set-breakpoint machine label n)
  ((machine 'set-breakpoint) label n))

(define (proceed-machine machine)
  (machine 'proceed-machine))

(define (cancel-breakpoint machine label n)
  ((machine 'cancel-breakpoint) label n))

(define (cancel-all-breakpoints machine)
  (machine 'cancel-all-breakpoints))

(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 (find-inst labels in-label-name in-n)
  (if (null? labels)
      nil
      (let* ((label (first labels))
             (label-name (first label))
             (insts (rest label)))
        (if (eq? in-label-name label-name)
            (nth insts in-n)
            (find-inst (rest labels) in-label-name in-n)))))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (breakpoint-set (make-set)) ; added: 5_19
        (the-labels nil)            ; added: 5_19
        )
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      ;; before: 5-19
      ;; (define (execute)
      ;;   (let ((insts (get-contents pc)))
      ;;     (if (null? insts)
      ;;         'done
      ;;         (begin
      ;;           ((instruction-execution-proc (car insts)))
      ;;           (execute)))))
      ;; after: 5-19
      (define (execute is-breakable-flag)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                (let ((inst (car insts)))
                  (if (and is-breakable-flag ((breakpoint-set 'contains?) inst))
                      '**break**
                      (begin
                        ((instruction-execution-proc (car insts)))
                        (execute true))))))))
      
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute true))
              ((eq? message 'install-instruction-sequence)
               ;; before: 5-19
               ;; (lambda (seq)
               ;;   (set! the-instruction-sequence seq))
               ;; after: 5-19
               (lambda (insts-labels)
                 (let ((seq (first insts-labels))
                       (labels (second insts-labels)))
                   (set! the-instruction-sequence seq)
                   (set! the-labels (reverse labels)) ; // reverse를 한 것에 주의.
                   ))
               )
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)

              ;; added: 5-19
              ((eq? message 'set-breakpoint)
               (lambda (label-name n)
                 (let ((inst (find-inst the-labels label-name n)))
                   (if (not (null? inst))
                       (begin
                         ((breakpoint-set 'add) inst)
                         (list '**break-marked**
                               'lable: label-name
                               ':idx   n
                               'inst:  (first inst)))))))
              ((eq? message 'proceed-machine)
               (execute false))
              ((eq? message 'cancel-breakpoint)
               (lambda (label-name n)
                 (let ((inst (find-inst the-labels label-name n)))
                   (if (null? inst)
                       (list 'cancel-breakpoint
                             'fail-to-find-inst
                             'lable: label-name
                             ':idx   n)
                       (if (not ((breakpoint-set 'contains?) inst))
                           (list 'cancel-breakpoint '**break-already-canceled**
                                 'lable: label-name
                                 ':idx   n
                                 'inst:  (first inst))
                           (let ((deleted-set ((breakpoint-set 'del) inst)))
                             (list 'cancel-breakpoint '**break-canceled**
                                   'lable: label-name
                                   ':idx   n
                                   'inst:  (first inst))))))))
              ((eq? message 'cancel-all-breakpoints)
               (set! breakpoint-set (make-set))
               '**cancel-all-breakpoints**)
              
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(override-make-new-machine! make-new-machine)

(define gcd-machine
  (make-machine
   '(a b t)
   (list (list 'rem remainder) (list '= =))
   '(test-b
     (test (op =) (reg b) (const 0))
     (branch (label gcd-done))
     (assign t (op rem) (reg a) (reg b))
     (assign a (reg b))
     (assign b (reg t))
     (goto (label test-b))
     
     gcd-done)))

(~> gcd-machine
    (set-breakpoint 'test-b 4)
    (check-equal? '(**break-marked** lable: test-b :idx 4 inst: (assign b (reg t)))))

(~> gcd-machine
    (set-register-contents! 'a 206)
    (check-equal? 'done))
(~> gcd-machine
    (set-register-contents! 'b 40)
    (check-equal? 'done))

(~> gcd-machine
    (start)
    (check-equal? '**break**))

(~> gcd-machine
    (get-register-contents 'a)
    (check-equal? 40))
(~> gcd-machine
    (get-register-contents 'b)
    (check-equal? 40))
(~> gcd-machine
    (get-register-contents 't)
    (check-equal? 6))

(~> gcd-machine
    (proceed-machine)
    (check-equal? '**break**))

(~> gcd-machine
    (get-register-contents 'a)
    (check-equal? 6))
(~> gcd-machine
    (get-register-contents 'b)
    (check-equal? 6))
(~> gcd-machine
    (get-register-contents 't)
    (check-equal? 4))

(~> gcd-machine
    (set-register-contents! 'a 40)
    (check-equal? 'done))
(~> gcd-machine
    (set-register-contents! 'b 40)
    (check-equal? 'done))
(~> gcd-machine
    (set-register-contents! 't 6)
    (check-equal? 'done))

(~> gcd-machine
    (proceed-machine)
    (check-equal? '**break**))

(~> gcd-machine
    (get-register-contents 'a)
    (check-equal? 6))

(~> gcd-machine
    (cancel-breakpoint 'test-c 1)
    (check-equal? '(cancel-breakpoint fail-to-find-inst lable: test-c :idx 1)))
(~> gcd-machine
    (cancel-breakpoint 'test-b 4)
    (check-equal? '(cancel-breakpoint **break-canceled** lable: test-b :idx 4 inst: (assign b (reg t)))))
(~> gcd-machine
    (cancel-breakpoint 'test-b 4)
    (check-equal? '(cancel-breakpoint **break-already-canceled** lable: test-b :idx 4 inst: (assign b (reg t)))))
#;(~> gcd-machine
    (cancel-all-breakpoints)
    (check-equal? '**cancel-all-breakpoints**))

(~> gcd-machine
    (proceed-machine)
    (check-equal? 'done))

(~> gcd-machine
    (get-register-contents 'a)
    (check-equal? 2))

5_20

;; file: 5_20.rkt

#|
연습문제 5.20: 다음 코드로 생성된 리스트 구조의 박스-포인터 다이어그램과 메모리 벡터 표현(그림 5.14와 같은 형식)을 그리시오:

(define x (cons 1 2))
(define y (list x x))

초기 free 포인터는 p1.
최종 free 포인터의 값은 무엇인가? 변수 x와 y의 값을 나타내는 포인터는 무엇인가?
|#

#|

| p | pointer    |
| n | number     |
| e | empty list |


e0 : 빈리스트 - '()

|#


#|

x = (cons 1 2)
<p1> = (cons 1 2)
+-+-+-+-+
|   |   |--> n2
+-+-+-+-+
  |
  v
  n1

y = (list x y) = (cons x (cons x '()))
  | <p2> = (cons x '())  = (cons <p1> <e0>)
  | <p3> = (cons x <p2>) = (cons <p1> <e2>)
y = <p3>

<p3>        <p2>
+-+-+-+-+    +-+-+-+-+
|   |   |--> |   |   |--> e0
+-+-+-+-+    +-+-+-+-+
  |            |
  v            v
  x<p1>       x<p1>


| index    | 0   | 1   | 2   | 3   | 4   |
| -------- | --- | --- | --- | --- | --- |
| the-cars |     | n1  | p1  | p1  |     |
| the-cdrs |     | n2  | e0  | p2  |     |

즉,

x    : p1
y    : p3
free : p4

|#

5_21

;; file: 5_21.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

#|

연습문제 5.21: 다음 프로시저에 대한 레지스터 머신 구현
리스트 구조 메모리 연산이 머신 기본 연산(primitive)으로 사용 가능하다고 가정하고, 아래 프로시저에 대한 레지스터 머신을 구현하시오.

1. 재귀적 count-leaves:
(define (count-leaves tree)
  (cond ((null? tree) 0)
        ((not (pair? tree)) 1)
        (else 
         (+ (count-leaves (car tree))
            (count-leaves (cdr tree))))))

2. 명시적 카운터를 사용한 재귀적 count-leaves:
(define (count-leaves tree)
  (define (count-iter tree n)
    (cond ((null? tree) n)
          ((not (pair? tree)) (+ n 1))
          (else 
           (count-iter 
            (cdr tree)
            (count-iter (car tree) 
                        n)))))
  (count-iter tree 0))
|#

#|
1번은 figure 5.12와 닮아 있음.


|#

(racket:require "../allcode/ch5-regsim.rkt")
(override-make-stack! make-stack-5-2-4)

(define (count-leaves-v1 tree)
  (cond ((null? tree) 0)
        ((not (pair? tree)) 1)
        (else 
         (+ (count-leaves-v1 (car tree))
            (count-leaves-v1 (cdr tree))))))

(define (count-leaves-v2 tree)
  (define (count-iter tree n)
    (cond ((null? tree) n)
          ((not (pair? tree)) (+ n 1))
          (else 
           (count-iter 
            (cdr tree)
            (count-iter (car tree) 
                        n)))))
  (count-iter tree 0))

(define sample-tree
  '((1 (2 3 (4 5)) (6 7)) (8 (9 (10 (11) 12)))))

(check-equal? (count-leaves-v1 sample-tree)
              12)
(check-equal? (count-leaves-v2 sample-tree)
              12)

;; v1 =====================================================================

(define controller-count-leaves-v1
  '(BEGIN
    
    (assign continue (label END))
    
    LOOP
    (test (op null?) (reg tree))             ; cond - ((null? tree) 0)
    (branch
     (label CASE-0))
    (assign temp1 (op pair?) (reg tree))     ; cond - ((not (pair? tree)) 1)
    (test (op not) (reg temp1))
    (branch
     (label CASE-1))
    
    (save continue)
    (assign continue (label AFTER-car-tree))
    (save tree)
    (assign tree (op car) (reg tree))        ; prepare : (count-leaves (car tree))
    (goto
     (label LOOP))                           ; do      : (count-leaves (car tree))

    AFTER-car-tree
    (restore tree)
    (restore continue)
    (assign tree (op cdr) (reg tree))        ; prepare : (count-leaves (cdr tree))
    (save continue)
    (assign continue (label AFTER-cdr-tree))
    (save val)                               ; save    : (count-leaves (car tree))
    (goto
     (label LOOP))                           ; do      : (count-leaves (cdr tree))

    AFTER-cdr-tree
    (assign tree (reg val))                  ; save    : (count-leaves (cdr tree))
    (restore val)                            ; restore : (count-leaves (car tree))
    (restore continue)
    (assign val (op +) (reg val) (reg tree)) ; cond - (+ (count-leaves-v1 (car tree))
    ;           (count-leaves-v1 (cdr tree)))
    (goto
     (reg continue))
    
    CASE-0
    (assign val (const 0))
    (goto
     (reg continue))

    CASE-1
    (assign val (const 1))
    (goto
     (reg continue))
    
    END))

(define machine-count-leaves-v1
  (make-machine
   '(tree temp1 continue val)
   (list (list 'null? null?)
         (list 'pair? pair?)
         (list 'not not)
         (list '+ +)
         (list 'car car)
         (list 'cdr cdr)
         )
   controller-count-leaves-v1
   ))

(~> machine-count-leaves-v1
    (set-register-contents! 'tree sample-tree)
    (check-equal? 'done))

(~> machine-count-leaves-v1
    (start)
    (check-equal? 'done))

(~> machine-count-leaves-v1
    (get-register-contents 'val)
    (check-equal? 12))

(check-output?
 "
(total-pushes = 80 maximum-depth = 18)"
 
 ((machine-count-leaves-v1 'stack) 'print-statistics))

;; v2 =====================================================================

(define controller-count-leaves-v2
  '(BEGIN
    
    (assign continue (label END))
    (assign n (const 0))                   ; (count-iter tree 0)
    
    LOOP
    (test (op null?) (reg tree))           ; cond - ((null? tree) n)
    (branch
     (label CASE-n))
    (assign temp1 (op pair?) (reg tree))   ; cond - ((not (pair? tree)) (+ n 1))
    (test (op not) (reg temp1))
    (branch
     (label CASE-n+1))

    ;; (count-iter (cdr tree)
    ;;             (count-iter (car tree)  n))))))
    (save continue)
    (assign continue (label AFTER-car-tree))
    (save tree)
    (assign tree (op car) (reg tree))
    (goto
     (label LOOP))

    AFTER-car-tree
    (restore tree)
    (restore continue)
    (assign tree (op cdr) (reg tree))
    (assign n (reg val))
    (goto
     (label LOOP))

    
    CASE-n
    (assign val (reg n))
    (goto
     (reg continue))

    CASE-n+1
    (assign val (op +) (reg n) (const 1))
    (goto
     (reg continue))
    
    END))


(define machine-count-leaves-v2
  (make-machine
   '(tree n temp1 continue val)
   (list (list 'null? null?)
         (list 'pair? pair?)
         (list 'not not)
         (list '+ +)
         (list 'car car)
         (list 'cdr cdr)
         )
   controller-count-leaves-v2
   ))

(~> machine-count-leaves-v2
    (set-register-contents! 'tree sample-tree)
    (check-equal? 'done))

(~> machine-count-leaves-v2
    (start)
    (check-equal? 'done))

(~> machine-count-leaves-v2
    (get-register-contents 'val)
    (check-equal? 12))

(check-output?
 "
(total-pushes = 40 maximum-depth = 10)"
 
 ((machine-count-leaves-v2 'stack) 'print-statistics))

5_22

;; file: 5_22.rkt
;; 3_12 / 5_22
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

#|
연습문제 3.12에 나온 append와 append!에 대한 머신 설계.
|#


(racket:require "../allcode/ch5-regsim.rkt")

(define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))

(define (append! x y)
  (set-cdr! (last-pair x) y)
  x)

(define (last-pair x)
  (if (null? (cdr x))
      x
      (last-pair (cdr x))))

(define x1 '(1 2))
(define y1 '(3 4))
(check-equal? (append x1 y1)
              '(1 2 3 4))
(check-equal? x1 '(1 2))
(check-equal? y1 '(3 4))

(define x2 '(1 2))
(define y2 '(3 4))
(check-equal? (append! x2 y2)
              '(1 2 3 4))
(check-equal? x2 '(1 2 3 4))
(check-equal? y2 '(3 4))



;; append =====================================================================

(define controller-append
  #|
  (define (append x y)
  (if (null? x)
      y
      (cons (car x) (append (cdr x) y))))
  |#
  '(BEGIN
    
    (assign continue (label END))
    
    LOOP
    (test (op null?) (reg x))                    ; (if (null? x)
    (branch
     (label CASE-y))
    
    (save continue)
    (assign continue (label AFTER-append-cdr))
    (save x)
    (assign x (op cdr) (reg x))                  ; prepare : (append (cdr x) y)
    (goto
     (label LOOP))                               ; do      : (append (cdr x) y)

    AFTER-append-cdr
    (restore x)
    (restore continue)
    (assign x (op car) (reg x))
    (assign val (op cons) (reg x) (reg val)) ; do : (cons (car x) (append (cdr x) y))))
    (goto
     (reg continue))
    
    CASE-y
    (assign val (reg y))
    (goto
     (reg continue))
    
    END))

(define machine-append
  (make-machine
   '(x y val continue)
   (list (list 'null? null?)
         (list 'car car)
         (list 'cdr cdr)
         (list 'cons cons)
         )
   controller-append
   ))

(define a1 '(1 2))
(define b1 '(3 4))
(~> machine-append
    (set-register-contents! 'x a1)
    (check-equal? 'done))
(~> machine-append
    (set-register-contents! 'y b1)
    (check-equal? 'done))
(~> machine-append
    (start)
    (check-equal? 'done))
(~> machine-append
    (get-register-contents 'val)
    (check-equal? '(1 2 3 4)))
(check-equal? a1 '(1 2))
(check-equal? b1 '(3 4))



;; append! =====================================================================
(define controller-append!
  '(BEGIN
    (assign iter-x (reg x))
    
    LOOP-last-pair
    (assign temp1 (op cdr) (reg iter-x))                    ; (if (null? (cdr x))
    (test (op null?) (reg temp1))
    (branch
     (label CASE-x))
    (assign iter-x (op cdr) (reg iter-x))
    (goto
     (label LOOP-last-pair))

    CASE-x
    (perform (op set-cdr!) (reg iter-x) (reg y))
    
    END))

(define machine-append!
  (make-machine
   '(x y iter-x temp1)
   (list (list 'null? null?)
         (list 'set-cdr! set-cdr!)
         (list 'cdr cdr)
         (list 'cons cons)
         )
   controller-append!
   ))

(define a2 '(1 2))
(define b2 '(3 4))
(~> machine-append!
    (set-register-contents! 'x a2)
    (check-equal? 'done))
(~> machine-append!
    (set-register-contents! 'y b2)
    (check-equal? 'done))
(~> machine-append!
    (start)
    (check-equal? 'done))
(~> machine-append!
    (get-register-contents 'x)
    (check-equal? '(1 2 3 4)))
(check-equal? a2 '(1 2 3 4))
(check-equal? b2 '(3 4))

5_23

;; file: 5_23.rkt
(#%require rackunit)
(#%require "../allcode/helper/my-util.rkt")
(#%require (prefix racket: racket))
(#%require threading)

#|
cond와 let을 처리할 수 있도록 확장해라.
(cond->if와 같은 변환을 연산으로 쓸 수 있다고 가정)
|#

(racket:require "../allcode/load-eceval.rkt")
(racket:require (racket:prefix-in syntax: "../allcode/ch5-syntax.rkt"))
(reset-the-global-environment!)

;; 4_06 연섭문제
(define (let? exp) (syntax:tagged-list? exp 'let))
(define (let->combination let-clause)
  (let* ((bindings (second let-clause))
         (vars (map first bindings))
         (exps (map second bindings))
         (body (rest (rest let-clause))))
    (cons (syntax:make-lambda vars body)
          exps)))

(define eceval
  (make-machine
   '(exp env val proc argl continue unev)
   (append eceval-operations
           (list (list 'cond? syntax:cond?)
                 (list 'cond->if syntax:cond->if)
                 (list 'let? let?)
                 (list 'let->combination let->combination)
                 ))
   '(
     ;;SECTION 5.4.4
     read-eval-print-loop
     (perform (op initialize-stack))
     #| 주석처리
     (perform
      (op prompt-for-input) (const ";;; EC-Eval input:"))
     (assign exp (op read))
     (assign env (op get-global-environment))
     (assign continue (label print-result))
     (goto (label eval-dispatch))
     print-result
     ;;**following instruction optional -- if use it, need monitored stack
     (perform (op print-stack-statistics))
     (perform
      (op announce-output) (const ";;; EC-Eval value:"))
     (perform (op user-print) (reg val))
     (goto (label read-eval-print-loop))
     |#
     ;; 한번만 실행하도록 하고, 바로 END로
     (assign env (op get-global-environment))
     (assign continue (label print-result))
     (goto (label eval-dispatch))
     print-result
     (goto (label END))

     unknown-expression-type
     (assign val (const unknown-expression-type-error))
     (goto (label signal-error))

     unknown-procedure-type
     (restore continue)
     (assign val (const unknown-procedure-type-error))
     (goto (label signal-error))

     signal-error
     (perform (op user-print) (reg val))
     (goto (label read-eval-print-loop))

     ;;SECTION 5.4.1
     eval-dispatch
     (test (op self-evaluating?) (reg exp))
     (branch (label ev-self-eval))
     (test (op variable?) (reg exp))
     (branch (label ev-variable))
     (test (op quoted?) (reg exp))
     (branch (label ev-quoted))
     (test (op assignment?) (reg exp))
     (branch (label ev-assignment))
     (test (op definition?) (reg exp))
     (branch (label ev-definition))
     (test (op if?) (reg exp))
     (branch (label ev-if))

     ;; added: 5-23
     (test (op cond?) (reg exp))
     (branch (label ev-cond))
     ;; added: 5-23
     (test (op let?) (reg exp))
     (branch (label ev-let))
     
     (test (op lambda?) (reg exp))
     (branch (label ev-lambda))
     (test (op begin?) (reg exp))
     (branch (label ev-begin))
     (test (op application?) (reg exp))
     (branch (label ev-application))
     (goto (label unknown-expression-type))

     ev-self-eval
     (assign val (reg exp))
     (goto (reg continue))
     ev-variable
     (assign val (op lookup-variable-value) (reg exp) (reg env))
     (goto (reg continue))
     ev-quoted
     (assign val (op text-of-quotation) (reg exp))
     (goto (reg continue))
     ev-lambda
     (assign unev (op lambda-parameters) (reg exp))
     (assign exp (op lambda-body) (reg exp))
     (assign val (op make-procedure)
             (reg unev) (reg exp) (reg env))
     (goto (reg continue))

     ev-application
     (save continue)
     (save env)
     (assign unev (op operands) (reg exp))
     (save unev)
     (assign exp (op operator) (reg exp))
     (assign continue (label ev-appl-did-operator))
     (goto (label eval-dispatch))
     ev-appl-did-operator
     (restore unev)
     (restore env)
     (assign argl (op empty-arglist))
     (assign proc (reg val))
     (test (op no-operands?) (reg unev))
     (branch (label apply-dispatch))
     (save proc)
     ev-appl-operand-loop
     (save argl)
     (assign exp (op first-operand) (reg unev))
     (test (op last-operand?) (reg unev))
     (branch (label ev-appl-last-arg))
     (save env)
     (save unev)
     (assign continue (label ev-appl-accumulate-arg))
     (goto (label eval-dispatch))
     ev-appl-accumulate-arg
     (restore unev)
     (restore env)
     (restore argl)
     (assign argl (op adjoin-arg) (reg val) (reg argl))
     (assign unev (op rest-operands) (reg unev))
     (goto (label ev-appl-operand-loop))
     ev-appl-last-arg
     (assign continue (label ev-appl-accum-last-arg))
     (goto (label eval-dispatch))
     ev-appl-accum-last-arg
     (restore argl)
     (assign argl (op adjoin-arg) (reg val) (reg argl))
     (restore proc)
     (goto (label apply-dispatch))
     apply-dispatch
     (test (op primitive-procedure?) (reg proc))
     (branch (label primitive-apply))
     (test (op compound-procedure?) (reg proc))  
     (branch (label compound-apply))
     (goto (label unknown-procedure-type))

     primitive-apply
     (assign val (op apply-primitive-procedure)
             (reg proc)
             (reg argl))
     (restore continue)
     (goto (reg continue))

     compound-apply
     (assign unev (op procedure-parameters) (reg proc))
     (assign env (op procedure-environment) (reg proc))
     (assign env (op extend-environment)
             (reg unev) (reg argl) (reg env))
     (assign unev (op procedure-body) (reg proc))
     (goto (label ev-sequence))

     ;;;SECTION 5.4.2
     ev-begin
     (assign unev (op begin-actions) (reg exp))
     (save continue)
     (goto (label ev-sequence))

     ev-sequence
     (assign exp (op first-exp) (reg unev))
     (test (op last-exp?) (reg unev))
     (branch (label ev-sequence-last-exp))
     (save unev)
     (save env)
     (assign continue (label ev-sequence-continue))
     (goto (label eval-dispatch))
     ev-sequence-continue
     (restore env)
     (restore unev)
     (assign unev (op rest-exps) (reg unev))
     (goto (label ev-sequence))
     ev-sequence-last-exp
     (restore continue)
     (goto (label eval-dispatch))

     ;;;SECTION 5.4.3

     ev-if
     (save exp)
     (save env)
     (save continue)
     (assign continue (label ev-if-decide))
     (assign exp (op if-predicate) (reg exp))
     (goto (label eval-dispatch))
     ev-if-decide
     (restore continue)
     (restore env)
     (restore exp)
     (test (op true?) (reg val))
     (branch (label ev-if-consequent))
     ev-if-alternative
     (assign exp (op if-alternative) (reg exp))
     (goto (label eval-dispatch))
     ev-if-consequent
     (assign exp (op if-consequent) (reg exp))
     (goto (label eval-dispatch))

     ;; added: 5-23
     ev-cond
     (assign exp (op cond->if) (reg exp))
     (goto (label ev-if))
     ;; added: 5-23
     ev-let
     (assign exp (op let->combination) (reg exp))
     (goto (label ev-application))
     
     ev-assignment
     (assign unev (op assignment-variable) (reg exp))
     (save unev)
     (assign exp (op assignment-value) (reg exp))
     (save env)
     (save continue)
     (assign continue (label ev-assignment-1))
     (goto (label eval-dispatch))
     ev-assignment-1
     (restore continue)
     (restore env)
     (restore unev)
     (perform
      (op set-variable-value!) (reg unev) (reg val) (reg env))
     (assign val (const ok))
     (goto (reg continue))

     ev-definition
     (assign unev (op definition-variable) (reg exp))
     (save unev)
     (assign exp (op definition-value) (reg exp))
     (save env)
     (save continue)
     (assign continue (label ev-definition-1))
     (goto (label eval-dispatch))
     ev-definition-1
     (restore continue)
     (restore env)
     (restore unev)
     (perform
      (op define-variable!) (reg unev) (reg val) (reg env))
     (assign val (const ok))
     (goto (reg continue))

     END)))

(~> eceval
    (set-register-contents! 'exp '(cond ((= 1 2) 'a)
                                        ((= 3 4) 'b)
                                        (else 'c)))
    (check-equal? 'done))
(~> eceval
    (start)
    (check-equal? 'done))
(~> eceval
    (get-register-contents 'val)
    (check-equal? 'c))



(~> eceval
    (set-register-contents! 'exp '(let ((x 1)
                                        (y 2))
                                    (+ x y)))
    (check-equal? 'done))
(~> eceval
    (start)
    (check-equal? 'done))
(~> eceval
    (get-register-contents 'val)
    (check-equal? 3))

5_24

;; file: 5_24.rkt

5_25

;; file: 5_25.rkt

5_26

;; file: 5_26.rkt

5_27

;; file: 5_27.rkt

5_28

;; file: 5_28.rkt

5_29

;; file: 5_29.rkt

5_30

;; file: 5_30.rkt

5_31

;; file: 5_31.rkt

5_32

;; file: 5_32.rkt

5_33

;; file: 5_33.rkt

5_34

;; file: 5_34.rkt

5_35

;; file: 5_35.rkt

5_36

;; file: 5_36.rkt

5_37

;; file: 5_37.rkt

5_38

;; file: 5_38.rkt

5_39

;; file: 5_39.rkt

5_40

;; file: 5_40.rkt

5_41

;; file: 5_41.rkt

5_42

;; file: 5_42.rkt

5_43

;; file: 5_43.rkt

5_44

;; file: 5_44.rkt

5_45

;; file: 5_45.rkt

5_46

;; file: 5_46.rkt

5_47

;; file: 5_47.rkt

5_48

;; file: 5_48.rkt

5_49

;; file: 5_49.rkt

5_50

;; file: 5_50.rkt

5_51

;; file: 5_51.rkt

5_52

;; file: 5_52.rkt