* Re: Bug: org-babel-expand-noweb-references is very slow [9.1.9 (release_9.1.9-65-g5e4542 @ /usr/share/emacs/26.3/lisp/org/)]
[not found] ` <87y2ujr198.fsf@nicolasgoaziou.fr>
@ 2020-01-08 2:18 ` Vladimir Nikishkin
2020-01-08 17:23 ` Nicolas Goaziou
0 siblings, 1 reply; 6+ messages in thread
From: Vladimir Nikishkin @ 2020-01-08 2:18 UTC (permalink / raw)
To: Nicolas Goaziou, emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 6134 bytes --]
Hm...
I am attaching the file in which tangling is still slow.
The file is quite big, but that alone doesn't seem to be the reason
for slowliness (I tried adding 1M-long words in the random places of
the previous mwe).
You can see the result by C-c C-v C-v'ing the code block at the
"Ramanujan numbers" heading.
Below is the profiler report for C-c C-v C-v'ing.with the heaviest
blocks expanded:
- command-execute 52967 87%
- call-interactively 52967 87%
- funcall-interactively 52655 87%
- org-babel-expand-src-block 52505 86%
- org-babel-expand-noweb-references 52424 86%
- org-babel-get-src-block-info 35019 57%
- org-babel-params-from-properties 28142 46%
- org-entry-get 27753 45%
- org-entry-get-with-inheritance 27683 45%
- org-up-heading-safe 26176 43%
+ org-back-to-heading 148 0%
org-outline-level 73 0%
+ org--property-local-values 1318 2%
+ org-back-to-heading 19 0%
org--property-global-value 6 0%
member-ignore-case 22 0%
+ org-babel-parse-header-arguments 359 0%
#<compiled 0x2495bf1> 5 0%
+ org-src-coderef-format 2533 4%
+ org-element-context 2521 4%
+ org-babel--normalize-body 1082 1%
+ mapcar 473 0%
+ apply 212 0%
org-element-property 5 0%
- org-in-commented-heading-p 13928 23%
- org-in-commented-heading-p 10418 17%
- org-up-heading-safe 9136 15%
org-outline-level 22 0%
+ org-back-to-heading 7 0%
+ org-in-commented-heading-p 1073 1%
+ org-heading-components 63 0%
+ org-before-first-heading-p 45 0%
+ org-up-heading-safe 3147 5%
+ org-heading-components 142 0%
+ org-before-first-heading-p 95 0%
+ org-babel-active-location-p 2594 4%
+ org-babel-ref-goto-headline-id 139 0%
+ #<compiled 0x106c419> 1 0%
+ #<compiled 0x19f41bd> 1 0%
+ org-edit-src-code 50 0%
+ org-babel-get-src-block-info 21 0%
+ execute-extended-command 138 0%
+ org-edit-src-exit 5 0%
scroll-down-command 4 0%
mouse-select-window 2 0%
scroll-up-command 1 0%
+ byte-code 312 0%
+ ... 7409 12%
+ timer-event-handler 54 0%
+ mouse-fixup-help-message 35 0%
+ flyspell-post-command-hook 22 0%
+ redisplay_internal (C function) 16 0%
+ tooltip-show-help 4 0%
undefined 2 0%
вт, 7 янв. 2020 г. в 18:48, Nicolas Goaziou <mail@nicolasgoaziou.fr>:
>
> Hello,
>
> Vladimir Nikishkin <lockywolf@gmail.com> writes:
>
> > Well, now I'm using org from org's own melpa (9.3.8), and it's still very
> > slow.
> >
> > Is there something I'm missing?
>
> Possibly. With your initial ECM, pasted below for reference, and Org
> 9.3.1, the last block expands in around one second here.
>
> --8<---------------cut here---------------start------------->8---
> * Noweb expansion
> :PROPERTIES:
> :header-args: :noweb yes
> :END:
>
> Hello, everyone.
>
> The mwe would be like:
>
> #+begin_src scheme :exports both :results output :noweb-ref bug1
> #+end_src
>
> #+begin_src scheme :exports both :results output :noweb-ref bug2
> #+end_src
>
> #+begin_src scheme :exports both :results output :noweb-ref bug3
> #+end_src
>
> #+begin_src scheme :exports both :results output :noweb-ref bug4
> #+end_src
>
> #+begin_src scheme :exports both :results output :noweb-ref bug5
> #+end_src
>
> #+begin_src scheme :exports both :results output :noweb-ref bug6
> #+end_src
>
> #+begin_src scheme :exports both :results output :noweb-ref bug7
> #+end_src
>
> #+begin_src scheme :exports both :results output :noweb-ref bug8
> #+end_src
>
> #+begin_src scheme :exports both :results output
> <<bug1>>
> <<bug2>>
> <<bug3>>
> <<bug4>>
> <<bug5>>
> <<bug6>>
> <<bug7>>
> <<bug8>>
> #+end_src
> --8<---------------cut here---------------end--------------->8---
>
> Regards,
>
> --
> Nicolas Goaziou
--
Yours sincerely, Vladimir Nikishkin
[-- Attachment #2: index.org --]
[-- Type: application/octet-stream, Size: 818063 bytes --]
# -*- mode: org; geiser-scheme-implementation: chibi; -*-
# Time-stamp: <2020-01-07 18:24:54 lockywolf>
# Created : [2019-08-18 Sun 20:11]
# Author : lockywolf gmail.com
#+STARTUP: inlineimages
#+STARTUP: latexpreview
#+HTML_MATHJAX: align: left indent: 5em tagside: left font: Neo-Euler
#+HTML_MATHJAX: cancel.js noErrors.js
#+OPTIONS: tex:imagemagick
* noweb + common
** Some common code blocks
** Setting chibi arguments. DANGEROUS :dangerous:elisp:
#+begin_src elisp :export both :results value
(setq geiser-chibi-extra-command-line-parameters
'("-m" "chibi"
"-m" "srfi 159"
"-m" "chibi ast"
"-m" "chibi time"
"-m" "srfi 27"
"-m" "chibi process"
"-m" "srfi 42"
"-m" "srfi 78"
"-m" "scheme list"
"-m" "srfi 18"))
(setq geiser-connection-timeout (* 2 geiser-connection-timeout))
#+end_src
#+RESULTS:
| -m | chibi | -m | srfi 159 | -m | chibi ast | -m | chibi time | -m | srfi 27 | -m | chibi process | -m | srfi 42 | -m | srfi 78 | -m | scheme list |
#+name: common
#+begin_src scheme :results output :exportss none
(import (chibi ast))
(import (chibi show))
(define (disp sexp)
(display sexp)
(newline))
#+end_src
#+RESULTS: common
* SICP [59%]
:PROPERTIES:
:header-args: :noweb yes
:END:
** TODO Chapter 1: Building abstractions with procedures [57/61]
*** Snippet
#+BEGIN_SRC scheme :exports both :results value :session
(* (+ 2 (* 4 6))
(+ 3 5 7))
#+END_SRC
#+RESULTS:
: 390
*** Thought
Tree accumulation is the process of computing a thing by traversing a tree.
*** DONE Figure 1.1 Tree representation, showing the value of each subcombination :graphviz:plantuml:
CLOSED: [2019-08-20 Tue 14:35]
For the sake of pedagogical clarity, I have formatted it as a picture.
#+BEGIN_SRC plantuml :exports both :file figure-1-1-mm.png
@startmindmap
skinparam monochrome true
+_ 390
++_ *
++_ 26
+++_ +
+++_ 2
+++_ 24
++++_ *
++++_ 4
++++_ 6
++_ 15
+++_ +
+++_ 3
+++_ 5
+++_ 7
@endmindmap
#+END_SRC
#+RESULTS:
[[file:figure-1-1-mm.png]]
# Then next line is the same diagram verbose, using DOT.
#+begin_src plantuml :exports both :file figure-1-1-dot.png
@startdot
graph g {
node [shape=plaintext];
A1 [label="390"];
B1 [label="*"];
B2 [label="26"];
B3 [label="15"];
C1 [label="+"];
C2 [label="2"];
C3 [label="24"];
D1 [label="*"];
D2 [label="4"];
D3 [label="6"];
E1 [label="+"];
E2 [label="3"];
E3 [label="5"];
E4 [label="7"];
// edges
A1 -- B1;
A1 -- B2;
A1 -- B3;
B2 -- C1;
B2 -- C2;
B2 -- C3;
C3 -- D1;
C3 -- D2;
C3 -- D3;
B3 -- E1;
B3 -- E2;
B3 -- E3;
B3 -- E4;
// B1 -> B3 [label="(g o f)'" tailport=s headport=s];
{ rank=same; A1 }
{ rank=same; B1 B2 B3 }
{ rank=same; C1 C2 C3 }
{ rank=same; D1 D2 D3 }
{ rank=same; E1 E2 E3 E4 }
}
@enddot
#+end_src
#+RESULTS:
[[file:figure-1-1-dot.png]]
*** Snippet
#+name square
#+begin_src scheme :exports both :results value :session
(define (square x) (* x x))
(define (sum-of-squares x y)
(+ (square x) (square y)))
(sum-of-squares 3 4)
#+end_src
#+RESULTS:
: 25
*** DONE Exercise 1.1 Interpreter result
CLOSED: [2019-08-20 Tue 14:23]
#+begin_src scheme :exports both :results output :session
(define (disp sexp)
(display sexp)
(newline))
(disp 10)
(disp (+ 2 3 4))
(disp (- 9 1))
(disp (/ 6 2))
(disp (+ (* 2 4) (- 4 6)))
(define a 3)
(define b (+ a 1))
(disp (+ a b (* a b)))
(disp (= a b))
(disp
(if (and (> b a) (< b (* a b )))
b
a))
(disp (cond ((= a 4) 6)
((= b 4) (+ 6 7 a))
(else 25)))
(disp (+ 2 (if (< b a) b a)))
(disp (* (cond ((> a b) a)
((< a b) b)
(else -1))
(+ a 1)))
#+end_src
#+RESULTS:
#+begin_example
10
9
8
3
6
19
#f
4
16
5
16
#+end_example
*** DONE Exercise 1.2 Prefix form
CLOSED: [2019-08-20 Tue 14:25]
#+begin_src scheme :exports both :results value :session
(/ (+ 5 4 (- 2 (- 3 (+ 6 (/ 4 5))))) (* 3 (- 6 2) (- 2 7)))
#+end_src
#+RESULTS:
: -37/150
*** DONE Exercise 1.3 Sum of squares
CLOSED: [2019-08-20 Tue 14:35]
#+begin_src scheme :exports both :results value :session
(define (sum-of-squares x y)
(+ (square x) (square y)))
(import (srfi 95))
(define (sum-of-two-max a b c)
(let ((num_list (sort (list a b c) (lambda (a b) (if (> a b) a b)))))
(sum-of-squares (car num_list) (cadr num_list))))
(sum-of-two-max 1 2 3)
#+end_src
#+RESULTS:
: "Result (exception): {Exception #19 user \"undefined variable\" (sort) #<procedure sum-of-two-max> (#f . 41)}\nStack trace:\n called from <anonymous> on line 813 of file /usr/lib64/chibi/init-7.scm\n called from <anonymous> on line 280 of file /usr/lib64/chibi/init-7.scm\n called from <anonymous> on line 1202 of file /usr/lib64/chibi/init-7.scm\n called from <anonymous> on line 813 of file /usr/lib64/chibi/init-7.scm\n called from sum-of-two-max on line 41\n called from <anonymous> on line 813 of file /usr/lib64/chibi/init-7.scm\n called from call-with-current-continuation on line 840 of file /usr/lib64/chibi/init-7.scm\n called from <anonymous> on line 813 of file /usr/lib64/chibi/init-7.scm\n called from <anonymous> on line 280 of file /usr/lib64/chibi/init-7.scm\n called from <anonymous> on line 280 of file /usr/lib64/chibi/init-7.scm\n called from <anonymous> on line 813 of file /usr/lib64/chibi/init-7.scm\n called from call-with-current-continuation on line 840 of file /usr/lib64/chibi/init-7.scm\n called from geiser:eval on line 25 of file /usr/lib64/chibi/scheme/misc-macros.scm\n"
*** DONE Exercise 1.4 Compound expressions
CLOSED: [2019-08-20 Tue 14:39]
#+begin_src scheme :exports both :results output :session
(define (a-plus-abs-b a b)
((if (> b 0) + -) a b))
(disp (a-plus-abs-b 3 4))
(disp (a-plus-abs-b 3 -4))
#+end_src
#+RESULTS:
: 7
: 7
*** DONE Exercise 1.5 Ben's test
CLOSED: [2019-08-20 Tue 14:50]
#+begin_src scheme :exports both :results value
(define (p) (p))
(define (test x y)
(if (= x 0) 0 y))
(test 0 (p))
#+end_src
On my interpreter this code goes into an infinite recursion, which
makes sense, I guess, since the second argument to (test) is evaluated
before executing (test). However, if we only substitute /p/ into the
application of test and try to traverse the tree depth-first, this
code should be able to terminate successfully?
*** DONE Exercise 1.6 If is a special form
CLOSED: [2019-08-21 Wed 14:05]
The problem with this Alyssa's (new-if) is that both arguments would
be computed, so this (new-if) would be either very inefficient or even
not working at all in the case when one of the arguments is
infeasible.
Consider:
#+begin_src scheme :exports both :results output :session
<<common>>
(define (new-if predicate then-clause else-clause)
(cond (predicate then-clause)
(else else-clause)))
(define a 1)
(define b 0)
(disp (if (not (= b 0)) (/ a b) a))
(new-if (not (= b 0)) (/ a b) a)
#+end_src
#+RESULTS:
: 1
: {Exception #19 user "divide by zero" () #<procedure #f> (#f . 127)}
However, this issue can be solved using scheme macros.
#+begin_src scheme :exports both :results output :session
<<common>>
(define-syntax new-if
(syntax-rules ()
( (new-if predicate then-clause else-clause)
(cond (predicate then-clause)
(else else-clause))
)
)
)
(define a 1)
(define b 0)
(disp (if (not (= b 0)) (/ a b) a))
(disp (new-if (not (= b 0)) (/ a b) a))
#+end_src
#+RESULTS:
: 1
: 1
The code above works as expected, because the macro does not evaluate
its arguments, and (cond) is a special form.
*** DONE Exercise 1.7 Good enough?
CLOSED: [2019-08-22 Thu 12:52]
This exercise is a very misleading one. On the first glance is seems
that this is just about formulating a good criterion. Make no mistake,
practically solving this task means really writing all this code
carefully.
The function we are interested in is:
\begin{equation}
\label{eq:5}
f(x) = \sqrt{x}
\end{equation}
The code given in the chapter before is equivalent to the following
Newton's method formula, where $f_i$ denotes the next guess:
\begin{equation}
\label{eq:1}
f_{i+1}_{} = \frac{f_i + \frac{x}{f_i}}{2}
\end{equation}
How on Earth does this formula even appear? Let's remember some
mathematics, namely, the Taylor series (variables unbound):
\begin{equation}
\label{eq:2}
f(x) = f(x_{0}_{}) + f'(x_{0})(x-x_{0}) + o(x)
\end{equation}
Let us call `true' value of $\sqrt{x}=f$. Let us call our first guess
$f_{0}$. What is the value of the difference (error) between them?
Clearly, $f-f_0$. Well, the problem is — we don't know $f$. But we do
know $f^2$. Therefore $f^2-f^2_0$ is a number we know. What will be the
error on the next step of the algorithm? Let's find $f_1$ as
$f_1=f_0+\delta$. If $\delta$ is not too big, we can use the Taylor
expansion from ref:eq:1 $\delta$.
\begin{equation}
\label{eq:8}
E = f^2 - f_0^2 = f^2 - (f_0 + \delta)^2 \approx f^2 - f_0^2 - 2f_0\delta
\end{equation}
Be careful. What I expanded here is not the function value. It is the
_error_ value. Now, clearly we want our error to be as small as
possible, desirably as little as machine precision would allow. So
assuming $E=0$, we get an equation to solve:
\begin{align}
\label{eq:9}
E=0 \leftrightarrow& f^2-f_0^2-2f_0\delta=0 \\
\delta =& \frac{f_0^2 -f^2 }{2f_0}
\end{align}
Remember though that we don't need just $\delta$ here. We actually need
$f_1$. But $f_1$ is just $f_0+\delta$.
\begin{align}
\label{eq:10}
f_1 = \frac{f^2 - f_0^2}{2f_0} + f_0
\end{align}
Now if you rearrange this formula, you will get exactly the formula
ref:eq:1.
The code below is copied from SICP verbatim and implements the
algorithm above.
#+begin_src scheme :exports both :results value :session :noweb-ref simple-sqrt-iter
(define (sqrt-iter guess x)
(if (good-enough? guess x)
guess
(sqrt-iter (improve guess x) x)))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value :noweb-ref square-improve
(define (improve guess x)
(average guess (/ x guess)))
#+end_src
#+begin_src scheme :exports both :results value :session :noweb-ref simple-newton-recursion
(define (good-enough? guess x)
(< (abs (- (square guess) x)) 0.001))
<<square-improve>>
(define (average x y)
(/ (+ x y) 2))
(define (sqrt x)
(sqrt-iter 1.0 x))
#+end_src
#+name simple-newton
#+begin_src scheme :exports both :results value :session
<<common>>
<<square>>
<<simple-sqrt-iter>>
<<simple-newton-recursion>>
(sqrt 9)
#+end_src
#+RESULTS:
: 3.00009155413138
An example of how this fails on small numbers:
#+begin_src scheme :exports both :results value
<<simple-newton>>
(square (sqrt 0.0004))
#+end_src
#+RESULTS:
: 0.0012532224857331766
An example of why this fails on big numbers I didn't manage to
craft. Perhaps chibi-scheme has some clever way to deal with rounding?
Anyway — here is the code:
#+begin_src scheme :exports both :results value
<<simple-newton>>
(square (sqrt 9999999999.0))
#+end_src
#+RESULTS:
: 9999999999.0
Why exactly this is not very good algorithms is a good question. The
derivative of the square is well-defined near the 0, although the
derivative of the square root is not. Therefore, the equation ref:eq:8
become very imprecise. As we see, big number seem to be working fine
in my scheme implementation.
Let us write a better sqrt-iter?.
#+begin_src scheme :exports both :results value :noweb-ref better-sqrt-iter
(define (sqrt-iter guess x)
(let ((better-guess (improve guess x)))
(if (good-enough? guess (square better-guess))
better-guess
(sqrt-iter better-guess x))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref better-newton
<<common>>
<<square>>
<<better-sqrt-iter>>
<<simple-newton-recursion>>
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value
<<better-newton>>
(square (sqrt 0.0004))
#+end_src
#+RESULTS:
: 0.0005452233379244715
Works faster and gives a better result. Seemingly. QED[fn:1].
*** DONE Exercise 1.8 Newton's method
CLOSED: [2019-08-22 Thu 17:36]
This exercise is not very hard. The only difference is that the
`improve' function is not derived from a derivative of a square but
rather from a derivative of a cube.
#+name: cube-improve
#+begin_src scheme :exports both :results value
(define (cube-improve guess x)
(/ (+ (/ x (* guess guess)) (* 2 guess)) 3))
#+end_src
#+RESULTS: cube-improve
: #<undef>
#+name: cube-good-enough
#+begin_src scheme :exports both :results value
(define (cube-good-enough? guess x)
(< (abs (- (cube guess) x)) 0.001))
#+end_src
#+RESULTS: cube-good-enough
: #<undef>
#+name: cube-root-iter
#+begin_src scheme :exports both :results value
(define (cube-root-iter guess x)
(let ((better-guess (cube-improve guess x)))
(disp better-guess)
(if (cube-good-enough? better-guess (cube guess))
better-guess
(cube-root-iter better-guess x))))
#+end_src
#+RESULTS: cube-root-iter
: #<undef>
#+name: cube-simple
#+begin_src scheme :exports both :results output
<<common>>
<<cube>>
<<cube-improve>>
<<cube-good-enough>>
<<cube-root-iter>>
(cube-root-iter 1.0 27.0)
#+end_src
#+RESULTS: cube-simple
: 9.666666666666666
: 6.540758356453956
: 4.570876778578707
: 3.4780192333867963
: 3.0626891086275365
: 3.001274406506175
: 3.0000005410641766
: 3.0000000000000977
*** TODO Figure 1.2 Procedural decomposition of the sqrt program
TODO
*** TODO Figure 1.3 A linear recursive process for computing \(6!\).
TODO
*** TODO Figure 1.4 A linear iterative process for computing \(6!\).
TODO
*** DONE Exercise 1.9 Iterative or recursive? :macro:er_macro_transformer:chicken:
CLOSED: [2019-08-29 Thu 15:14]
I didn't find (inc) and (dec) in my scheme, so I define them myself.
I still don't want to overload the "+" and "-" symbols, so I will call
them `plus' and `minus'.
#+name: example-substitution-first
#+begin_src scheme :exports both :results value
(define (inc x)
(+ 1 x))
(define (dec x)
(- x 1))
(define-syntax plusF
(er-macro-transformer
(lambda (form rename compare?)
(let ((a (cadr form))
(b (caddr form)))
n (if (= a 0) b `(inc (plusF ,(dec a) ,b)))))))
(macroexpand '(plusF 4 5))
#+end_src
#+RESULTS: example-substitution-first
| inc | (inc (inc (inc 5))) |
We can see that the macro expander has expanded the computation in to
a tree of length 4. This happens because the algorithm is genuinely
recursive, the return value is not produced by a call to itself, and
therefore recursion cannot be tail-optimized.
#+name: example-substitution-second
#+begin_src scheme :exports both :results value
(define (inc x)
(+ 1 x))
(define (dec x)
(- x 1))
(define-syntax plusS
(er-macro-transformer
(lambda (form rename compare?)
(let ((a (cadr form))
(b (caddr form)))
(if (= a 0) b `(plusS ,(dec a) ,(inc b)))))))
(macroexpand '(plusS 4 5))
#+end_src
#+RESULTS: example-substitution-second
: 9
We can clearly see the difference. The first macro is genuinely
recursive, it expands to a series of calls, and needs to keep the
information about this calls on the stack. The second one is actually
iterative. The macro call only happens as the last step, and no
information is kept, as the return value will be just the last result,
so this macro is expanded until it's just a number.
*** DONE Exercise 1.10 Ackermann's function
CLOSED: [2019-08-25 Sun 18:31]
Let's run the demos first:
#+name: ackerman
#+begin_src scheme :exports both :results output :session
<<common>>
(define (A x y)
(cond ((= y 0.0) 0.0)
((= x 0.0) (* 2.0 y))
((= y 1.0) 2.0)
(else (A (- x 1.0) (A x (- y 1.0))))))
(disp (A 1 10))
(disp (A 2 4))
(disp (A 3 3))
#+end_src
#+RESULTS: ackermann
: 1024.0
: 65536.0
: 65536.0
The values of these expressions are listed above.
#+begin_src scheme :exports both :results value :session
(define (f n) (A 0 n))
(define (g n) (A 1 n))
(define (h n) (A 2 n))
(define (k n) (* 5 n n))
#+end_src
#+RESULTS:
: #<undef>
The mathematical expressions for these formulae are:
\begin{eqnarray}
\label{eq:3}
f(n) & = & 2y\\
g(n) & = & 2^y \\
h(n) & = & 2^{2^n}\\
k(n) & = & 5n^2\\
\end{eqnarray}
Actually this is not the Ackermann's function as it is most often
defined, for example, see
[[http://mathworld.wolfram.com/AckermannFunction.html]]. But the
recurrent relation is the same. This version of the Ackermann's
function seems to be equivalent to the powers tower.
I may have lied with the coefficients, but essentially, the
Ackermann's function with parameters $n$ and $m$ works by applying the
n-the hyperoperator m times to 2. A hyperoperator is a generalization
of the standard matematical operator sequence `+', `*', `^', see
[[https://googology.wikia.org/wiki/Hyper_operator]]
*** TODO Figure 1.5 The tree-recursive process generated in computing (fib 5)
*** DONE Exercise 1.11 Recursive vs iterative
CLOSED: [2019-08-25 Sun 19:25]
\begin{equation}
\label{eq:4}
f(n)=\left\{
\begin{array}{l@{\quad:\quad}l}
n & n<3\\
f(n-1) + 2f(n-2) + 3f(n-3) & \ge 3
\end{array}\right.
\end{equation}
#+begin_src scheme :exports both :results value :session
(define (f-recursive n)
(cond ((< n 3) n)
(else
(+
(f-recursive (- n 1))
(* 2 (f-recursive (- n 2)))
(* 3 (f-recursive (- n 3)))))))
(f-recursive 7)
#+end_src
#+RESULTS:
: 142
#+begin_src scheme :exports both :results value :session
(define (f-iter m n fn-1 fn-2 fn-3)
(let ((fn (+ fn-1 (* 2 fn-2) (* 3 fn-3))))
(cond ((= m n) fn)
(else (f-iter m (+ n 1) fn fn-1 fn-2)))))
(define (f-iterative n)
(cond ((< n 3) n)
(else (f-iter n 3 2 1 0))))
(f-iterative 7)
#+end_src
#+RESULTS:
: 142
*** DONE Exercise 1.12 Recursive Pascal's triangle
CLOSED: [2019-08-25 Sun 19:42]
\begin{tabular}{rcccccccccc}
& & & & & 1\\\noalign{\smallskip\smallskip}
& & & & 1 & & 1\\\noalign{\smallskip\smallskip}
& & & 1 & & 2 & & 1\\\noalign{\smallskip\smallskip}
& & 1 & & 3 & & 3 & & 1\\\noalign{\smallskip\smallskip}
& 1 & & 4 & & 6 & & 4 & & 1\\\noalign{\smallskip\smallskip}
& & & & . & . & . & & & & \\\noalign{\smallskip\smallskip}
\end{tabular}
#+BEGIN_SRC scheme
(define (pascal-number line-number column-number)
(cond ((= line-number 1) 1)
((= line-number 2) 1)
((= column-number 1) 1)
((= column-number line-number) 1)
(else (+
(pascal-number (- line-number 1) (- column-number 1))
(pascal-number (- line-number 1) column-number)))))
(pascal-number 5 3)
#+END_SRC
#+RESULTS:
: 6
*** DONE Exercise 1.13 Fibonacci
CLOSED: [2019-08-25 Sun 23:04]
\begin{equation}
\label{eq:6}
\mbox{Fib}(n)=\left\{
\begin{array}{l@{\quad:\quad}l}
0 & n=0\\
1 & n=1\\
\mbox{Fib}(n-1) + \mbox{Fib}(n-2) & \mbox{otherwise}}
\end{array}\right.
\end{equation}
Abelson and Sussman define \(\varphi=(1+\sqrt{5})/2\) and \(\psi=(1-\sqrt{5})/2\).
Knowing that \( \mbox{Fib}(n) = (\varphi^{n} - \psi^n)/\sqrt{5}\) is almost all the
problem done, because \(\psi\) is clearly less than \(1\), so for large
\(n\) it will be exponentially close to \(0\), and this is where the
``closest integer'' comes from.
Let us prove the rest by induction.
\begin{eqnarray}
\label{eq:13}
\frac{\varphi^{n-1} - \psi^{n-1} + \varphi^{n-2} - \psi^{n-2}}{\sqrt{5}} &=& \frac{\varphi^{n} - \psi^{n}}{\sqrt{5}}\\
\varphi^{n-1} - \psi^{n-1} + \varphi^{n-2} - \psi^{n-2} &=& \varphi^{n} - \psi^{n} \\
(\varphi + 1)\varphi^{n-2} - (\psi + 1)\psi^{n-2} &=& \varphi^{n} - \psi^{n}\\
(\varphi + 1 - \varphi^2)\varphi^{n-2} &=& (\psi + 1 - \psi^2)\psi^{n-2}\\
(\frac{1+\sqrt{5}}{2} + 1 - (\frac{1+\sqrt{5}}{2})^2)\varphi^{n-2} &=&
(\frac{1-\sqrt{5}}{2} + 1 - (\frac{1-\sqrt{5}}{2}))\psi^{n-2} \\
(\frac{2+2\sqrt{5}}{4} + \frac{4}{4} - \frac{1+2\sqrt{5}+5}{4})\varphi^{n-2} &=&
(\frac{2-2\sqrt{5}}{4} + \frac{4}{4} - \frac{1-2\sqrt{5}+5}{4})\psi^{n-2}\\
0&=&0
\end{eqnarray}
This proves that the recurrent relation for \(\frac{\varphi^n-\psi^n}{\sqrt{5}}\) is the
same as for the Fibonacci sequence. Then if we prove that there exist
such \(n\) and \(n-1\) so that \(\mbox{Fib}(n) =
\frac{\varphi^n-\psi^n}{\sqrt{5}}\), then we're done.
Indeed, let's have a look at \(n=1\): \(\frac{1+\sqrt{5}}{2
\sqrt{5}} - \frac{1-\sqrt{5}}{2 \sqrt{5}} = 1\); and \(n=0\): \(
\frac{1-1}{\sqrt{5}} = 0\).
*** DONE Exercise 1.14 count-change :macro:er_macro_transformer:
CLOSED: [2019-08-30 Fri 16:09]
Let us use the non-standard but common er-macro-transformer to plot
the execution tree.
#+begin_src scheme :exports both :results output
(define-syntax cc
(er-macro-transformer
(lambda (form rename compare?)
(let ((amount (cadr form))
(kinds-of-coins (caddr form)))
(cond ((= amount 0) 1)
((or (< amount 0) (= kinds-of-coins 0)) 0)
(`(+ (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)))
(show #t " "(pretty (macroexpand '(cc 11 5))))
#+end_src
#+RESULTS:
: (+
: (+
: (+
: (+ (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 1)))))))))))
: (+ (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 (+ 0 1)))))) (+ (+ 0 1) 0)))
: (+ (+ (+ 0 1) 0) 0))
: 0)
: 0)
Initially I wrote the same code in Emacs Lisp, I am leaving it here
for future reference.
#+begin_src elisp :exports both :results output
(defmacro cc (amount kinds-of-coins)
(cond ((= amount 0) 1)
((or (< amount 0) (= kinds-of-coins 0)) 0)
(`(+ (cc ,amount
,(- kinds-of-coins 1))
(cc ,(- amount
(first-denomination
kinds-of-coins))
,kinds-of-coins)))))
(defun 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)))
(pp (macroexpand-all '(cc 11 5)))
#+end_src
#+RESULTS: ?
#+begin_example
(+
(+
(+
(+
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0 1)))))))))))
(+
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0
(+ 0 1))))))
(+
(+ 0 1)
0)))
(+
(+
(+ 0 1)
0)
0))
0)
0)
#+end_example
The space complexity of the algorithm will be dominated by the depth
of the tree — that is the value to be changed, as there is no need to
keep any additional information.
The time complexity can be estimated as follows: for every additional
value the algorithm will have to go through all passes of the
algorithm without an additional denomination, times the amount divided
by the value of an additional denomination. We can consider the
additional denomination value as a constant, and the amount of steps
for the simplest case of only one denomination is the
amount. Therefore, the algorithm is linear in amount and exponential
in the number of denominations.
\begin{equation}
\label{eq:14}
C = \Theta(n^a)
\end{equation}
*** I found a bug in ob-scheme while doing this Exercise.
_In process I have found a bug in org-babel!_
#+begin_src scheme :exports both :results output
(display "(+ 0) ")
#+end_src
#+RESULTS:
: 0
#+begin_src scheme :exports both :results output
(display "(+ 0)")
#+end_src
#+RESULTS:
| + | 0 |
(org-babel-script-escape "(+ 0)") (org-babel-script-escape "(+ 0) ")
*** DONE Exercise 1.15 sine :macro:er_macro_transformer:
CLOSED: [2019-08-30 Fri 22:34]
First let us code this thing:
Loop version:
#+begin_src scheme :exports both :results output
(define niter 0)
(define (cube x) (* x x x))
(define (p x)
(set! niter (+ niter 1))
(- (* 3 x) (* 4 (cube x))))
(define (sine angle)
(if (not (> (abs angle) 0.1))
angle
(p (sine (/ angle 3.0)))))
(display "sine=" )
(display (sine 12.15))
(display " niter=")
(display niter)
#+end_src
#+RESULTS:
: sine=-0.39980345741334 niter=5
Let's have the macro system expand this for us.
#+begin_src scheme :exports both :results output
(define (cube x)
(* x x x))
(define (p x)
(- (* 3 x)
(* 4 (cube x))))
(define-syntax sine
(er-macro-transformer
(lambda (form rename compare?)
(let ((a (cadr form)))
(if (< (abs a) 0.1)
a
`(p (sine ,(/ a 3))))))))
(show #t " " (pretty (macroexpand '(sine 12.15))))
#+end_src
#+RESULTS:
: (p (p (p (p (p 0.05)))))
Theoretically, we can expand everything at once.
#+begin_src scheme :exports both :results output
(define-syntax cube
(er-macro-transformer
(lambda (form rename compare?)
(let ((x (cadr form)))
`(* ,x ,x ,x)))))
(define-syntax p
(er-macro-transformer
(lambda (form rename compare?)
(let ((x (cadr form)))
`(- (* 3 ,x)
(* 4 (cube ,x)))))))
(define-syntax sine
(er-macro-transformer
(lambda (form rename compare?)
(let ((a (cadr form)))
(if (< (abs a) 0.1)
a
`(p (sine ,(/ a 3))))))))
(show #t " " (pretty (macroexpand '(sine 12.15))))
#+end_src
#+RESULTS:
#+begin_example
(-
(* 3
(-
(* 3
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))))))
(* 4
(*
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))))))
(* 4
(*
(-
(* 3
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))))))
(* 4
(*
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))))))))
(-
(* 3
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))))))
(* 4
(*
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))))))))
(-
(* 3
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))))))
(* 4
(*
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))
(-
(* 3
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))
(* 4
(*
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))))
(- (* 3 (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05))))
(* 4
(* (- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))
(- (* 3 0.05) (* 4 (* 0.05 0.05 0.05)))))))))))))))
#+end_example
As seen from the code above, the amount of steps is 5. It is easily
seen from the fact that the application of ~p~ starts when *x* is
sufficiently small, and that requires \(0.1 > 12.15\cdot(\frac{1}{3})^n \Rightarrow n
= O(\log_3 121.5)\) steps.
~(sine x)~ is expandable in constant space and time, ~(cube x)~ is
expandable in constant space and time if multiplication is an
elementary operation. Therefore the only operation left is
~p~. Therefore, time and space are of equal order of magnitude.
- \(\left\lceil \log_3 121.5 \right\rceil = 5\)
- \(O(\ln(a\cdot b))\) where \(a\) is the angle and \(b\) is precision
*** DONE Exercise 1.16 Iterative exponentiation
CLOSED: [2019-08-30 Fri 23:20]
For the start, let's input the code.
#+begin_src scheme :exports both :results value
(define (expt b n)
(if (= n 0)
1
(* b (expt b (- n 1)))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value
(define (expt b n)
(expt-iter b n 1))
(define (expt-iter b counter product)
(if (= counter 0)
product
(expt-iter b
(- counter 1)
(* b counter product))))
#+end_src
#+begin_src scheme :exports both :results value
(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 (even? n)
(= (remainder n 2) 0))
(fast-expt 2 10)
#+end_src
#+RESULTS:
: 1024
#+begin_src scheme :exports both :results value
(define (fast-expt b n a)
(cond ((= n 0) a)
((even? n) (fast-expt (square b) (/ n 2) a))
(else (fast-expt b (- n 1) (* a b)))))
(define (even? n)
(= (remainder n 2) 0))
(define (faster-expt b n)
(fast-expt b n 1))
(faster-expt 2 10)
#+end_src
#+RESULTS:
: 1024
The answer is the code block above. We just collect some data and put
it into the state variable *a*.
*** DONE Exercise 1.17 Fast multiplication
CLOSED: [2019-08-30 Fri 23:48]
#+begin_src scheme :exports both :results value
(define (double a)
(* 2 a))
(define (halve a)
(if (even? a)
(/ a 2)
(raise "Error: a not even.")))
(define (even? n)
(= (remainder n 2) 0))
(define (* a b)
(cond
((= b 0) 0)
((even? b) (double (* a (halve b))))
(else (+ a (* a (- b 1))))))
(* 137 17)
#+end_src
#+RESULTS:
: 2329
The procedure above uses logarithmic time and space, because for every
subtraction there is also at least one division, so the total
convergence speed is exponential. This could be reformulated as an
iterative procedure, with an accumulator variable, but I am too lazy.
*** DONE Exercise 1.18 Iterative multiplication
CLOSED: [2019-08-31 Sat 11:43]
In Exercise 1.17 I said that I was too lazy to design an iterative
procedure. Well, now I do it in this exercise.
#+begin_src scheme :exports both :results value
(define (double a)
(* 2 a))
(define (halve a)
(if (even? a)
(/ a 2)
(raise "Error: a not even.")))
(define (even? n)
(= (remainder n 2) 0))
(define (mul a b accumulator)
(cond
((= b 0) accumulator)
((even? b) (mul (double a) (halve b)))
(else (mul a (- b 1) (+ a accumulator)))))
(* 137 17)
#+end_src
#+RESULTS:
: 2329
The idea here is exactly the same as in the previous Exercise 1.18.
*** DONE Exercise 1.19 Logarithmic Fibonacci
CLOSED: [2019-09-01 Sun 20:42]
As usualy, let's first copy the code of ~fib-iter~.
#+begin_src scheme :exports both :results value
(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))))
(fib 10)
#+end_src
#+RESULTS:
: 55
The formula for \(T\) is the following:
\begin{eqnarray}
T_{pq} \begin{pmatrix} a\\ b \end{pmatrix} & = & \begin{pmatrix} aq+bq+ap \\ bp + aq \end{pmatrix} &\\
T_{pq} \left( T_{pq} \begin{pmatrix} a\\ b \end{pmatrix} \right) & = & \begin{pmatrix} (aq+bq+ap)q+(bp + aq)q+(aq+bq+ap)p \\ (bp + aq)p + (aq+bq+ap)q \end{pmatrix} &\\
T_{p'q'}\begin{pmatrix} a\\ b \end{pmatrix} & = & \begin{pmatrix}a(2pq + qq) + a(pp+qq) + b(2pq + qq)\\ a(2pq + qq) + b(pp + qq) \end{pmatrix}& \\
\end{eqnarray}
From here we can easily see the values for \(p\prime\) and \(q'\):
# \(a(2pq + qq) + a(pp+qq) + b(2pq + qq)\)
# \(a(2pq + qq) + b(pp + qq)\)
\(p'=pp+qq\), \(q' = 2pq+qq\)
Let us substitute them into the code given by Abelson and Sussman.
#+begin_src scheme :exports both :results value
(define (fib 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))
(+ (* 2 p q) (* q q))
(/ count 2)))
(else (fib-iter (+ (* b q) (* a q) (* a p))
(+ (* b p) (* a q))
p
q
(- count 1)))))
(fib 10)
#+end_src
#+RESULTS:
: 55
Works.
*** *Interjection* ir-macro-transformer.
#+begin_src scheme :exports both :results value
(define-syntax swap!
(ir-macro-transformer
(lambda (form inject compare?)
(let ((a (cadr form))
(b (caddr form))
(tmp (cadr form)))
(set! a b)
(set! b tmp)))))
(define x 4)
(define y 5)
(swap! x y)
(list x y)
#+end_src
#+RESULTS:
: "{Exception #19 user \"undefined variable\" (ir-macro-transformer) #<procedure #f> (#f . 3)}"
*** DONE Exercise 1.20 GCD applicative vs normal :er_macro_transformer:macro:
CLOSED: [2019-09-01 Sun 23:04]
The exercise urges us to recall the difference between the normal
order and the applicative order of evaluation.
*Normal*: fully expand the computation tree until obtained an
expression involving only primitive operators.
*Applicative*: evaluate the arguments and then apply.
First let us print the execution tree of the normal order.
#+begin_src scheme :exports both :results output
(define-syntax gcd-normal
(er-macro-transformer
(lambda (form rename compare?)
(let ((a (cadr form))
(b (caddr form)))
(if (= b 0)
`(if (= ,b 0)
,a
(remainder ,a ,b))
`(if (= ,b 0)
(,a (remainder ,a ,b))
(gcd-normal ,b ,(remainder a b))))))))
(display (show #f " " (pretty (macroexpand '(gcd-normal 206 40)))))
#+end_src
#+RESULTS:
: (if (= 40 0)
: (206 (remainder 206 40))
: (if (= 6 0)
: (40 (remainder 40 6))
: (if (= 4 0)
: (6 (remainder 6 4))
: (if (= 2 0) (4 (remainder 4 2)) (if (= 0 0) 2 (remainder 2 0))))))
Now let us show the applicative order.
#+begin_src scheme :exports both :results output
(define-syntax gcd-normal
(er-macro-transformer
(lambda (form rename compare?)
(let ((a (cadr form))
(b (caddr form)))
(if (= b 0)
`(if (= ,b 0)
,a
'division-by-zero)
`(if (= ,b 0)
(,a (remainder ,a ,b))
(gcd-normal ,b ,(remainder a b))))))))
(display (show #f " " (pretty (macroexpand '(gcd-normal 206 40)))))
#+end_src
#+RESULTS:
: (if (= 40 0)
: (206 (remainder 206 40))
: (if
: (= 6 0)
: (40 (remainder 40 6))
: (if (= 4 0)
: (6 (remainder 6 4))
: (if (= 2 0) (4 (remainder 4 2)) (if (= 0 0) 2 'division-by-zero)))))
The problem here would arise, if the ~(if)~ form had a normal
evaluation order, because the last division, ~(remainder 2 0)~ may be
a forbidden operation, involving a division by zero. On the other
hand, the evaluation of ~(remainder x 0)~ could be defined as *x*, and
then the algorithm would evaluate one more (useless) remainder.
*** DONE Exercise 1.21 smallest-divisor
CLOSED: [2019-09-01 Sun 23:43]
As usual, let us first copy the code for the ~smallest-divisor~.
#+begin_src scheme :exports both :results output :noweb-ref primetest
(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)))
#+end_src
#+begin_src scheme :exports both :results output
<<primetest>>
(display (smallest-divisor 199))
(newline)
(display (smallest-divisor 1999))
(newline)
(display (smallest-divisor 19999))
(newline)
(display (/ 19999 7))
(newline)
#+end_src
#+RESULTS:
: 199
: 1999
: 7
: 2857
Well, this problem doesn't look too complicated on the first glance.
*** DONE Exercise 1.22 timed-prime-test
CLOSED: [2019-09-02 Mon 00:44]
#+begin_src scheme :exports both :results output :noweb-ref timed-primetest
(define (runtime) (* 1000 (current-second)))
(define (timed-prime-test n)
(newline)
(display n)
(start-prime-test n (runtime)))
(define (start-prime-test n start-time)
(if (prime? n)
(report-prime (- (runtime) start-time))))
(define (report-prime elapsed-time)
(display " *** ")
(display elapsed-time))
(define (search-for-primes start finish)
(timed-prime-test start)
(if (< (+ 1 start) finish)
(if (even? start)
(search-for-primes (+ start 1) finish)
(search-for-primes (+ start 2) finish))))
#+end_src
#+begin_src scheme :exports both :results output
<<primetest>>
<<timed-primetest>>
(search-for-primes 1000 1020)
(newline)
(search-for-primes 10000 10038)
(newline)
(search-for-primes 100000 100044)
(newline)
(search-for-primes 1000000 1000038)
#+end_src
#+RESULTS:
#+begin_example
1000
1001
1003
1005
1007
1009 *** 0.006103515625
1011
1013 *** 0.005859375
1015
1017
1019 *** 0.005859375
10000
10001
10003
10005
10007 *** 0.016845703125
10009 *** 0.016845703125
10011
10013
10015
10017
10019
10021
10023
10025
10027
10029
10031
10033
10035
10037 *** 0.016845703125
100000
100001
100003 *** 0.052978515625
100005
100007
100009
100011
100013
100015
100017
100019 *** 0.052978515625
100021
100023
100025
100027
100029
100031
100033
100035
100037
100039
100041
100043 *** 0.052001953125
1000000
1000001
1000003 *** 0.163818359375
1000005
1000007
1000009
1000011
1000013
1000015
1000017
1000019
1000021
1000023
1000025
1000027
1000029
1000031
1000033 *** 0.1650390625
1000035
1000037 *** 0.1640625
#+end_example
- Write the procedure: done.
- Find the smallest three primes greater than 1000 : found.
- Find the smallest three primes greater than 10000 : found.
- Find the smallest three primes greater than 100000 : found.
- Find the smallest three primes greater than 1000000: found.
- The timing data confirms the prediction. \(\sqrt{10}\approx3\), \(0.16 \approx 3\cdot1.05\).
- The execution time per step for testing 1.000.000 is 1.63e-07. The
execution time per step for testing 100.000 5.3199e-07. At least on
my machine the claim doesn't seem to hold very well.
*** DONE Exercise 1.23 (next test-divisor)
CLOSED: [2019-09-02 Mon 09:56]
#+begin_src scheme :exports both :results value :noweb-ref improved-primetest
(define (next x)
(if (= 2 x)
3
(+ x 2)))
(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 (next test-divisor)))))
(define (divides? a b) (= (remainder b a) 0))
(define (prime? n)
(= n (smallest-divisor n)))
#+end_src
#+begin_src scheme :exports both :results output
<<improved-primetest>>
<<timed-primetest>>
(timed-prime-test 1009)
(timed-prime-test 1013)
(timed-prime-test 1019)
(timed-prime-test 10007)
(timed-prime-test 10009)
(timed-prime-test 10037)
(timed-prime-test 100003)
(timed-prime-test 100019)
(timed-prime-test 100043)
(timed-prime-test 1000003)
(timed-prime-test 1000033)
(timed-prime-test 1000037)
#+end_src
#+RESULTS:
#+begin_example
1009 *** 0.010009765625
1013 *** 0.00390625
1019 *** 0.00390625
10007 *** 0.010009765625
10009 *** 0.010009765625
10037 *** 0.010009765625
100003 *** 0.031005859375
100019 *** 0.03076171875
100043 *** 0.030029296875
1000003 *** 0.10205078125
1000033 *** 0.104736328125
1000037 *** 0.10205078125
#+end_example
We can see that the test does show a speed improvement, although not
as impressive as 2 times. We can observe that the number of steps is
not really halved, since ~(+ a b)~ requires one operation, and ~(if (=
2 x) 3 else (+ 3 2))~ requires three operations, so the speed should
improve by 3/2, which we can observe.
*** DONE Exercise 1.24 Fermat method
CLOSED: [2019-09-02 Mon 11:32]
Firstly we need the ~(fast-prime?)~ procedure.
#+begin_src scheme :exports both :results value :noweb-ref random
(define (random x)
(random-integer x))
#+end_src
#+RESULTS:
: 30
#+begin_src scheme :exports both :results value :noweb-ref expmod
(define (expmod base exp m)
(cond ((= exp 0) 1)
((even? exp)
(remainder
(square (expmod base (/ exp 2) m))
m))
(else
(remainder
(* base (expmod base (- exp 1) m))
m))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref fermat-primetest
<<random>>
(define (fermat-test n)
(define (try-it a)
(= (expmod a n n) a))
(try-it (+ 1 (random (- n 1)))))
(define prime-test fermat-test)
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref fast-prime
(define (fast-prime? n times)
(cond ((= times 0) true)
((prime-test n) (fast-prime? n (- times 1)))
(else false)))
(define true #t)
(define false #f)
(define (prime? x)
(fast-prime? x 10))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<expmod>>
<<fermat-primetest>>
<<fast-prime>>
<<timed-primetest>>
(timed-prime-test 1009)
(timed-prime-test 1013)
(timed-prime-test 1019)
(timed-prime-test 10007)
(timed-prime-test 10009)
(timed-prime-test 10037)
(timed-prime-test 100003)
(timed-prime-test 100019)
(timed-prime-test 100043)
(timed-prime-test 1000003)
(timed-prime-test 1000033)
(timed-prime-test 1000037)
(timed-prime-test 1000)
(timed-prime-test 6601)
#+end_src
#+RESULTS:
#+begin_example
1009 *** 0.0830078125
1013 *** 0.057861328125
1019 *** 0.060791015625
10007 *** 0.072998046875
10009 *** 0.071044921875
10037 *** 0.07275390625
100003 *** 0.083251953125
100019 *** 0.0849609375
100043 *** 0.085693359375
1000003 *** 0.09521484375
1000033 *** 0.09619140625
1000037 *** 0.09814453125
1000
6601 *** 0.0478515625
#+end_example
Firstly, observe that the interpreter seems to be doing some black magic, so
that the test for 1009 takes more time than the test for 1013.
Secondly, observe that indeed, the speed seems to have reduced its dependence
on the length of a number, and if we want to test even bigger numbers, the
dependency should become even smaller, as \(\log(n)\) grows very slowly. In
particular, comparing the range around 1000 and 1000.000, the ratio of
\(\frac{\log_{10}(1000000)}{\log_{10}(1000)} = \frac{6}{3} = 2\). This doesn't seem
to be completely the case, but hey, there may be some constants involved, as
well as some interpreter dark magic.
*** DONE Exercise 1.25 expmod
CLOSED: [2019-09-02 Mon 12:46]
Well, in principle, Alyssa's algorithm should work. The problem here really
is that we would have to store the number \(a^n\), which is a very big number,
especially because we are interested in testing primality of very large
numbers (e.g., 512-bit long cryptography keys), and \((2^{256-1})^{2^{256}}\)
is a very large number.
*** DONE Exercise 1.26 square vs mul
CLOSED: [2019-09-02 Mon 12:50]
The hint here lies in the name of the person helping Louis. Eva Lu Ator
sounds similar to "evaluator", and the reason for Louis's problem really lies
in the optimization capabilities of the interpreter. That is, if the
evaluating algorithm uses applicative order, then the ~expmod~ is evaluated
twice per step, which makes ~(/ exp 2)~ useless. If, however, the interpreter
can memoize the results, his algorithm would be just as good.
*** DONE Exercise 1.27 Carmichael numbers
CLOSED: [2019-09-02 Mon 20:50]
First let us recall some Carmichael numbers.
| # | |
|---+------|
| 1 | 561 |
| 2 | 1105 |
| 3 | 1729 |
| 4 | 2465 |
| 5 | 2821 |
| 6 | 6601 |
We already have a procedure that computes \(a^n\mod n\), and a procedure that
computes \(a\mod n\) is even a scheme primitive. Moreover, we even have all
the code that does the comparison, with the single difference - our existing
code takes an initial guess uniformly at random, whereas we need to check all
\( a < n\).
#+begin_src scheme :exports both :results output
<<expmod>>
(define (congruent? a n)
(= (expmod a n n) a))
(define (carmichael-iter a n)
(cond ((= a n) #t)
((not (congruent? a n)) #f)
(else (carmichael-iter (+ 1 a) n))))
(define (carmichael-or-prime? n)
(carmichael-iter 1 n))
(define (test-carmichael n)
(display "Testing ")
(display n)
(display ": ")
(if (carmichael-or-prime? n)
(display "true")
(display "false"))
(newline))
(test-carmichael 561)
(test-carmichael 1105)
(test-carmichael 1729)
(test-carmichael 2465)
(test-carmichael 2821)
(test-carmichael 6601)
(test-carmichael 20)
(test-carmichael 7)
#+end_src
#+RESULTS:
: Testing 561: true
: Testing 1105: true
: Testing 1729: true
: Testing 2465: true
: Testing 2821: true
: Testing 6601: true
: Testing 20: false
: Testing 7: true
*** DONE Exercise 1.28 Miller-Rabin
CLOSED: [2019-09-02 Mon 23:28]
#+begin_src scheme :exports both :results value :noweb-ref expmod-miller-rabin
(define (expmod base exp m)
(cond ((= exp 0) 1)
((even? exp)
(let* ((root (expmod base (/ exp 2) m))
(sq (square root)))
(if (and (= (remainder sq m) 1) (not (or (= root 1) (= root (- m 1)))))
0
(remainder sq m))))
(else
(remainder
(* base (expmod base (- exp 1) m))
m))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value :noweb-ref miller-rabin-primetest
<<random>>
(define (rabin-test n)
(define (try-it a)
(let ((result (expmod a (- n 1) n) ))
(if (or (= 1 result) (= n 1) (= n 0))
#t
#f)))
(if (not (= n 1)) (try-it (+ 1 (random (- n 1)))) #t))
(define prime-test rabin-test)
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output :noweb-ref rabin-prime
<<expmod-miller-rabin>>
<<miller-rabin-primetest>>
<<fast-prime>>
<<timed-primetest>>
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<rabin-prime>>
(timed-prime-test 1009)
(timed-prime-test 1013)
(timed-prime-test 1019)
(timed-prime-test 10007)
(timed-prime-test 10009)
(timed-prime-test 10037)
(timed-prime-test 100003)
(timed-prime-test 100019)
(timed-prime-test 100043)
(timed-prime-test 1000003)
(timed-prime-test 1000033)
(timed-prime-test 1000037)
(timed-prime-test 1000)
(timed-prime-test 6601)
#+end_src
#+RESULTS:
#+begin_example
1009 *** 0.09716796875
1013 *** 0.086669921875
1019 *** 0.087158203125
10007 *** 0.1220703125
10009 *** 0.113037109375
10037 *** 0.113037109375
100003 *** 0.130859375
100019 *** 0.133056640625
100043 *** 0.132080078125
1000003 *** 0.151123046875
1000033 *** 0.172119140625
1000037 *** 0.156982421875
1000
6601
#+end_example
I used the ~(let)~ construction introduced in the later chapters, because I
find bindings with nested procedures confusing.
*** DONE Exercise 1.29 Simpson's integral
CLOSED: [2019-09-03 Tue 10:36]
Since at the end of the task we are told to compare the result of our
algorithm with the results of the ~integral~ procedure, let us first copy the
integral code.
#+begin_src scheme :exports both :results value :noweb-ref integral-common
(define (sum term a next b)
(if (> a b)
0
(+ (term a)
(sum term (next a) next b))))
(define (cube x)
(* x x x))
(define (next point)
(+ point 1))
#+end_src
#+begin_src scheme :exports both :results value
<<integral-common>>
(define (integral f a b dx)
(define (add-dx x)
(+ x dx))
(* (sum f (+ a (/ dx 2.0)) add-dx b)
dx))
(list (integral cube 0 1 0.01) (integral cube 0 1 0.001))
#+end_src
#+RESULTS:
| 0.24998750000000053 | 0.24999987500000106 |
#+begin_src scheme :exports both :results output
<<integral-common>>
(define (integral-simpson f a b npoints)
(define h (/ (- b a) npoints))
(define h/3 (/ h 3))
(define (f_k k)
(* (f (+ a (* k h))) (cond ((= k 0) 1)
((= k npoints) 1)
((odd? k) 4)
((even? k) 2))))
(* h/3 (sum f_k 0 next npoints)))
(display (integral-simpson cube 0 1 100))
(newline)
(display (integral-simpson cube 0 1 1000))
#+end_src
#+RESULTS:
: 1/4
: 1/4
An impressive result. I don't know at which point of the computation the
interpreter switches to an exact representation, but meh, this result is good.
*** DONE Exercise 1.30 Iterative sum
CLOSED: [2019-09-03 Tue 11:19]
#+begin_src scheme :exports both :results output
(define (inc x) (+ x 1))
(define (identity x) x)
(define (sum term a next b)
(define (iter a result)
(if (= a b)
(+ a result)
(iter (next a) (+ a result))))
(iter a 0))
(sum identity 1 inc 10)
#+end_src
#+RESULTS:
: 55
*** DONE Exercise 1.31 Product
CLOSED: [2019-09-03 Tue 11:59]
**** DONE a. Defining product
CLOSED: [2019-09-03 Tue 11:56]
#+begin_src scheme :exports both :results value
(define (inc x) (+ x 1))
(define (identity x) x)
(define (product term a next b)
(define (iter a result)
(if (= a b)
(* (term a) result)
(iter (next a) (* (term a) result))))
(iter a 1.0))
(define (factorial x) (product identity 1 inc 6))
(factorial 6)
(define (pi precision)
(define (enumerator index)
(cond ((odd? index) (+ index 1.0))
((even? index) (+ index 2.0))
(else (error "Error"))))
(define (denominator index)
(cond ((odd? index) (+ index 2.0))
((even? index) (+ index 1.0))
(else (error "Error"))))
(define (fraction index)
(/ (enumerator index) (denominator index)))
(* 4.0 (product fraction 1 inc precision)))
(pi 1280)
#+end_src
#+RESULTS:
: 3.142818162579486
I can say that it converges very-very slowly.
**** DONE b. A recursive version
CLOSED: [2019-09-03 Tue 11:59]
#+begin_src scheme :exports both :results value
(define (inc x) (+ x 1))
(define (identity x) x)
(define (product term a next b)
(define (iter a result)
(if (= a b)
(* (term a) result)
(* (iter (next a) (term a)) result)))
(iter a 1.0))
(define (factorial x) (product identity 1 inc 6))
(factorial 6)
#+end_src
#+RESULTS:
: 720.0
Doesn't make too much sense to me, but here you are.
*** DONE Exercise 1.32 Accumulator
CLOSED: [2019-09-03 Tue 12:23]
I will cheat a little bit in this exercise, I will run ~sum~ as an iterative
procedure and ~product~ as a recursive procedure, so at the end I will have
two implementations, not 4, but that should not be too much of a digression.
#+begin_src scheme :exports both :results value :noweb-ref accumulator-common
(define (inc x) (+ x 1))
(define (identity x) x)
#+end_src
**** DONE Implement ~sum~ in terms of an iterative accumulator
CLOSED: [2019-09-03 Tue 12:23]
#+begin_src scheme :exports both :results value
<<accumulator-common>>
(define (accumulate combiner null-value term a next b)
(define (iter a result)
(if (>= a b)
(combiner (term a) result)
(combiner (iter (next a) (term a)) result)))
(iter a null-value))
(define (sum term a next b)
(accumulate + 0 term a next b))
(sum identity 1 inc 10)
#+end_src
#+RESULTS:
: 55
**** DONE Implement ~product~ in terms of a recursive process
CLOSED: [2019-09-03 Tue 12:22]
#+begin_src scheme :exports both :results value
<<accumulator-common>>
(define (accumulate combiner null-value term a next b)
(define (iter a result)
(if (= a b)
(combiner (term a) result)
(iter (next a) (combiner (term a) result) )))
(iter a null-value))
(define (product term a next b)
(accumulate * 1 term a next b))
(product identity 1 inc 10)
#+end_src
#+RESULTS:
: 3628800
*** DONE Exercise 1.33 filtered-accumulate
CLOSED: [2019-09-03 Tue 14:36]
**** DONE a. Sum-of-squares-of-primes
CLOSED: [2019-09-03 Tue 14:24]
#+begin_src scheme :exports both :results value :noweb-ref filtered-accumulate
<<accumulator-common>>
<<rabin-prime>>
(define (filtered-accumulate combiner filter null-value term a next b)
(define (iter a result)
(if (= a b)
(combiner (if (filter a) (term a) null-value) result)
(iter (next a) (combiner (if (filter a) (term a) null-value) result))))
(iter a null-value))
#+end_src
#+begin_src scheme :exports both :results value
<<filtered-accumulate>>
(define (sum-square-prime a next b)
(filtered-accumulate + prime? 0 square a next b))
(sum-square-prime 1 inc 10)
#+end_src
#+RESULTS:
: 88
**** DONE b. Product of positive integers mutually prime with n
CLOSED: [2019-09-03 Tue 14:36]
#+begin_src scheme :exports both :results output
<<filtered-accumulate>>
(define (product-mutually-prime n)
(define (filter-gcd x)
(if (= (gcd n x) 1)
#t
#f))
(filtered-accumulate * filter-gcd 1 identity 1 inc n))
(display (product-mutually-prime 10))
#+end_src
#+RESULTS:
: 189
Here I used the ~gcd~ function from the standard library.
*** DONE Exercise 1.34 lambda
CLOSED: [2019-09-03 Tue 14:44]
#+begin_src scheme :exports both :results value :noweb-ref example-lambda
(define (f g) (g 2))
#+end_src
#+begin_src scheme :exports both :results value
<<example-lambda>>
(define (square x) (* x x))
(f square)
#+end_src
#+RESULTS:
: 4
#+begin_src scheme :exports both :results value
<<example-lambda>>
(f (lambda (z) (* z (+ z 1))))
#+end_src
#+RESULTS:
: 6
#+begin_src scheme :exports both :results value
<<example-lambda>>
(f f)
#+end_src
#+RESULTS:
: "{Exception #19 user \"non procedure application\" (2) #<procedure #f> (\"/usr/lib64/chibi/init-7.scm\" . 230)}"
Well, no wonder. The final combination reduces to ~(2 2)~, which *IS* a
non-procedure application.
*** DONE Exercise 1.35 fixed-point
CLOSED: [2019-09-03 Tue 21:05]
\(\varphi = \frac{1+\sqrt{5}}{2}\)
\(x\mapsto 1+\frac{1}{x}\)
Let's substitute:
\( \frac{1+\sqrt{5}}{2} &=& 1+ \frac{2}{1+\sqrt{5}} \)
\( (1+\sqrt{5})^2 = 2(1+\sqrt{5})+ 4\)
\( 1 + 2 \sqrt{5} + 5 = 2 + 2 \sqrt{5} + 4 \)
\(6 = 6\)
#+begin_src scheme :exports both :results value :noweb-ref fixed-point-silent
(define tolerance 0.00001)
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(< (abs (- v1 v2))
tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
#+end_src
#+begin_src scheme :exports both :results value
<<fixed-point-silent>>
(fixed-point cos 1.0)
#+end_src
#+RESULTS:
: 0.7390822985224024
#+begin_src scheme :exports both :results value
<<fixed-point-silent>>
(define (golden-transform x)
(+ 1 (/ 1 x)))
(fixed-point golden-transform 1.0)
#+end_src
#+RESULTS:
: 1.6180327868852458
#+begin_src scheme :exports both :results value
(/ (+ 1 (sqrt 5)) 2)
#+end_src
#+RESULTS:
: 1.618033988749895
The difference is not too big.
*** DONE Exercise 1.36 fixed-point-with-dampening
CLOSED: [2019-09-03 Tue 21:55]
#+begin_src scheme :exports both :results value :noweb-ref fixed-point-verbose
(define tolerance 0.00001)
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(display "Guesses: ")
(display v1)
(display " ")
(display v2)
(newline)
(< (abs (- v1 v2))
tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
#+end_src
To find a solution to \(x^x=1000\), let us rearrange: \( x = \log_x1000 =
\frac{\log 1000}{\log x}\).
#+begin_src scheme :exports both :results value :noweb-ref log1000
(define (log1000/logx x)
(/ (log 1000) (log x)))
#+end_src
#+begin_src scheme :exports both :results output
<<fixed-point-verbose>>
<<log1000>>
(display (fixed-point log1000/logx 5))
#+end_src
#+RESULTS:
#+begin_example
Guesses: 5 4.29202967422018
Guesses: 4.29202967422018 4.741863119908242
Guesses: 4.741863119908242 4.438204569837609
Guesses: 4.438204569837609 4.635299887107611
Guesses: 4.635299887107611 4.50397811613643
Guesses: 4.50397811613643 4.589989462723705
Guesses: 4.589989462723705 4.53301150767844
Guesses: 4.53301150767844 4.570475672855484
Guesses: 4.570475672855484 4.545720389670642
Guesses: 4.545720389670642 4.562024936588171
Guesses: 4.562024936588171 4.551263234080531
Guesses: 4.551263234080531 4.55835638768598
Guesses: 4.55835638768598 4.553676852183342
Guesses: 4.553676852183342 4.55676216434628
Guesses: 4.55676216434628 4.554727130670954
Guesses: 4.554727130670954 4.556069054770006
Guesses: 4.556069054770006 4.555184018843625
Guesses: 4.555184018843625 4.5557676565438205
Guesses: 4.5557676565438205 4.555382746639082
Guesses: 4.555382746639082 4.55563658243586
Guesses: 4.55563658243586 4.555469180245326
Guesses: 4.555469180245326 4.555579577901
Guesses: 4.555579577901 4.5555067722873686
Guesses: 4.5555067722873686 4.5555547860484085
Guesses: 4.5555547860484085 4.555523121789556
Guesses: 4.555523121789556 4.555544003742869
Guesses: 4.555544003742869 4.555530232469306
Guesses: 4.555530232469306 4.555539314360711
4.555539314360711
#+end_example
#+begin_src scheme :exports both :results value :noweb-ref fixed-point-verbose-with-dampening
(define tolerance 0.00001)
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(display "Guesses: ")
(display v1)
(display " ")
(display v2)
(newline)
(< (abs (- v1 v2))
tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try (/ (+ guess next) 2)))))
(try first-guess))
#+end_src
#+begin_src scheme :exports both :results output
<<fixed-point-verbose-with-dampening>>
<<log1000>>
(display (fixed-point log1000/logx 5))
#+end_src
#+RESULTS:
: Guesses: 5 4.29202967422018
: Guesses: 4.64601483711009 4.49720773504196
: Guesses: 4.571611286076025 4.544977348996107
: Guesses: 4.558294317536066 4.553717728226165
: Guesses: 4.556006022881116 4.555225576581478
: Guesses: 4.555615799731297 4.555482885419889
: Guesses: 4.555549342575593 4.555526711628406
: Guesses: 4.555538027102 4.555534173941779
: 4.555534173941779
Well, the amount of steps is visibly smaller. Works.
*** DONE Exercise 1.37 cont-frac
CLOSED: [2019-09-04 Wed 10:34]
**** DONE a. recursive
CLOSED: [2019-09-04 Wed 11:35]
#+begin_src scheme :exports both :results value :noweb-ref cont-frac-recursive
(define (cont-frac n d k)
(define (next step)
(if (< step k)
(/ (n step) (+ (d step) (next (+ step 1))) )
0))
(next 1))
#+end_src
#+begin_src scheme :exports both :results value
<<cont-frac-recursive>>
(/ 1 (cont-frac (lambda (i) 1.0) (lambda (i) 1.0) 14))
#+end_src
#+RESULTS:
: 1.6180257510729614
Abelson and Sussman tell us to estimate \(k\) needed to approximate the \(\varphi\) to a required
degree (0.0001). I didn't manage to derive the formula myself, however, I can
give a link to the book where this proof is given:
Khinchin, Continued Fractions (1935), chapter 2, section 7, gives an upper
bound on the speed of convergence as \(\frac{1}{k^2}\). Therefore we should
expect \(k \approx \sqrt{1000} \approx 33\). This holds for an arbitrary convergent
continued fraction. In our case, however, when \(N_k=D_k=1\), the constant in
the rate is also known as \(\sqrt{5}\), so the equation we need to solve is
in fact \(k^2 \sqrt{5} = 1000\), and in practice that is
\(\sqrt{\frac{1000}{2.23}} = 21\). How exactly we managed to do it in 14
steps, I don't know.
**** DONE b. iterative
CLOSED: [2019-09-04 Wed 11:35]
We just start computing from the end.
#+begin_src scheme :exports both :results value :noweb-ref cont-frac
(define (cont-frac n d k)
(define (next step accumulator)
(if (> step 0)
(next (- step 1) (/ (n step) (+ (d step) accumulator)))
accumulator))
(next k 0))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value
<<cont-frac>>
(/ 1 (cont-frac (lambda (i) 1.0) (lambda (i) 1.0) 14))
#+end_src
#+RESULTS:
: 1.6180371352785146
Remark: this exercise took me 7 hours.
*** DONE Exercise 1.38 euler constant
CLOSED: [2019-09-04 Wed 11:35]
The only difficulty with this exercise is to derive the formula for the
second lambda.
#+begin_src scheme :exports both :results value
<<cont-frac>>
(+ 2
(cont-frac
(lambda (i) 1.0)
(lambda (i) (if (= (remainder i 3) 2) (+ (* (/ i 3) 2) 2) 1))
14 ))
#+end_src
#+RESULTS:
: 2.794771662537
*** DONE Exercise 1.39 tan-cf
CLOSED: [2019-09-04 Wed 12:11]
:LOGBOOK:
:END:
#+begin_src scheme :exports both :results output
<<cont-frac>>
(define (tan-cf x k)
(cont-frac
(lambda (i)
(if (= i 1) x (- (* x x))))
(lambda (i)
(- (* 2 i) 1))
k))
(display (tan 0.1))
(newline)
(display(tan-cf 0.1 300))
#+end_src
#+RESULTS:
: 0.10033467208545055
: 0.10033467208545055
*** DONE Exercise 1.40 newtons-method
CLOSED: [2019-09-04 Wed 17:06]
:LOGBOOK:
CLOCK: [2019-09-04 Wed 17:21]--[2019-09-04 Wed 17:21] => 0:00
:END:
#+begin_src scheme :exports both :results value :noweb-ref deriv
(define (deriv g)
(lambda (x) (/ (- (g (+ x dx)) (g x)) dx)))
(define dx 0.00001)
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref newtons-method
(define (newton-transform g)
(lambda (x) (- x (/ (g x) ((deriv g) x)))))
(define (newtons-method g guess)
(fixed-point (newton-transform g) guess))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref square
(define (square x)
(* x x))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref cube
(define (cube x)
(* x x x))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref cubic
(define (cubic a b c)
(lambda (x) (+ (cube x) (* a (square x)) (* b x) c)))x
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref inc
(define (inc x) (+ x 1))
#+end_src
#+begin_src scheme :exports both :results output
<<fixed-point-silent>>
<<cubic>>
<<cube>>
<<square>>
<<deriv>>
<<newtons-method>>
(display (newtons-method (cubic 5 3 1) 1))
#+end_src
#+RESULTS:
: -4.365230013403046
Theoretically, a cubic may have up to 3 roots, but to find all of them we
would need to try over all possible ones.
*** DONE Exercise 1.41 double-double
CLOSED: [2019-09-04 Wed 17:21]
#+begin_src scheme :exports both :results value :noweb-ref double-function
(define (double fun)
(lambda (x) (fun (fun x))))
(define (inc x)
(+ x 1))
#+end_src
#+begin_src scheme :exports both :results value
<<double-function>>
(((double double) inc) 5)
#+end_src
#+RESULTS:
: 9
#+begin_src scheme :exports both :results value
<<double-function>>
(((double (double double)) inc) 5)
#+end_src
#+RESULTS:
: 21
\(21 = 5 + 16\)
Double really works as a power of a function. \( 2 \Rightarrow 2^2 \Rightarrow2^{2^2} =
\mbox{inc}^{16} 5 \)
*** DONE Exercise 1.42 compose
CLOSED: [2019-09-04 Wed 17:27]
#+begin_src scheme :exports both :results value :noweb-ref compose
(define (compose f g)
(lambda (x) (f (g x))))
#+end_src
#+begin_src scheme :exports both :results value
<<compose>>
<<square>>
<<inc>>
((compose square inc) 6)
#+end_src
#+RESULTS:
: 49
*** DONE Exercise 1.43 repeated
CLOSED: [2019-09-04 Wed 17:54]
#+begin_src scheme :exports both :results value :noweb-ref repeated
(define (repeated fun n)
(define (repeat-it n fun combinator)
(if (= n 1)
combinator
(repeat-it (- n 1) fun (lambda (x) (fun (combinator x))))))
(repeat-it n fun fun))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value
<<repeated>>
<<square>>
((repeated square 2) 5)
#+end_src
#+RESULTS:
: 625
Hm. Managed to do it without the ~compose~ form.
*** DONE Exercise 1.44 smoothing
CLOSED: [2019-09-04 Wed 20:17]
#+begin_src scheme :exports both :results value :noweb-ref smooth
(define dx 0.1)
(define (smooth f)
(lambda (x) (/ (+ (f (- x dx))
(f x)
(f (+ x dx)))
3)))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref n-smoothed
(define (n-smoothed fun n)
((repeated smooth n) fun))
#+end_src
#+begin_src scheme :exports both :results output
<<smooth>>
<<n-smoothed>>
<<repeated>>
<<cube>>
(define (ex144-answer x)
((n-smoothed cube 3) x))
(display (ex144-answer 10))
#+end_src
#+RESULTS:
: 1000.6
Looks like what we wanted.
*** DONE Exercise 1.45 nth-root
CLOSED: [2019-09-04 Wed 21:37]
#+begin_src scheme :exports both :results value :noweb-ref average
(define (average x y)
(/ (+ x y) 2))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref average-damp
(define (average-damp f)
(lambda (x) (average x (f x))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref n-average-damp
(define (n-average-damped f n)
((repeated average-damp n) f))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref better-fixed-point
(define tolerance 0.0001)
(define (fixed-point f first-guess)
(define (close-enough? v1 v2)
(< (abs (- v1 v2))
tolerance))
(define (try guess)
(let ((next (f guess)))
(if (close-enough? guess next)
next
(try next))))
(try first-guess))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value :noweb-ref root-n-x
(define (root n x initial-guess)
(fixed-point
(n-average-damped
(lambda (y) (/ x (pow y (- n 1))))
n)
initial-guess))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref pow-recursive
(define (pow x n)
(if (= n 1)
x
(* x (pow x (- n 1)))))
#+end_src
#+begin_src scheme :exports both :results output
<<average>>
<<average-damp>>
<<repeated>>
<<better-fixed-point>>
<<n-average-damp>>
<<pow-recursive>>
<<root-n-x>>
(display (root 4 4 3.0))
#+end_src
#+RESULTS:
: 1.4144444873765194
The true answer would require to actually estimate the dampening factor, but
we know that *n* is enough, and I am lazy.
*** DONE Exercise 1.46 iterative-improve
CLOSED: [2019-09-04 Wed 22:25]
#+begin_src scheme :exports both :results value :noweb-ref iterative-improve
(define (iterative-improve good-enough? improve)
(define (improver guess)
(if (good-enough? guess)
guess
(improver (improve guess))))
improver)
#+end_src
**** DONE a. sqrt
CLOSED: [2019-09-04 Wed 22:24]
#+begin_src scheme :exports both :results value
<<square>>
<<iterative-improve>>
(define (ex1.46sqrt x)
(let (
(square-improver
(iterative-improve
(lambda (y) (< (abs (- (square y) x )) 0.01))
(lambda (y) (/ (+ y (/ x y)) 2)))
)
)
(square-improver 1)))
(ex1.46sqrt 2.0)
#+end_src
#+RESULTS:
: 1.4166666666666665
**** DONE b. fixed-point
CLOSED: [2019-09-04 Wed 22:25]
#+begin_src scheme :exports both :results value
<<square>>
<<iterative-improve>>
(define (fixpoint f)
(let (
(fixpoint-improver
(iterative-improve
(lambda (y) (< (abs (- (f y) y )) 0.01))
(lambda (y) (/ (+ y (f y)) 2)))
)
)
(fixpoint-improver 1.0)))
(fixpoint (lambda (x) (+ 1 (/ 1 x))))
#+end_src
#+RESULTS:
: 1.6147785476652068
I have made it. At [2019-09-04 Wed 22:25] I still haven't implemented all the
pictures, but I already can say that I have solved _all_ problems of the
first chapter of SICP. Some macros are wrong, I need to revise them, but that
will be done on the second pass. (Yes, there will be a second [or, rather, third] pass!)
** TODO Chapter 2: Building abstractions with data [106/110]
*** DONE Exercise 2.1 make-rat
CLOSED: [2019-09-06 Fri 13:00]
In this exercise I will also define the functions presented by Abelson
and Sussman for general reference.
#+begin_src scheme :exports both :results value :noweb-ref make-rat
(define (make-rat numerator denominator)
(let* ((my-gcd (gcd numerator denominator))
(numerator (/ numerator my-gcd))
(denominator (/ denominator my-gcd))
(sign (/ (abs denominator) denominator)))
(cons (* numerator sign) (* denominator sign))))
(define (numer x)
(car x))
(define (denom x)
(cdr x))
#+end_src
#+RESULTS:
: unfinished
#+begin_src scheme :exports both :results value 2.2.1-basic-rat
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (equal-rat? x y)
(= (* (numer x) (denom y))
(* (numer y) (denom x))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref print-rat
(define (print-rat x)
(newline)
(display (numer x))
(display "/")
(display (denom x)))
#+end_src
#+begin_src scheme :exports both :results output
<<print-rat>>
<<2.2.1-basic-rat>>
<<make-rat>>
(define one-half (make-rat -65 -5))
(print-rat one-half)
#+end_src
#+RESULTS:
:
: 13/1
*** TODO Figure 2.1
This figure contains a data-abstraction diagram. I don't know how to
make them yet.
*** DONE Exercise 2.2 make-segment
CLOSED: [2019-09-06 Fri 13:34]
#+begin_src scheme :exports both :results value :noweb-ref make-segment
(define (make-segment x1 y1 x2 y2)
(cons (make-point x1 y1) (make-point x2 y2)))
(define (start-segment segment)
(car segment))
(define (end-segment segment)
(cdr segment))
(define (make-point x y)
(cons x y))
(define (x-point point)
(car point))
(define (y-point point)
(cdr point))
(define (midpoint-segment segment)
(make-point (/ (+ (x-point (start-segment segment))
(x-point (end-segment segment))) 2)
(/ (+ (y-point (start-segment segment))
(y-point (end-segment segment))) 2)))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref print-point
(define (print-point p)
(newline)
(display "(")
(display (x-point p))
(display ",")
(display (y-point p))
(display ")"))
#+end_src
#+begin_src scheme :exports both :results output
<<print-point>>
<<make-segment>>
(print-point (midpoint-segment (make-segment 1 0 0 1)))
#+end_src
#+RESULTS:
:
: (1/2,1/2)
The task looks pretty straightforward. Just make a cons of points.
*** DONE Exercise 2.3 make-rectangle
CLOSED: [2019-09-08 Sun 17:58]
I will choose the following two representations:
- List of points from top left to the right.
- Two lists of coordinates, x and y.
I will not be using segments from Exercise 2.2, because then I would
have to care about the consistency of the first and the last point in
the four segments.
#+begin_src scheme :exports both :results output :noweb-ref rectangle
(define (area rectangle)
(* (get-height rectangle) (get-width rectangle)))
(define (perimeter rectangle)
(* 2 (+ (get-height rectangle) (get-width rectangle))))
(define (get-height rectangle)
(dist (nth-point 1 rectangle) (nth-point 2 rectangle)))
(define (get-width rectangle)
(dist (nth-point 2 rectangle) (nth-point 3 rectangle)))
(define (dist point1 point2)
(+ (square (- (x-point point1) (x-point point2))) (square (- (y-point point1) (y-point point2)))))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref rectangle-point-list
(define (make-rectangle x1 y1 x2 y2 x3 y3 x4 y4)
(list (make-point x1 y1)
(make-point x2 y2)
(make-point x3 y3)
(make-point x4 y4)))
(define (nth-point n rectangle)
(if (= n 1)
(car rectangle)
(nth-point (- n 1) (cdr rectangle))))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref rectangle-two-lists
(define (make-rectangle x1 y1 x2 y2 x3 y3 x4 y4)
(cons (list x1 x2 x3 x4) (list y1 y2 y3 y4)))
(define (nth-point n rectangle)
(if (= n 1)
(make-point (caar rectangle) (cadr rectangle))
(nth-point (- n 1) (cons (cdar rectangle) (cddr rectangle)))))
#+end_src
#+begin_src scheme :exports both :results output
<<rectangle>>
<<rectangle-point-list>>
<<make-segment>>
(let ((test1 (make-rectangle 0 0 0 1 1 1 1 0)))
(display "Area=")
(display (area test1))
(newline)
(display "Perimeter=")
(display (perimeter test1))
(newline))
#+end_src
#+RESULTS:
: Area=1
: Perimeter=4
#+begin_src scheme :exports both :results output
<<rectangle>>
<<rectangle-two-lists>>
<<make-segment>>
(let ((test1 (make-rectangle 0 0 0 1 1 1 1 0)))
(display "Area=")
(display (area test1))
(newline)
(display "Perimeter=")
(display (perimeter test1))
(newline))
#+end_src
#+RESULTS:
: Area=1
: Perimeter=4
This is not very efficient, but two implementations were requested --
and they were delivered.
*** DONE Exercise 2.4 cons-lambda
CLOSED: [2019-09-08 Sun 18:08]
#+begin_src scheme :exports both :results output
(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)))
(display (car (cons 'a 'b)))
(newline)
(display (cdr (cons 'a 'b)))
(newline)
#+end_src
#+RESULTS:
: a
: b
*** DONE Exercise 2.5 cons-pow
CLOSED: [2019-09-08 Sun 19:07]
0:00:00 -- 0:56:02
#+begin_src scheme :exports both :results value :noweb-ref ex2.5cons
(define (cons a b)
(* (expt 2 a) (expt 3 b)))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value :noweb-ref ex2.5car
(define (car number)
(log (gcd (expt 2.0 (floor (log number 2))) number) 2))
(define (cdr number)
(log (gcd (expt 3.0 (floor (log number 2))) number) 3))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value
<<ex2.5car>>
<<ex2.5cons>>
(list (car (cons 14 4)) (cdr (cons 14 4)))
#+end_src
#+RESULTS:
| 14.0 | 4.0 |
*** DONE Exercise 2.6 Church Numerals
CLOSED: [2019-09-08 Sun 19:41]
0:00:00 -- 0:23:58
In the worst case this exercise can be copied literally right from the
Wikipedia article: https://en.wikipedia.org/wiki/Church_encoding
#+begin_src scheme :exports both :results value :noweb-ref church-zero
(define identity (lambda (x) x))
(define zero (lambda (f) identity))
(define (add-1 n)
(lambda (f) (lambda (x) (f ((n f) x)))))
#+end_src
#+begin_src scheme :exports both :results output
<<church-zero>>
(define one (lambda (f) (lambda (x) (f x))))
(define two (lambda (f) (lambda (x) (f (f x)))))
(define (plus a b)
(lambda (f) (lambda (x) ((a f) ((b f) x)))))
#+end_src
#+RESULTS:
*** DONE Exercise 2.7 make-interval
CLOSED: [2019-09-08 Sun 20:09]
0:00:00 -- 0:20:09
#+begin_src scheme :exports both :results value :noweb-ref make-interval
(define (make-interval a b)
(cons a b))
(define (upper-bound interval)
(max (car interval) (cdr interval)))
(define (lower-bound interval)
(min (car interval) (cdr interval)))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref interval-common
(define (add-interval x y)
(make-interval (+ (lower-bound x) (lower-bound y))
(+ (upper-bound x) (upper-bound y))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref mul-interval-simple
(define (mul-interval x y)
(let ((p1 (* (lower-bound x) (lower-bound y)))
(p2 (* (lower-bound x) (upper-bound y)))
(p3 (* (upper-bound x) (lower-bound y)))
(p4 (* (upper-bound x) (upper-bound y))))
(make-interval (min p1 p2 p3 p4)
(max p1 p2 p3 p4))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref div-interval-lame
(define (div-interval x y)
(mul-interval
x
(make-interval (/ 1.0 (upper-bound y))
(/ 1.0 (lower-bound y)))))
#+end_src
#+begin_src scheme :exports both :results output
<<make-interval>>
<<interval-common>>
<<div-interval-lame>>
<<mul-interval-simple>>
(show #t " " (add-interval (make-interval 5 5.6) (make-interval 6 6.1)) "\n")
(show #t " " (mul-interval (make-interval -0.1 0.1) (make-interval 100 110)) "\n")
(show #t " " (div-interval (make-interval -0.1 0.1) (make-interval 100 110)))
#+end_src
#+RESULTS:
: (11.0 . 11.7)
: (-11.0 . 11.0)
: (-0.001 . 0.001)
*** DONE Exercise 2.8 sub-interval
CLOSED: [2019-09-08 Sun 23:07]
#+begin_src scheme :exports both :results value :noweb-ref sub-interval
(define (sub-interval a b)
(make-interval (- (upper-bound a) (lower-bound b))
(- (lower-bound a) (upper-bound b))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<make-interval>>
<<sub-interval>>
(show #t " " (sub-interval (make-interval 100 -100) (make-interval -1 101)))
#+end_src
#+RESULTS:
: (101 . -201)
*** DONE Exercise 2.9 interval-width
CLOSED: [2019-09-08 Sun 23:15]
0:06:00
#+begin_src scheme :exports both :results value
(define (width interval)
(abs (- (upper-bound interval) (lower-bound interval))))
#+end_src
\( a + \Delta a + b + \Delta b = (a+b) + (\Delta a + \Delta b)\)
\((a+\Delta a)\cdot (b+\Delta b) = (a\cdot b) + (a\Delta b + b\Delta a + \Delta a \Delta b)\)
The formulae above should relatively convincingly explain why the
width is not the function of the initial widths only in the case of
multiplication.
*** DONE Exercise 2.10 div-interval-better
CLOSED: [2019-09-08 Sun 23:30]
0:14:50
The initial Alyssa's construction is:
#+begin_src scheme :exports both :results value :noweb-ref div-interval-better
(define (div-interval x y)
(when (and (< (lower-bound y) 0) (> (upper-bound y) 0))
(error "Division by zero." (list x y)))
(mul-interval
x
(make-interval (/ 1.0 (upper-bound y))
(/ 1.0 (lower-bound y)))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<div-interval-better>>
<<make-interval>>
(display (div-interval (make-interval 1 2) (make-interval -1 1)))
#+end_src
#+RESULTS:
: '(Exception #19 user "Division by zero." (((1 . 2) (-1 . 1))) #f #f)
*** DONE Exercise 2.11 mul-interval-nine-cases
CLOSED: [2019-09-09 Mon 00:45]
1:06:58
| number | lower x | upper x | lower y | upper y |
|--------+---------+---------+---------+---------|
| 2 | + | + | + | + |
| 2 | + | + | - | + |
| 2 | + | + | - | - |
| 2 | - | + | + | + |
| 3 | - | + | - | + |
| 2 | - | + | - | - |
| 2 | - | - | + | + |
| 2 | - | - | - | + |
| 2 | - | - | - | - |
#+begin_src scheme :exports both :results value :noweb-ref mul-interval
(define (mul-interval x y)
(let ((x1 (lower-bound x))
(x2 (upper-bound x))
(y1 (lower-bound y))
(y2 (upper-bound y)))
(cond ((and (> x1 0) (> x2 0) (> y1 0) (> y2 0)) (make-interval (* x1 y1) (* x2 y2)))
((and (> x1 0) (> x2 0) (< y1 0) (> y2 0)) (make-interval (* x2 y1) (* x2 y2)))
((and (> x1 0) (> x2 0) (< y1 0) (< y2 0)) (make-interval (* x2 y1) (* x2 y1)))
((and (< x1 0) (> x2 0) (> y1 0) (> y2 0)) (make-interval (* x1 y2) (* x2 y2)))
((and (< x1 0) (> x2 0) (< y1 0) (> y2 0))
(let ((p1 (* (lower-bound x) (lower-bound y)))
(p2 (* (lower-bound x) (upper-bound y)))
(p3 (* (upper-bound x) (lower-bound y)))
(p4 (* (upper-bound x) (upper-bound y))))
(make-interval (min p1 p2 p3 p4)
(max p1 p2 p3 p4))))
((and (< x1 0) (> x2 0) (< y1 0) (< y2 0)) (make-interval (* x2 y2) (* x2 y1)))
((and (< x1 0) (< x2 0) (> y1 0) (> y2 0)) (make-interval (* x1 y2) (* x2 y1)))
((and (< x1 0) (< x2 0) (< y1 0) (> y2 0)) (make-interval (* x2 y2) (* x1 y1)))
((and (< x1 0) (< x2 0) (< y1 0) (< y2 0)) (make-interval (* x2 y2) (* x1 y1))))))
#+end_src
I don't even want to test it.
#+begin_src scheme :exports both :results output
<<mul-interval>>
<<make-interval>>
(show #t " " (mul-interval (make-interval -2 2) (make-interval -5 6)))
#+end_src
#+RESULTS:
: (-12 . 12)
Marvelous.
*** DONE Exercise 2.12 make-center-percent
CLOSED: [2019-09-09 Mon 10:11]
#+begin_src scheme :exports both :results value :noweb-ref make-center-width
(define (make-center-width c w)
(make-interval (- c w) (+ c w)))
(define (center i)
(/ (+ (lower-bound i) (upper-bound i)) 2))
(define (width i)
(/ (- (upper-bound i) (lower-bound i)) 2))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref make-center-precision
(define (make-center-percent center percent)
(let ((delta (* center (/ percent 100))))
(make-interval (+ center delta) (- center delta))))
(define (relative-precision interval)
(let* ((center (/ (+ (lower-bound interval) (upper-bound interval))
2))
(percent (/ (abs (- (lower-bound interval) (upper-bound interval))) 2)))
(/ percent center)))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<make-center-width>>
<<make-center-precision>>
<<make-interval>>
(let ((test-interval (make-center-percent 100 2)))
(show #t " " test-interval "\n")
(show #t " " (center test-interval) "\n")
(show #t " " (relative-precision test-interval)) "\n")
#+end_src
#+RESULTS:
: (102 . 98)
: 100
: 1/50
*** DONE Exercise 2.13 formula for tolerance
CLOSED: [2019-09-09 Mon 10:16]
\((a+\Delta a)\cdot (b+\Delta b) = (a\cdot b) + (a\Delta b + b\Delta a + \Delta a \Delta b)\)
\(\frac{(a+\Delta a)\cdot (b+\Delta b)}{a\cdot b} = \frac{(a\cdot b)}{a\cdot b} + \frac{(a\Delta b +
b\Delta a + \Delta a \Delta b)}{a \cdot b} \approx 1 + \frac{\Delta a}{a} + \frac{\Delta b}{b}\)
*** DONE Exercise 2.14 parallel-resistors
CLOSED: [2019-09-09 Mon 11:24]
0:37:00 + 0:31:07 = 1:06:07
#+begin_src scheme :exports both :results output
<<make-interval>>
<<div-interval-better>>
<<mul-interval>>
<<interval-common>>
(define (par1 r1 r2)
(div-interval (mul-interval r1 r2)
(add-interval r1 r2)))
(define (par2 r1 r2)
(let ((one (make-interval 1 1)))
(div-interval
one (add-interval (div-interval one r1)
(div-interval one r2)))))
(show #t " " (par1 (make-interval 4.9 5.1) (make-interval 6.9 7.1)) "\n")
(show #t " " (par2 (make-interval 4.9 5.1) (make-interval 6.9 7.1)) "\n")
#+end_src
#+RESULTS:
: (2.7713114754098367 . 3.0686440677966096)
: (2.8652542372881356 . 2.968032786885246)
It is worth noticing that ~par2~ uses more operations than
~par1~. Even if the title problem in the exercise wasn't present, we
would still get a less precise result.
#+begin_src scheme :exports both :results output
<<make-interval>>
<<mul-interval>>
<<div-interval-better>>
(let ((one (make-interval 1.0 1.0))
(i2 (make-interval 4.9 5.1))
(i3 (make-interval 6.9 7.1)))
(show #t " " (div-interval one one) "\n")
(show #t " " (div-interval one i2) "\n")
(show #t " " (div-interval i2 i2) "\n")
(show #t " " (div-interval i2 i3) "\n")
(show #t " " (mul-interval i2 (div-interval one i2)) "\n"))
#+end_src
#+RESULTS:
: (1.0 . 1.0)
: (0.19607843137254904 . 0.2040816326530612)
: (0.9607843137254903 . 1.040816326530612)
: (0.6901408450704226 . 0.7391304347826086)
: (0.9607843137254903 . 1.040816326530612)
The idea here is, in some sense, the non-independence of the random
variables *i2* and *i2*. Regardless of the precision of *i2*, we
_know_ that \(\frac{i_2}{i_2} = 1\).
The center-percent form I implemented is slightly different from the
one Abelson expected, I guess, but still,
\(\frac{1}{1} \approx 1 \pm 2\Delta\). This is too much.
*** DONE Exercise 2.15 better-intervals
CLOSED: [2019-09-09 Mon 11:34]
I already answered this question in the Exercise 2.14. The problem is
of the potential independence (which may or may not be the case) of
*a* and *b*, but complete dependence of *a* on *a*, which is \(1\)
regardless of whether *a* is even well-defined.
*** DONE Exercise 2.16 interval-arithmetic
CLOSED: [2019-09-09 Mon 11:37]
To solve this problem in the general case, on would have to build a
probability distribution of the function on the variables, and use
something of a probabilistic reduction on every step. I am not aware
of such systems if they even exist. It would be indispensable for
quantum modelling though.
Hypothetically, if such systems existed, they would do something like
build a distribution on every step of the computation and track every
quantity occurrence in every distribution.
*** TODO Figure 2.2 Box-and-pointer representation of ~(cons 1 2)~. :graphviz:plantuml:tikz:
https://gitlab.com/graphviz/graphviz/issues/1588
https://gitlab.com/graphviz/graphviz/issues/1589
10:00:00
[2019-09-10 Tue 10:24] I managed to make pgf work with org-mode, but
didn't manage to make a picture yet. So far this problem happened to
generalize to the case of drawing arbitrary vector graphics. Graphviz
turned out to be less fit for this problem.
#+begin_src plantuml :exports both :file figure-2-2.png
@startdot
digraph sicp2_2 {
node [shape=none];
source [label=""];
node [shape=plaintext, style="rounded"];
struct0 [label=<<table BORDER="0" CELLBORDER="1" CELLSPACING="0">
<tr>
<td width="29" height="35" sides="ltrb" port="f1"></td>
<td width="29" height="35" sides="lrtb" port="f2"></td>
</tr>
</table>>, style="rounded,filled", fillcolor="gray"];
rankdir=LR;
node [shape=record, style="rounded"];
struct2 [label="<f2> 2"];
struct1 [label="<f1> 1"];
edge [arrowhead=normal,arrowtail=dot];
struct0:f2:c -> struct2:f0 [tailclip=false];
struct0:f1:c -> struct1:f0 [tailclip=false];
source -> struct0;
}
@enddot
#+end_src
#+RESULTS:
[[file:figure-2-2.png]]
#+name: tikztest
#+header: :imagemagick yes :iminoptions -density 600 :imoutoptions -geometry 200
#+header: :fit yes :headers '("\\usepackage{tikz}")
#+header: :buffer on
#+begin_src latex :results raw file :exports code :file test.png
\usetikzlibrary{trees}
\begin{tikzpicture}[color=white]
\node [circle, draw, fill=red!70] at (0,0) {1}
child {
node [circle, draw, fill=blue!70] {2}
child {
node [circle, draw, fill=green!70] {3} }
child {
node [circle, draw, fill=yellow!70] {4} }
};
\end{tikzpicture}
#+end_src
#+RESULTS: tikztest
[[file:test.png]]
#+begin_src plantuml :exports both :file ditaa.png
@startditaa
+---+---+ +---+---+ +---+---+ +---+
---->| * | *-+---->| * | * | ---->| * | *------>| 4 |
+-|-+---+ +-|-+-|-+ +-|-+---+ +---+
| | | |
V V V V
+---+---+ +---+ +---+ +---+---+ +---+---+
| * | * | | 3 | | 4 | | * | *-+---->| * | * |
+-|-+-|-+ +---+ +---+ +-|-+---+ +-|-+-|-+
| | | | |
V V V V V
+---+ +---+ +---+ +---+ +---+
| 1 | | 2 | | 1 | | 2 | | 3 |
+---+ +---+ +---+ +---+ +---+
@endditaa
#+end_src
#+RESULTS:
[[file:ditaa.png]]
*** DONE Exercise 2.17 last-pair
CLOSED: [2019-09-10 Tue 10:48]
0:20:51
#+begin_src scheme :exports both :results value :noweb-ref last-pair
(define (last-pair lst)
(list-tail lst (- (length lst) 1)))
#+end_src
#+begin_src scheme :exports both :results output
<<last-pair>>
(let ((tmp (last-pair '(1 1))))
(show #t " " (car tmp) " " (cdr tmp)))
#+end_src
#+RESULTS:
: 1 ()
*** DONE Exercise 2.18 reverse
CLOSED: [2019-09-10 Tue 10:57]
0:03:56
#+begin_src scheme :exports both :results value :noweb-ref reverse-list
(define (reverse lst)
(define (lst-iter x y)
(if (null? y)
x
(lst-iter (cons (car y) x) (cdr y))))
(lst-iter '() lst))
#+end_src
#+begin_src scheme :exports both :results output
<<reverse-list>>
(show #t " " (reverse '(1 2 3)))
#+end_src
#+RESULTS:
: (3 2 1)
*** DONE Exercise 2.19 coin-values :unsure:
CLOSED: [2019-09-10 Tue 11:27]
#+begin_src scheme :exports both :results value :noweb-ref coin-values
(define us-coins (list 50 25 10 5 1))
(define uk-coins (list 100 50 20 10 5 2 1 0.5))
(define uk-coins-damaged (list 0.50 100 50 20 10 5 2 1))
(define (cc amount coin-values)
(cond ((= amount 0) 1)
((or (< amount 0) (no-more? coin-values)) 0)
(else
(+ (cc amount
(except-first-denomination
coin-values))
(cc (- amount
(first-denomination
coin-values))
coin-values)))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref first-denomination
(define (first-denomination coin-values)
(car coin-values))
(define (except-first-denomination coin-values)
(cdr coin-values))
(define (no-more? coin-values)
(null? coin-values))
#+end_src
*Warning:* the next code is a bit slow (~1 minute).
#+begin_src scheme :exports both :results output
<<first-denomination>>
<<coin-values>>
(show #t " " (cc 137 us-coins) "\n")
(show #t " " (cc 137 uk-coins) "\n")
#+end_src
#+RESULTS:
: 704
: 443166
#+begin_src scheme :exports both :results output
<<first-denomination>>
<<coin-values>>
(show #t " " (cc 137 uk-coins-damaged) "\n")
#+end_src
#+RESULTS:
: 443166
I don't see why the result would depend on the order of the coins. We
don't seem to be using the order anywhere.
*** DONE Exercise 2.20 dotted-tail notation
CLOSED: [2019-09-10 Tue 18:55]
1:45:10
#+begin_src scheme :exports both :results value :noweb-ref same-parity
(define (same-parity . lst)
(define (iter-parity lst bit accumulator)
(cond ((null? lst)
accumulator)
((= (remainder (car lst) 2) bit)
(iter-parity (cdr lst) bit (cons (car lst) accumulator)))
(else
(iter-parity (cdr lst) bit accumulator))))
(reverse (iter-parity lst (remainder (car lst) 2) '())))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<same-parity>>
(show #t " " (same-parity 2 3 4) "\n")
(show #t " " (same-parity 1 2 3 4) "\n")
#+end_src
#+RESULTS:
: (2 4)
: (1 3)
*** DONE Exercise 2.21 map-square-list
CLOSED: [2019-09-10 Tue 19:14]
0:13:23
#+begin_src scheme :exports both :results output
(define nil #f)
(define (square-list items)
(if (null? items)
'()
(cons (* (car items) (car items)) (square-list (cdr items)))))
(show #t " " (square-list '(1 2 3 4 5)))
#+end_src
#+RESULTS:
: (1 4 9 16 25)
#+begin_src scheme :exports both :results output
(define (square-list items)
(map (lambda (x) (* x x)) items))
(show #t " " (square-list '(1 2 3 4 5)))
#+end_src
#+RESULTS:
: (1 4 9 16 25)
One of the peculiar tricks in this equation is that unlike in older
lisps, *#f* is not entirely the same as ~'()~, although they both
evaluate to false.
*** DONE Exercise 2.22 wrong list order
CLOSED: [2019-09-10 Tue 19:24]
Referring to Exercise 2.20 is highly recommended.
The problem with the first solution is that, indeed, he's ~cons~'ing
the pair in such a way that it would produce the reversed list.
The problem with the second solution is that it IS creating a list-ish
construction that is contains all the elements in the right order, but
stores them in ~cdr~'s, not in ~car~'s.
In lisp without mutations (without ~set-cdr!~ and ~set-car!~), it is
only possible to prepend elements to lists, not really append.
*** DONE Exercise 2.23 for-each
CLOSED: [2019-09-10 Tue 19:33]
0:04:56
#+begin_src scheme :exports both :results output
(define (for-each fun items)
(unless (null? items)
(fun (car items))
(for-each fun (cdr items))))
(for-each (lambda (x)
(newline)
(display x))
(list 57 321 88))
#+end_src
#+RESULTS:
:
: 57
: 321
: 88
*** DONE Exercise 2.24 list-plot-result :graphviz:
CLOSED: [2019-09-10 Tue 22:13]
0:48:39
The result of the interpreter:
#+begin_src scheme :exports both :results output
(show #t " " (list 1 (list 2 (list 3 4))))
#+end_src
#+RESULTS:
: (1 (2 (3 4)))
The box-and-pointer structure:
#+begin_src plantuml :exports both :file exercise-2-24.png
@startdot
digraph sicp2_24 {
node [shape=plaintext, style="rounded"];
struct1 [label=<<table BORDER="0" CELLBORDER="1" CELLSPACING="0">
<tr>
<td width="29" height="35" sides="ltrb" port="f0">1</td>
<td width="29" height="35" sides="lrtb" port="f1"></td>
</tr>
</table>>, style="rounded,filled", fillcolor="gray"];
rankdir=LR;
edge [arrowhead=normal,arrowtail=dot,tailclip=false, dir=both];
struct1:f1:c -> struct2 [tailclip=false];
node [shape=plaintext, style="rounded"];
struct2 [label=<<table BORDER="0" CELLBORDER="1" CELLSPACING="0">
<tr>
<td width="29" height="35" sides="ltrb" port="f0"></td>
<td width="29" height="35" sides="lrtb" port="f1">'()</td>
</tr>
</table>>, style="rounded,filled", fillcolor="gray"];
struct2:f0:c -> struct3 [tailclip=false];
node [shape=plaintext, style="rounded"];
struct3 [label=<<table BORDER="0" CELLBORDER="1" CELLSPACING="0">
<tr>
<td width="29" height="35" sides="ltrb" port="f0"></td>
<td width="29" height="35" sides="lrtb" port="f1"></td>
</tr>
</table>>, style="rounded,filled", fillcolor="gray"];
node [shape=plaintext, style="rounded"];
struct4 [label=<<table BORDER="0" CELLBORDER="1" CELLSPACING="0">
<tr>
<td width="29" height="35" sides="ltrb" port="f0"></td>
<td width="29" height="35" sides="lrtb" port="f1">'()</td>
</tr>
</table>>, style="rounded,filled", fillcolor="gray"];
struct3_3 [label="2",shape=record];
struct3:f0:c -> struct3_3 [tailclip=false];
struct3:f1:c -> struct4 [tailclip=false];
struct5 [label=<<table BORDER="0" CELLBORDER="1" CELLSPACING="0">
<tr>
<td width="29" height="35" sides="ltrb" port="f0">3</td>
<td width="29" height="35" sides="lrtb" port="f1"></td>
</tr>
</table>>, style="rounded,filled", fillcolor="gray"];
struct4:f0:c -> struct5;
struct6 [label=<<table BORDER="0" CELLBORDER="1" CELLSPACING="0">
<tr>
<td width="29" height="35" sides="ltrb" port="f0">4</td>
<td width="29" height="35" sides="lrtb" port="f1">'()</td>
</tr>
</table>>, style="rounded,filled", fillcolor="gray"];
struct5:f1:c -> struct6;
}
@enddot
#+end_src
#+RESULTS:
[[file:exercise-2-24.png]]
Tree interpretation:
#+begin_src plantuml :exports both :file figure-1-1-dot.png
@startdot
graph g {
node [shape=plaintext];
A1 [label="(1 (2 (3 4)))"];
B1 [label="1"];
B2 [label="(2 (3 4))"];
C1 [label="2"];
C2 [label="(3 4)"];
D1 [label="3"];
D2 [label="4"];
// edges
A1 -- B1;
A1 -- B2;
B2 -- C1;
B2 -- C2;
C2 -- D1;
C2 -- D2;
{ rank=same; A1 }
{ rank=same; B1 B2 }
{ rank=same; C1 C2 }
{ rank=same; D1 D2 }
}
@enddot
#+end_src
#+RESULTS:
[[file:figure-1-1-dot.png]]
*** DONE Exercise 2.25 caddr
CLOSED: [2019-09-10 Tue 23:07]
#+begin_src scheme :exports both :results value
(car (cdr (car (cdr (cdr '(1 3 (5 7) 9))))))
#+end_src
#+RESULTS:
: 7
#+begin_src scheme :exports both :results value
(caar '((7)))
#+end_src
#+RESULTS:
: 7
#+begin_src scheme :exports both :results output
(show #t " " (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr '(1 (2 (3 (4 (5 (6 7)))))))))))))))))))
#+end_src
#+RESULTS:
: 7
The task was funny.
*** DONE Exercise 2.26 append cons list
CLOSED: [2019-09-10 Tue 23:23]
#+begin_src scheme :exports both :results output
(define x (list 1 2 3))
(define y (list 4 5 6))
(show #t " " (append x y) "\n")
(show #t " " (cons x y) "\n")
(show #t " " (list x y) "\n")
#+end_src
#+RESULTS:
: (1 2 3 4 5 6)
: ((1 2 3) 4 5 6)
: ((1 2 3) (4 5 6))
*** DONE Exercise 2.27 deep-reverse
CLOSED: [2019-09-11 Wed 09:47]
0:14:46
#+begin_src scheme :exports both :results output
(define (deep-reverse lst)
(define (iter-reverse lst1 accumulator)
(if (null? lst1)
accumulator
(if (pair? (car lst1))
(iter-reverse (cdr lst1) (cons (deep-reverse (car lst1)) accumulator))
(iter-reverse (cdr lst1) (cons (car lst1) accumulator)))))
(iter-reverse lst '()))
(define x (list (list 1 2) (list 3 4)))
(show #t " " (reverse x) "\n")
(show #t " " (deep-reverse x))
#+end_src
#+RESULTS:
: ((3 4) (1 2))
: ((4 3) (2 1))
*** DONE Exercise 2.28 fringe
CLOSED: [2019-09-11 Wed 10:24]
0:37:00
#+begin_src scheme :exports both :results output
(define (fringe tree)
(define (fringe-iter tree accumulator)
(cond ((null? tree) '())
((not (pair? tree)) (list tree))
(else
(append accumulator
(fringe-iter (car tree) '())
(fringe-iter (cdr tree) '())))))
(fringe-iter tree '()))
(define x (list (list 1 2) (list 3 4)))
(show #t " " (fringe x) "\n")
(show #t " " (fringe (list x x)) "\n")
#+end_src
#+RESULTS:
: (1 2 3 4)
: (1 2 3 4 1 2 3 4)
*** DONE Exercise 2.29 mobile
CLOSED: [2019-09-11 Wed 11:47]
1:23:0
#+begin_src scheme :exports both :results value :noweb-ref mobile
(define (make-mobile left right)
(list left right))
(define (make-branch length structure)
(list length structure))
(define (left-branch mobile)
(car mobile))
(define (right-branch mobile)
(cadr mobile))
(define (branch-length branch)
(car branch))
(define (branch-structure branch)
(cadr branch))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref mobile-total-weight
(define (total-weight mobile)
(if (pair? mobile)
(+ (if (pair? (branch-structure (left-branch mobile)))
(total-weight (branch-structure (left-branch mobile)))
(branch-structure (left-branch mobile)))
(if (pair? (branch-structure (right-branch mobile)))
(total-weight (branch-structure (right-branch mobile)))
(branch-structure (right-branch mobile))))
mobile))
#+end_src
#+begin_src scheme :exports both :results value
<<mobile>>
<<mobile-total-weight>>
(total-weight
(make-mobile
(make-branch
5
(make-mobile
(make-branch 1 1)
(make-branch 2 2)))
(make-branch 7 2)))
#+end_src
#+RESULTS:
: 5
#+begin_src scheme :exports both :results value :noweb-ref mobile-balanced
(define (balanced? mobile)
(and
(=
(*
(branch-length (left-branch mobile))
(total-weight (branch-structure (left-branch mobile))))
(*
(branch-length (right-branch mobile))
(total-weight (branch-structure (right-branch mobile))))
)
(if (pair? (branch-structure (left-branch mobile)))
(balanced? (branch-structure (left-branch mobile)))
#t)
(if (pair? (branch-structure (right-branch mobile)))
(balanced? (branch-structure (right-branch mobile)))
#t)))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<mobile-balanced>>
<<mobile-total-weight>>
<<mobile>>
(show #t " " (balanced?
(make-mobile
(make-branch
5
(make-mobile
(make-branch 1 1)
(make-branch 2 2)))
(make-branch 7 2))) "\n")
(show #t " " (balanced? (make-mobile (make-branch 5 5) (make-branch 5 5))) "\n")
#+end_src
#+RESULTS:
: #f
: #t
If we replace lists with ~cons~, the only thing that needs to be
changed is that ~cadr~ should be replaced with ~car~.
*** DONE Exercise 2.30 square-tree
CLOSED: [2019-09-11 Wed 14:11]
1. A no-high-level version
#+begin_src scheme :exports both :results value :noweb-ref square-tree
(define (square-tree tree)
(cond ((null? tree) '())
((not (pair? tree)) (square tree))
(else (cons (square-tree (car tree))
(square-tree (cdr tree))))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<square-tree>>
(show #t " " (square-tree
(list 1
(list 2 (list 3 4) 5)
(list 6 7))))
#+end_src
#+RESULTS:
: (1 (4 (9 16) 25) (36 49))
2. High-level version
#+begin_src scheme :exports both :results output :noweb-ref square-subtree-map
(define (square-tree tree)
(map (lambda (sub-tree)
(if (pair? sub-tree)
(square-tree sub-tree)
(square sub-tree)))
tree))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<square-subtree-map>>
(show #t " " (square-tree
(list 1
(list 2 (list 3 4) 5)
(list 6 7))))
#+end_src
#+RESULTS:
: (1 (4 (9 16) 25) (36 49))
Not a very hard problem.
*** DONE Exercise 2.31 tree-map square tree
CLOSED: [2019-09-11 Wed 14:38]
Not a very hard problem.
#+begin_src scheme :exports both :results output
(define (square-tree tree) (tree-map square tree))
(define (tree-map square tree)
(map (lambda (sub-tree)
(if (pair? sub-tree)
(tree-map square sub-tree)
(square sub-tree)))
tree))
(show #t " "
(square-tree
(list 1
(list 2 (list 3 4) 5)
(list 6 7))))
#+end_src
#+RESULTS:
: (1 (4 (9 16) 25) (36 49))
*** DONE Exercise 2.32 subsets
CLOSED: [2019-09-11 Wed 14:53]
#+begin_src scheme :exports both :results value :noweb-ref subsets
(define (subsets s)
(if (null? s)
(list '())
(let ((rest (subsets (cdr s))))
(append rest (map (lambda (suffix) (append (list (car s)) suffix)) rest)))))
(subsets '(1 2 3))
#+end_src
#+RESULTS:
|---+---+---|
| 3 | | |
| 2 | | |
| 2 | 3 | |
| 1 | | |
| 1 | 3 | |
| 1 | 2 | |
| 1 | 2 | 3 |
The explanation is easy. The subsets can be constructed by taking any
element, say, the first, and appending it to every subset of the rest
of the set. That is if we already have a set of subsets of some set
*S*, and we are adding some element *a*, then it may or may not be in
every subset of the enlarged set *S+a*.
*** TODO Figure 2.7 Signal-flow diagram
*** DONE Exercise 2.33 map-append-length
CLOSED: [2019-09-11 Wed 23:53]
#+begin_src scheme :exports both :results value :noweb-ref filter
(define (filter predicate sequence)
(cond ((null? sequence) '())
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
#+end_src
n
#+begin_src scheme :exports both :results value :noweb-ref accumulate
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref enumerate-interval
(define (enumerate-interval low high)
(if (> low high)
'()
(cons low (enumerate-interval (+ low 1) high))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref enumerate-tree
(define (enumerate-tree tree)
(cond ((null? tree) '())
((not (pair? tree)) (list tree))
(else (append (enumerate-tree (car tree))
(enumerate-tree (cdr tree))))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref map-append-length
(define (map p sequence)
(accumulate (lambda (x y) (x y)) '() sequence))
(define (append seq1 seq2)
(accumulate cons seq2 seq1))
(define (length sequence)
(accumulate (lambda (x y) (+ 1 y))))
#+end_src
#+begin_src scheme :exports both :results value
(length (make-list 100 99))
#+end_src
#+RESULTS:
: 100
*** DONE Exercise 2.34 horners-rule
CLOSED: [2019-09-12 Thu 00:01]
#+begin_src scheme :exports both :results value
<<accumulate>>
(define (horner-eval x coefficient-sequence)
(accumulate (lambda (this-coeff higher-terms) (+ this-coeff (* x higher-terms)))
0
coefficient-sequence))
(horner-eval 2 (list 1 3 0 5 0 1))
#+end_src
#+RESULTS:
: 79
*** DONE Exercise 2.35 count-leaves-accumulate
CLOSED: [2019-09-12 Thu 00:17]
#+begin_src scheme :exports both :results value
<<accumulate>>
(define (count-leaves t)
(accumulate + 0 (map (lambda (x) (if (pair? x)
(count-leaves x)
1)) t)))
(count-leaves (list 1 2 3))
#+end_src
#+RESULTS:
: 3
*** DONE Exercise 2.36 accumulate-n
CLOSED: [2019-09-12 Thu 00:26]
#+begin_src scheme :exports both :results value :noweb-ref accumulate-n
<<accumulate>>
(define (accumulate-n op init seqs)
(if (null? (car seqs))
'()
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
#+end_src
#+begin_src scheme :exports both :results value
<<accumulate-n>>
(accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))
#+end_src
#+RESULTS:
| 22 | 26 | 30 |
*** DONE Exercise 2.37 matrix-*-vector
CLOSED: [2019-09-12 Thu 00:50]
#+begin_src scheme :exports both :results value :noweb-ref dot-product
(define (dot-product v w)
(accumulate + 0 (map * v w)))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref matrix-operations
(define (matrix-*-vector m v)
(map (lambda (x) (dot-product v x)) m))
(define (transpose mat)
(accumulate-n cons '() mat))
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map (lambda (x) (matrix-*-vector m x)) n)))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<accumulate>>
<<accumulate-n>>
<<dot-product>>
<<matrix-operations>>
(show #t " " (matrix-*-vector '((1 2 3 4) (4 5 6 6) (6 7 8 9)) '(1 2 3 4)) "\n")
(show #t " " (transpose '((1 2 3 4) (4 5 6 6) (6 7 8 9))) "\n")
(show #t " " (matrix-*-matrix
'((1 2 3 4) (4 5 6 6) (6 7 8 9))
'((1 2 3 4) (4 5 6 6) (6 7 8 9)) ) "\n")
#+end_src
#+RESULTS:
: (30 56 80)
: ((1 4 6) (2 5 7) (3 6 8) (4 6 9))
: ((30 56 80) (56 113 161) (80 161 230))
*** DONE Exercise 2.38 fold-left
CLOSED: [2019-09-12 Thu 09:45]
#+begin_src scheme :exports both :results value :noweb-ref fold-left
(define (fold-left op initial sequence)
(define (iter result rest)
(if (null? rest)
result
(iter (op result (car rest))
(cdr rest))))
(iter initial sequence))
#+end_src
#+begin_src scheme :exports both :results output
<<accumulate>>
<<fold-left>>
(show #t " " (accumulate / 1 (list 1 2 3)) "\n")
(show #t " " (fold-left / 1 (list 1 2 3)) "\n")
(show #t " " (accumulate list '() (list 1 2 3)) "\n")
(show #t " " (fold-left list '() (list 1 2 3)) "\n")
(show #t " " (fold-left + 0 (list 1 2 3)) "\n")
(show #t " " (accumulate + 0 (list 1 2 3)) "\n")
#+end_src
#+RESULTS:
: 3/2
: 1/6
: (1 (2 (3 ())))
: (((() 1) 2) 3)
: 6
: 6
Well, it seems that commutative operations, that is the ones for which
\(a+b = b+a\).
*** DONE Exercise 2.39 reverse fold-right fold-left
CLOSED: [2019-09-12 Thu 09:52]
#+begin_src scheme :exports both :results output
<<accumulate>>
<<fold-left>>
(define (reverse sequence)
(accumulate (lambda (x y) (cons x y)) '() sequence))
(show #t " " (reverse (list 1 2 3)) "\n")
(define (reverse sequence)
(fold-left (lambda (x y) (cons y x)) '() sequence))
(show #t " " (reverse (list 1 2 3)))
#+end_src
#+RESULTS:
: (1 2 3)
: (3 2 1)
*** DONE Exercise 2.40 unique-pairs
CLOSED: [2019-09-12 Thu 10:34]
0:42:00
#+begin_src scheme :exports both :results value :noweb-ref flatmap
(define (flatmap proc seq)
(accumulate append '() (map proc seq)))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref prime-sum
(define (prime-sum? pair)
(prime? (+ (car pair) (cadr pair))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref make-pair-sum
(define (make-pair-sum pair)
(list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref prime-sum-pairs
(define (prime-sum-pairs n)
(map make-pair-sum
(filter prime-sum? (flatmap
(lambda (i)
(map (lambda (j) (list i j))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 1 n)))))
#+end_src
#+begin_src scheme :exports both :results output
<<prime-sum-pairs>>
<<enumerate-interval>>
<<flatmap>>
<<accumulate>>
<<prime-sum>>
<<filter>>
<<fast-prime>>
<<fermat-primetest>>
<<expmod-miller-rabin>>
<<make-pair-sum>>
<<map-append-length>>
(show #t " " (prime-sum-pairs 30))
#+end_src
#+RESULTS:
: ((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7) (6 1 7) (6 5 11) (7 4 11) (7 6 13) (8 3 11) (8 5 13) (9 2 11) (9 4 13) (9 8 17) (10 1 11) (10 3 13) (10 7 17) (10 9 19) (11 2 13) (11 6 17) (11 8 19) (12 1 13) (12 5 17) (12 7 19) (12 11 23) (13 4 17) (13 6 19) (13 10 23) (14 3 17) (14 5 19) (14 9 23) (15 2 17) (15 4 19) (15 8 23) (15 14 29) (16 1 17) (16 3 19) (16 7 23) (16 13 29) (16 15 31) (17 2 19) (17 6 23) (17 12 29) (17 14 31) (18 1 19) (18 5 23) (18 11 29) (18 13 31) (19 4 23) (19 10 29) (19 12 31) (19 18 37) (20 3 23) (20 9 29) (20 11 31) (20 17 37) (21 2 23) (21 8 29) (21 10 31) (21 16 37) (21 20 41) (22 1 23) (22 7 29) (22 9 31) (22 15 37) (22 19 41) (22 21 43) (23 6 29) (23 8 31) (23 14 37) (23 18 41) (23 20 43) (24 5 29) (24 7 31) (24 13 37) (24 17 41) (24 19 43) (24 23 47) (25 4 29) (25 6 31) (25 12 37) (25 16 41) (25 18 43) (25 22 47) (26 3 29) (26 5 31) (26 11 37) (26 15 41) (26 17 43) (26 21 47) (27 2 29) (27 4 31) (27 10 37) (27 14 41) (27 16 43) (27 20 47) (27 26 53) (28 1 29) (28 3 31) (28 9 37) (28 13 41) (28 15 43) (28 19 47) (28 25 53) (29 2 31) (29 8 37) (29 12 41) (29 14 43) (29 18 47) (29 24 53) (30 1 31) (30 7 37) (30 11 41) (30 13 43) (30 17 47) (30 23 53) (30 29 59))
#+begin_src scheme :exports both :results value :noweb-ref unique-pairs
(define (unique-pairs n)
(flatmap
(lambda (i)
(map (lambda (j) (list i j))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 1 n)))
#+end_src
#+begin_src scheme :exports both :results value
<<unique-pairs>>
<<flatmap>>
<<enumerate-interval>>
<<accumulate>>
(unique-pairs 3)
#+end_src
#+RESULTS:
| 2 | 1 |
| 3 | 1 |
| 3 | 2 |
#+begin_src scheme :exports both :results value :noweb-ref prime-sum-pairs-unique-pairs
(define (prime-sum-pairs n)
(map make-pair-sum
(filter prime-sum? (unique-pairs n))))
#+end_src
#+begin_src scheme :exports both :results value
<<unique-pairs>>
<<prime-sum-pairs-unique-pairs>>
<<enumerate-interval>>
<<flatmap>>
<<accumulate>>
<<prime-sum>>
<<filter>>
<<fast-prime>>
<<fermat-primetest>>
<<expmod-miller-rabin>>
<<make-pair-sum>>
<<map-append-length>>
(prime-sum-pairs 10)
#+end_src
#+RESULTS:
| 2 | 1 | 3 |
| 3 | 2 | 5 |
| 4 | 1 | 5 |
| 4 | 3 | 7 |
| 5 | 2 | 7 |
| 6 | 1 | 7 |
| 6 | 5 | 11 |
| 7 | 4 | 11 |
| 7 | 6 | 13 |
| 8 | 3 | 11 |
| 8 | 5 | 13 |
| 9 | 2 | 11 |
| 9 | 4 | 13 |
| 9 | 8 | 17 |
| 10 | 1 | 11 |
| 10 | 3 | 13 |
| 10 | 7 | 17 |
| 10 | 9 | 19 |
I have to note that this deceiptively simple task involves reusing
results of 12 other problems.
*** DONE Exercise 2.41 triple-sum
CLOSED: [2019-09-14 Sat 15:15]
*Exercise 2.41:* Write a procedure to find all ordered triples of
distinct positive integers i, j, and k less than or equal to a
given integer n that sum to a given integer s.
#+begin_src scheme :exports both :results value :noweb-ref unique-triples
(define (unique-triples n)
(flatmap
(lambda (i)
(flatmap (lambda (j)
(map (lambda (k) (list i j k))
(enumerate-interval 1 (- j 1))))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 1 n)))
#+end_src
#+begin_src scheme :exports both :results output
<<accumulate>>
<<enumerate-interval>>
<<flatmap>>
<<unique-triples>>
(show #t " " (unique-triples 5) "\n")
#+end_src
#+RESULTS:
: ((3 2 1) (4 2 1) (4 3 1) (4 3 2) (5 2 1) (5 3 1) (5 3 2) (5 4 1) (5 4 2) (5 4 3))
#+begin_src scheme :exports both :results value :noweb-ref sum-equal-s
(define (sum-equal-s? s tuple)
(if (= s (accumulate + 0 tuple))
#t
#f))
#+end_src
#+begin_src scheme :exports both :results value
<<sum-equal-s>>
<<accumulate>>
(and (sum-equal-s? 30 (list 10 5 5 9 1)) (not (sum-equal-s? 10 (list 3 3 3))))
#+end_src
#+RESULTS:
: #t
#+begin_src scheme :exports both :results value :noweb-ref sum-equal-s-triples
(define (sum-equal-s-triples s n)
(filter (lambda (x) (sum-equal-s? s x)) (unique-triples n)))
#+end_src
#+begin_src scheme :exports both :results value
<<enumerate-interval>>
<<flatmap>>
<<sum-equal-s-triples>>
<<accumulate>>
<<sum-equal-s>>
<<filter>>
<<unique-triples>>
(sum-equal-s-triples 15 30)
#+end_src
#+RESULTS:
| 6 | 5 | 4 |
| 7 | 5 | 3 |
| 7 | 6 | 2 |
| 8 | 4 | 3 |
| 8 | 5 | 2 |
| 8 | 6 | 1 |
| 9 | 4 | 2 |
| 9 | 5 | 1 |
| 10 | 3 | 2 |
| 10 | 4 | 1 |
| 11 | 3 | 1 |
| 12 | 2 | 1 |
*** DONE Figure 2.8 A solution to the eight-queens puzzle.
#+begin_src plantuml :exports both :file figure-2-8.png
@startditaa
+---+---+---+---+---+---+---+---+
| | | | | | Q | | |
+---+---+---+---+---+---+---+---+
| | | Q | | | | | |
+---+---+---+---+---+---+---+---+
| Q | | | | | | | |
+---+---+---+---+---+---+---+---+
| | | | | | | Q | |
+---+---+---+---+---+---+---+---+
| | | | | Q | | | |
+---+---+---+---+---+---+---+---+
| | | | | | | | Q |
+---+---+---+---+---+---+---+---+
| | Q | | | | | | |
+---+---+---+---+---+---+---+---+
| | | | Q | | | | |
+---+---+---+---+---+---+---+---+
@endditaa
#+end_src
#+RESULTS:
[[file:figure-2-8.png]]
*** DONE Exercise 2.42 k-queens
CLOSED: [2019-09-17 Tue 22:27]
3:00:00 + 2:00:00 + 1:00:00 = 6:00:00
The commentary to this problem is bad. Firstly, it is *NOT* obvious
that it is even possible to place a queen into every column and every
row. Indeed, in the solution above, this happens to be the case, but
this is by no means obvious.
The second thought: since the algorithm is expected to provide *all*
possible solutions, it should be required have a list of lists... sort
of, to represent the multitude. So ~queens~ should return a list of
lists.
Secondly, the code given by the authors is totally moronic in at least
two places:
1. rest-of-queens? Seriously? Why not "world of queens", or
"suffix-queens", to make it even more obscure? It should have been
called "prefix-queens", or, better "queens-already-on-board". We
are not short of bytes, are we?
2. who on Earth would call a procedure "queen-cols"? What does it
even mean? Descriptive names -- zero.
The third thought: anyone who wants to solve this puzzle, must at
least know what it is for a queen to be "safe". That is, if a queen
number A has a position b_1 then our new queen's B position b_2 must
satisfy : 1) b_2 \neq b_1 2)|b_2 - b_1| \ne B - A. And this must be true
\forall A < B.
The fourth thought: it is *NOT* obvious, but the "rest of queens"
contains the list of queens _in the reversed order_. So ~car~'ing
anything with it represents attaching the queen _to the end_ of the
list. This is why we have *k* supplied as an argument to the ~safe?~
procedure.
#+begin_src scheme :exports both :results value :noweb-ref k-queens
(define (queens board-size)
(define (queen-cols k)
(if (= k 0)
(list empty-board)
(filter
(lambda (positions) (safe? k positions))
(flatmap
(lambda (rest-of-queens)
(map (lambda (new-row)
(adjoin-position new-row k rest-of-queens))
(enumerate-interval 1 board-size)))
(queen-cols (- k 1))))))
(queen-cols board-size))
#+end_src
#+begin_src scheme :exports both :results output
<<k-queens>>
<<flatmap>>
<<enumerate-interval>>
<<accumulate>>
<<filter>>
(define empty-board '())
(define (adjoin-position new-row k rest-of-queens)
(cons (cons k new-row) rest-of-queens))
(define (safe? k positions)
(cond ((null? (cdr positions)) #t)
((= k 1) #t)
((= (cdar positions) (cdadr positions)) #f)
((= (abs (- (cdar positions) (cdadr positions))) (abs (- (caar positions) (caadr positions)))) #f)
(else (safe? k (cons (car positions) (cddr positions))))))
(map (lambda (x) (show #t " " x "\n")) (queens 8))
#+end_src
#+RESULTS:
#+begin_example
((8 . 4) (7 . 2) (6 . 7) (5 . 3) (4 . 6) (3 . 8) (2 . 5) (1 . 1))
((8 . 5) (7 . 2) (6 . 4) (5 . 7) (4 . 3) (3 . 8) (2 . 6) (1 . 1))
((8 . 3) (7 . 5) (6 . 2) (5 . 8) (4 . 6) (3 . 4) (2 . 7) (1 . 1))
((8 . 3) (7 . 6) (6 . 4) (5 . 2) (4 . 8) (3 . 5) (2 . 7) (1 . 1))
((8 . 5) (7 . 7) (6 . 1) (5 . 3) (4 . 8) (3 . 6) (2 . 4) (1 . 2))
((8 . 4) (7 . 6) (6 . 8) (5 . 3) (4 . 1) (3 . 7) (2 . 5) (1 . 2))
((8 . 3) (7 . 6) (6 . 8) (5 . 1) (4 . 4) (3 . 7) (2 . 5) (1 . 2))
((8 . 5) (7 . 3) (6 . 8) (5 . 4) (4 . 7) (3 . 1) (2 . 6) (1 . 2))
((8 . 5) (7 . 7) (6 . 4) (5 . 1) (4 . 3) (3 . 8) (2 . 6) (1 . 2))
((8 . 4) (7 . 1) (6 . 5) (5 . 8) (4 . 6) (3 . 3) (2 . 7) (1 . 2))
((8 . 3) (7 . 6) (6 . 4) (5 . 1) (4 . 8) (3 . 5) (2 . 7) (1 . 2))
((8 . 4) (7 . 7) (6 . 5) (5 . 3) (4 . 1) (3 . 6) (2 . 8) (1 . 2))
((8 . 6) (7 . 4) (6 . 2) (5 . 8) (4 . 5) (3 . 7) (2 . 1) (1 . 3))
((8 . 6) (7 . 4) (6 . 7) (5 . 1) (4 . 8) (3 . 2) (2 . 5) (1 . 3))
((8 . 1) (7 . 7) (6 . 4) (5 . 6) (4 . 8) (3 . 2) (2 . 5) (1 . 3))
((8 . 6) (7 . 8) (6 . 2) (5 . 4) (4 . 1) (3 . 7) (2 . 5) (1 . 3))
((8 . 6) (7 . 2) (6 . 7) (5 . 1) (4 . 4) (3 . 8) (2 . 5) (1 . 3))
((8 . 4) (7 . 7) (6 . 1) (5 . 8) (4 . 5) (3 . 2) (2 . 6) (1 . 3))
((8 . 5) (7 . 8) (6 . 4) (5 . 1) (4 . 7) (3 . 2) (2 . 6) (1 . 3))
((8 . 4) (7 . 8) (6 . 1) (5 . 5) (4 . 7) (3 . 2) (2 . 6) (1 . 3))
((8 . 2) (7 . 7) (6 . 5) (5 . 8) (4 . 1) (3 . 4) (2 . 6) (1 . 3))
((8 . 1) (7 . 7) (6 . 5) (5 . 8) (4 . 2) (3 . 4) (2 . 6) (1 . 3))
((8 . 2) (7 . 5) (6 . 7) (5 . 4) (4 . 1) (3 . 8) (2 . 6) (1 . 3))
((8 . 4) (7 . 2) (6 . 7) (5 . 5) (4 . 1) (3 . 8) (2 . 6) (1 . 3))
((8 . 5) (7 . 7) (6 . 1) (5 . 4) (4 . 2) (3 . 8) (2 . 6) (1 . 3))
((8 . 6) (7 . 4) (6 . 1) (5 . 5) (4 . 8) (3 . 2) (2 . 7) (1 . 3))
((8 . 5) (7 . 1) (6 . 4) (5 . 6) (4 . 8) (3 . 2) (2 . 7) (1 . 3))
((8 . 5) (7 . 2) (6 . 6) (5 . 1) (4 . 7) (3 . 4) (2 . 8) (1 . 3))
((8 . 6) (7 . 3) (6 . 7) (5 . 2) (4 . 8) (3 . 5) (2 . 1) (1 . 4))
((8 . 2) (7 . 7) (6 . 3) (5 . 6) (4 . 8) (3 . 5) (2 . 1) (1 . 4))
((8 . 7) (7 . 3) (6 . 1) (5 . 6) (4 . 8) (3 . 5) (2 . 2) (1 . 4))
((8 . 5) (7 . 1) (6 . 8) (5 . 6) (4 . 3) (3 . 7) (2 . 2) (1 . 4))
((8 . 1) (7 . 5) (6 . 8) (5 . 6) (4 . 3) (3 . 7) (2 . 2) (1 . 4))
((8 . 3) (7 . 6) (6 . 8) (5 . 1) (4 . 5) (3 . 7) (2 . 2) (1 . 4))
((8 . 6) (7 . 3) (6 . 1) (5 . 7) (4 . 5) (3 . 8) (2 . 2) (1 . 4))
((8 . 7) (7 . 5) (6 . 3) (5 . 1) (4 . 6) (3 . 8) (2 . 2) (1 . 4))
((8 . 7) (7 . 3) (6 . 8) (5 . 2) (4 . 5) (3 . 1) (2 . 6) (1 . 4))
((8 . 5) (7 . 3) (6 . 1) (5 . 7) (4 . 2) (3 . 8) (2 . 6) (1 . 4))
((8 . 2) (7 . 5) (6 . 7) (5 . 1) (4 . 3) (3 . 8) (2 . 6) (1 . 4))
((8 . 3) (7 . 6) (6 . 2) (5 . 5) (4 . 8) (3 . 1) (2 . 7) (1 . 4))
((8 . 6) (7 . 1) (6 . 5) (5 . 2) (4 . 8) (3 . 3) (2 . 7) (1 . 4))
((8 . 8) (7 . 3) (6 . 1) (5 . 6) (4 . 2) (3 . 5) (2 . 7) (1 . 4))
((8 . 2) (7 . 8) (6 . 6) (5 . 1) (4 . 3) (3 . 5) (2 . 7) (1 . 4))
((8 . 5) (7 . 7) (6 . 2) (5 . 6) (4 . 3) (3 . 1) (2 . 8) (1 . 4))
((8 . 3) (7 . 6) (6 . 2) (5 . 7) (4 . 5) (3 . 1) (2 . 8) (1 . 4))
((8 . 6) (7 . 2) (6 . 7) (5 . 1) (4 . 3) (3 . 5) (2 . 8) (1 . 4))
((8 . 3) (7 . 7) (6 . 2) (5 . 8) (4 . 6) (3 . 4) (2 . 1) (1 . 5))
((8 . 6) (7 . 3) (6 . 7) (5 . 2) (4 . 4) (3 . 8) (2 . 1) (1 . 5))
((8 . 4) (7 . 2) (6 . 7) (5 . 3) (4 . 6) (3 . 8) (2 . 1) (1 . 5))
((8 . 7) (7 . 1) (6 . 3) (5 . 8) (4 . 6) (3 . 4) (2 . 2) (1 . 5))
((8 . 1) (7 . 6) (6 . 8) (5 . 3) (4 . 7) (3 . 4) (2 . 2) (1 . 5))
((8 . 3) (7 . 8) (6 . 4) (5 . 7) (4 . 1) (3 . 6) (2 . 2) (1 . 5))
((8 . 6) (7 . 3) (6 . 7) (5 . 4) (4 . 1) (3 . 8) (2 . 2) (1 . 5))
((8 . 7) (7 . 4) (6 . 2) (5 . 8) (4 . 6) (3 . 1) (2 . 3) (1 . 5))
((8 . 4) (7 . 6) (6 . 8) (5 . 2) (4 . 7) (3 . 1) (2 . 3) (1 . 5))
((8 . 2) (7 . 6) (6 . 1) (5 . 7) (4 . 4) (3 . 8) (2 . 3) (1 . 5))
((8 . 2) (7 . 4) (6 . 6) (5 . 8) (4 . 3) (3 . 1) (2 . 7) (1 . 5))
((8 . 3) (7 . 6) (6 . 8) (5 . 2) (4 . 4) (3 . 1) (2 . 7) (1 . 5))
((8 . 6) (7 . 3) (6 . 1) (5 . 8) (4 . 4) (3 . 2) (2 . 7) (1 . 5))
((8 . 8) (7 . 4) (6 . 1) (5 . 3) (4 . 6) (3 . 2) (2 . 7) (1 . 5))
((8 . 4) (7 . 8) (6 . 1) (5 . 3) (4 . 6) (3 . 2) (2 . 7) (1 . 5))
((8 . 2) (7 . 6) (6 . 8) (5 . 3) (4 . 1) (3 . 4) (2 . 7) (1 . 5))
((8 . 7) (7 . 2) (6 . 6) (5 . 3) (4 . 1) (3 . 4) (2 . 8) (1 . 5))
((8 . 3) (7 . 6) (6 . 2) (5 . 7) (4 . 1) (3 . 4) (2 . 8) (1 . 5))
((8 . 4) (7 . 7) (6 . 3) (5 . 8) (4 . 2) (3 . 5) (2 . 1) (1 . 6))
((8 . 4) (7 . 8) (6 . 5) (5 . 3) (4 . 1) (3 . 7) (2 . 2) (1 . 6))
((8 . 3) (7 . 5) (6 . 8) (5 . 4) (4 . 1) (3 . 7) (2 . 2) (1 . 6))
((8 . 4) (7 . 2) (6 . 8) (5 . 5) (4 . 7) (3 . 1) (2 . 3) (1 . 6))
((8 . 5) (7 . 7) (6 . 2) (5 . 4) (4 . 8) (3 . 1) (2 . 3) (1 . 6))
((8 . 7) (7 . 4) (6 . 2) (5 . 5) (4 . 8) (3 . 1) (2 . 3) (1 . 6))
((8 . 8) (7 . 2) (6 . 4) (5 . 1) (4 . 7) (3 . 5) (2 . 3) (1 . 6))
((8 . 7) (7 . 2) (6 . 4) (5 . 1) (4 . 8) (3 . 5) (2 . 3) (1 . 6))
((8 . 5) (7 . 1) (6 . 8) (5 . 4) (4 . 2) (3 . 7) (2 . 3) (1 . 6))
((8 . 4) (7 . 1) (6 . 5) (5 . 8) (4 . 2) (3 . 7) (2 . 3) (1 . 6))
((8 . 5) (7 . 2) (6 . 8) (5 . 1) (4 . 4) (3 . 7) (2 . 3) (1 . 6))
((8 . 3) (7 . 7) (6 . 2) (5 . 8) (4 . 5) (3 . 1) (2 . 4) (1 . 6))
((8 . 3) (7 . 1) (6 . 7) (5 . 5) (4 . 8) (3 . 2) (2 . 4) (1 . 6))
((8 . 8) (7 . 2) (6 . 5) (5 . 3) (4 . 1) (3 . 7) (2 . 4) (1 . 6))
((8 . 3) (7 . 5) (6 . 2) (5 . 8) (4 . 1) (3 . 7) (2 . 4) (1 . 6))
((8 . 3) (7 . 5) (6 . 7) (5 . 1) (4 . 4) (3 . 2) (2 . 8) (1 . 6))
((8 . 5) (7 . 2) (6 . 4) (5 . 6) (4 . 8) (3 . 3) (2 . 1) (1 . 7))
((8 . 6) (7 . 3) (6 . 5) (5 . 8) (4 . 1) (3 . 4) (2 . 2) (1 . 7))
((8 . 5) (7 . 8) (6 . 4) (5 . 1) (4 . 3) (3 . 6) (2 . 2) (1 . 7))
((8 . 4) (7 . 2) (6 . 5) (5 . 8) (4 . 6) (3 . 1) (2 . 3) (1 . 7))
((8 . 4) (7 . 6) (6 . 1) (5 . 5) (4 . 2) (3 . 8) (2 . 3) (1 . 7))
((8 . 6) (7 . 3) (6 . 1) (5 . 8) (4 . 5) (3 . 2) (2 . 4) (1 . 7))
((8 . 5) (7 . 3) (6 . 1) (5 . 6) (4 . 8) (3 . 2) (2 . 4) (1 . 7))
((8 . 4) (7 . 2) (6 . 8) (5 . 6) (4 . 1) (3 . 3) (2 . 5) (1 . 7))
((8 . 6) (7 . 3) (6 . 5) (5 . 7) (4 . 1) (3 . 4) (2 . 2) (1 . 8))
((8 . 6) (7 . 4) (6 . 7) (5 . 1) (4 . 3) (3 . 5) (2 . 2) (1 . 8))
((8 . 4) (7 . 7) (6 . 5) (5 . 2) (4 . 6) (3 . 1) (2 . 3) (1 . 8))
((8 . 5) (7 . 7) (6 . 2) (5 . 6) (4 . 3) (3 . 1) (2 . 4) (1 . 8))
#+end_example
Because of really terrible introduction, this exercise took me 6 times
more than it's worth.
*** DONE Exercise 2.43 slow k-queens
CLOSED: [2019-09-17 Tue 22:55]
To answer this exercise, we need to estimate the complexity of the
canonical solution and Louis' solution.
For the canonical solution, we can safely assume that the ~safe?~
procedure filters out no sequences at all (this would only worsen our
estimate). Therefore, every additional column would multiply the total
computation needed by the size of the column. Roughly speaking, this
would be \(k^k \approx 2^k \rightarrow 2^{}^6 = 64\).
For the Louis's solution, however, the ~(queen-cols (- k 1))~ is
solved for every value of ~k~ from scratch, which is not necessary,
and adds an additional multiplicand of \(k^{k-1}\) for every
~k~. Roughly speaking, this adds an additional power of \(k-1\) to the
solution time. \( (k\cdot T)^k \approx 2^{6k}\rightarrow 2^{36}\). A little bit too much.
*** Remark. Now we are starting the "picture language" chapter.
It may (and will) require extensive modification to the standard
working environment, because I am not using the most default nowadays
Racket. In this subsection I will implement the required subroutines.
SICP is incredibly confusing in this chapter.
The following is one of the most prominent examples:
#+begin_src scheme :exports both :results value
(define (segments->painter segment-list)
(lambda (frame)
(for-each
(lambda (segment)
(draw-line
((frame-coord-map frame) (start-segment segment))
((frame-coord-map frame) (end-segment segment))))
segment-list)))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref draw-line
(define canvas-size
(make-parameter
200
(lambda (size)
(if (and (exact-integer? size) (<= 2 size 1000))
size
(error "invalid canvas size")))))
(define canvas-file-name
(make-parameter
(string-append "./" (substring (process->string "uuidgen") 0 36) ".png")
(lambda (name)
(if (string? name)
name
(error "invalid canvas file name")))))
(define (canvas-reset)
(system "rm" (canvas-file-name))
(system "convert" "xc:white"
"-scale" (string-append
(number->string (canvas-size))
"x"
(number->string (canvas-size)))
(canvas-file-name)))
(define (canvas-refresh)
(string-append "[[" (canvas-file-name) "]]"))
(canvas-reset)
(define (draw-line point1 point2)
(system "mogrify"
"-fill" "black"
"-draw" (string-append "line "
(number->string (* (canvas-size) (car point1)))
","
(number->string (* (canvas-size) (cadr point1)))
" "
(number->string (* (canvas-size) (car point2)))
","
(number->string (* (canvas-size) (cadr point2))))
(canvas-file-name))
#;(display (string-append "[[" (canvas-file-name) "]]"))
(string-append "[[" (canvas-file-name) "]]"))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results raw value
<<draw-line>>
(draw-line (list 0 0) (list 1 1))
(draw-line (list 0 1) (list 1 0))
#+end_src
#+RESULTS:
[[./d890f987-3ba1-41f4-a2b2-c427aa7c2858.gif]]
#+begin_src scheme :exports both :results value :noweb-ref pict-frame
(define (frame-coord-map frame)
(lambda (v)
(add-vect
(origin-frame frame)
(add-vect (scale-vect (xcor-vect v) (edge1-frame frame))
(scale-vect (ycor-vect v) (edge2-frame frame))))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value
<<make-frame>>
<<pict-frame>>
<<pict-vect>>
((frame-coord-map
(make-frame
(make-vect 0.1 0.2)
(make-vect 1.0 1.0)
(make-vect 1.0 1.0))) (make-vect 0 0))
#+end_src
#+RESULTS:
| 0.1 | 0.2 |
#+begin_src scheme :exports both :results raw value :noweb-ref segments-painter
(define (segments->painter segment-list)
(lambda (frame)
(for-each
(lambda (segment)
(draw-line
((frame-coord-map frame)
(start-segment segment))
((frame-coord-map frame)
(end-segment segment))))
segment-list)))
#+end_src
The next is the "rogers" painter. As usual with SICP, fighting with
the programming system takes more time than actually solving anything.
Took me 3 hours. (3:00:00)
Asked a question here: https://www.imagemagick.org/discourse-server/viewtopic.php?f=1&t=36770
#+begin_src scheme :exports both :results value :noweb-ref magick-vect
(define (pict-vect->magick-vect vector separator)
(string-append
(number->string (+ 1 (* (canvas-size) (xcor-vect vector))))
separator
(number->string (+ 1 (* (canvas-size) (ycor-vect vector))))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref rogers
(define (rogers frame)
(system "convert"
(canvas-file-name)
"("
"+distort" "affine"
(string-append
"1,1 " "1,1"
" 149,1 " (pict-vect->magick-vect (edge1-frame frame) ",")
" 1,180 " (pict-vect->magick-vect (edge2-frame frame) ","))
"-background" "transparent"
"-splice" (pict-vect->magick-vect
(origin-frame frame) "x")
"./assets/rogers.png" ")"
"-composite"
(canvas-file-name)))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<pict-frame>>
<<make-frame>>
<<magick-vect>>
<<rogers>>
<<draw-line>>
(rogers (make-frame (make-vect 0 0) (make-vect 1 0) (make-vect 0 1)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./755096f1-280f-4e39-bd9f-c17dada9ed69.png]]
#+begin_src scheme :exports both :results value :noweb-ref wave-bitmap
(define (wave frame)
#;(convert white.gif \( -distort "Affine" "1,1 1,1 1,149 1,200 180,1 200,1" rogers.png \) -composite output.gif)
#;(convert rogers.png -alpha set -virtual-pixel transparent +distort affine "1,1 1,1 1,50 1,50 50,1 50,50" -background transparent -splice "50x50" output.png)
(system "convert"
(canvas-file-name)
"("
"-alpha" "set" "-virtual-pixel" "transparent"
"+distort" "affine"
(string-append
"1,1 " "1,1"
" 152,1 " (pict-vect->magick-vect
(edge1-frame frame) ",")
" 1,184 " (pict-vect->magick-vect
(edge2-frame frame) ","))
"-background" "transparent"
"-splice" (pict-vect->magick-vect
(origin-frame frame) "x")
"./assets/wave.png" ")"
"-composite"
(canvas-file-name)))
#+end_src
#+RESULTS:
: #<undef>
*** DONE Exercise 2.44 up-split
CLOSED: [2019-09-23 Mon 22:54]
#+begin_src scheme :exports both :results value :noweb-ref up-split
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<make-frame>>
<<pict-segment>>
<<segments-painter>>
<<wave-segment>>
<<transform-painter>>
<<pict-frame>>
<<draw-line>>
<<beside>>
<<below-beside>>
<<rotate270>>
<<rotate90>>
<<up-split>>
((up-split wave 1) (make-frame (make-vect 0.0 1.0) (make-vect 1.0 0.0) (make-vect 0.0 -1.0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./47ef240d-2a8b-4886-8431-c7aade49fb09.png]]
*** DONE Exercise 2.45 split
CLOSED: [2019-09-24 Tue 01:37]
#+begin_src scheme :exports both :results value :noweb-ref split
(define (split op1 op2)
(define (split-inner painter n)
(if (= n 0)
painter
(let ((smaller (split-inner painter (- n 1))))
(op2 painter (op1 smaller smaller)))))
(lambda (painter n)
(split-inner painter n)))
(define up-split (split beside below))
(define right-split (split below beside))
#+end_src
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<make-frame>>
<<pict-segment>>
<<segments-painter>>
<<wave-segment>>
<<transform-painter>>
<<pict-frame>>
<<draw-line>>
<<beside>>
<<below-beside>>
<<rotate270>>
<<rotate90>>
<<split>>
((up-split wave 1) (make-frame (make-vect 0.0 1.0) (make-vect 1.0 0.0) (make-vect 0.0 -1.0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./43404b14-9224-4b64-b304-7beebed2c3c8.png]]
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<make-frame>>
<<pict-segment>>
<<segments-painter>>
<<wave-segment>>
<<transform-painter>>
<<pict-frame>>
<<draw-line>>
<<beside>>
<<below-beside>>
<<rotate270>>
<<rotate90>>
<<split>>
((right-split wave 1) (make-frame (make-vect 0.0 1.0) (make-vect 1.0 0.0) (make-vect 0.0 -1.0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./b96c593e-a711-4824-a79c-4b4e911d1374.png]]
*** DONE Exercise 2.46 make-vect
CLOSED: [2019-09-20 Fri 12:48]
#+begin_src scheme :exports both :results value :noweb-ref pict-vect
(define (make-vect xcor ycor . o)
(append (list xcor) (list ycor) o))
(define (xcor-vect vect)
(car vect))
(define (ycor-vect vect)
(cadr vect))
(define (scale-vect scale vect)
(map (lambda (x) (* x scale)) vect))
(define (add-vect vec1 vec2)
(map (lambda (cor1 cor2) (+ cor1 cor2)) vec1 vec2))
(define (sub-vect vec1 vec2)
(map (lambda (cor1 cor2) (- cor1 cor2)) vec1 vec2))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<pict-vect>>
(show #t (make-vect 1 2 3) "\n")
(show #t (xcor-vect (make-vect 1 2 3)) "\n")
(show #t (ycor-vect (make-vect 1 2 3)) "\n")
(show #t (scale-vect 2 (make-vect 1 2 3)) "\n")
(show #t (add-vect (make-vect 1 2 3) (make-vect 1 2 3)) "\n")
(show #t (sub-vect (make-vect 1 2 3) (make-vect 1 2 3)) "\n")
#+end_src
#+RESULTS:
: (1 2 3)
: 1
: 2
: (2 4 6)
: (2 4 6)
: (0 0 0)
*** DONE Exercise 2.47 make-frame
CLOSED: [2019-09-20 Fri 14:48]
#+begin_src scheme :exports both :results value :noweb-ref make-frame
(define (make-frame origin edge1 edge2)
(list origin edge1 edge2))
(define (origin-frame frame)
(car frame))
(define (edge1-frame frame)
(cadr frame))
(define (edge2-frame frame)
(caddr frame))
#+end_src
#+begin_src scheme :exports both :results output
<<make-frame>>
<<pict-vect>>
(make-frame (make-vect 0.1 0.2) (make-vect 0.1 0.2) (make-vect 0.0 0.3))
(origin-frame (make-frame (make-vect 0.1 0.2) (make-vect 0.1 0.2) (make-vect 0.0 0.3)))
(edge1-frame (make-frame (make-vect 0.1 0.2) (make-vect 0.1 0.2) (make-vect 0.0 0.3)))
(edge2-frame (make-frame (make-vect 0.1 0.2) (make-vect 0.1 0.2) (make-vect 0.0 0.3)))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<pict-vect>>
(define (make-frame origin edge1 edge2)
(cons origin (cons edge1 edge2)))
(define (origin-frame frame)
(car frame))
(define (edge1-frame frame)
(cadr frame))
(define (edge2-frame frame)
(cddr frame))
(show #t (origin-frame (make-frame (make-vect 0.1 0.2) (make-vect 0.1 0.2) (make-vect 0.0 0.3))) "\n")
(show #t (edge1-frame (make-frame (make-vect 0.1 0.2) (make-vect 0.1 0.2) (make-vect 0.0 0.3))) "\n")
(show #t (edge2-frame (make-frame (make-vect 0.1 0.2) (make-vect 0.1 0.2) (make-vect 0.0 0.3))) "\n")
#+end_src
#+RESULTS:
: (0.1 0.2)
: (0.1 0.2)
: (0.0 0.3)
*** DONE Exercise 2.48 make-segment
CLOSED: [2019-09-20 Fri 16:06]
#+begin_src scheme :exports both :results value :noweb-ref pict-segment
(define (make-segment start-vector end-vector)
(list start-vector end-vector))
(define (start-segment segment)
(car segment))
(define (end-segment segment)
(cadr segment))
#+end_src
#+begin_src scheme :exports both :results raw value
<<draw-line>>
<<pict-segment>>
<<segments-painter>>
<<pict-vect>>
<<make-frame>>
<<pict-frame>>
((segments->painter
(list
(make-segment (make-vect 0 0) (make-vect 1 1))
(make-segment (make-vect 0 1) (make-vect 1 0))))
(make-frame (make-vect 0 0) (make-vect 0 1) (make-vect 1 0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[/tmp/scheme-temp.gif]]
*** DONE Exercise 2.49 segments->painter applications
CLOSED: [2019-09-20 Fri 23:10]
#+begin_src scheme :exports both :results value :noweb-ref x-painter
(define x-painter
(segments->painter
(list
(make-segment (make-vect 0 0) (make-vect 1 1))
(make-segment (make-vect 0 1) (make-vect 1 0)))))
#+end_src
#+begin_src scheme :exports both :results raw value
<<draw-line>>
<<pict-segment>>
<<segments-painter>>
<<pict-vect>>
<<make-frame>>
<<pict-frame>>
<<x-painter>>
(x-painter
(make-frame (make-vect 0 0) (make-vect 0 1) (make-vect 1 0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./a58f8946-42b6-43c4-89a5-59e892599394.gif]]
This painter is not entirely accurate, because my background is black,
so the lines would coalesce with it. I therefore just moved the lines
a little bit inside.
#+begin_src scheme :exports both :results value :noweb-ref frame-boundary-painter
(define frame-boundary-painter
(segments->painter
(list
(make-segment (make-vect 0.01 0.01) (make-vect 0.01 0.99))
(make-segment (make-vect 0.01 0.99) (make-vect 0.99 0.99))
(make-segment (make-vect 0.99 0.99) (make-vect 0.99 0.01))
(make-segment (make-vect 0.99 0.01) (make-vect 0.01 0.01)))))
#+end_src
#+begin_src scheme :exports both :results raw value
<<draw-line>>
<<pict-segment>>
<<segments-painter>>
<<pict-vect>>
<<make-frame>>
<<pict-frame>>
<<frame-boundary-painter>>
(frame-boundary-painter
(make-frame (make-vect 0.1 0.1) (make-vect 0.1 0.05) (make-vect 0.5 0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./c03f59fb-c473-4cc1-bb80-20c97e7e7594.gif]]
#+begin_src scheme :exports both :results value :noweb-ref diamond-painter
(define diamond-painter
(segments->painter
(list
(make-segment (make-vect 0.01 0.5) (make-vect 0.5 0.99))
(make-segment (make-vect 0.5 0.99) (make-vect 0.99 0.5))
(make-segment (make-vect 0.99 0.5) (make-vect 0.5 0.01))
(make-segment (make-vect 0.5 0.01) (make-vect 0.01 0.5)))))
#+end_src
#+begin_src scheme :exports both :results raw value
<<draw-line>>
<<pict-segment>>
<<segments-painter>>
<<pict-vect>>
<<make-frame>>
<<pict-frame>>
<<diamond-painter>>
(diamond-painter
(make-frame (make-vect 0 0) (make-vect 0 1) (make-vect 1 0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./90918df1-a802-4df6-a10d-afc50547bc72.gif]]
Remark: the exercise 2.49d is ambiguous. The "Unofficial Texinfo Version"
differs with the official paper version in this respect, since in the paper
version the waving figurine is drawn with segments, whereas the UTF uses a
bitmap.
This is the rough solution to the "segment-based" version.
#+begin_src scheme :exports both :results value :noweb-ref wave-segment
(define wave
(segments->painter
(list
(make-segment (make-vect .25 0) (make-vect .35 .5))
(make-segment (make-vect .35 .5) (make-vect .3 .6))
(make-segment (make-vect .3 .6) (make-vect .15 .4))
(make-segment (make-vect .15 .4) (make-vect 0 .65))
(make-segment (make-vect 0 .65) (make-vect 0 .85))
(make-segment (make-vect 0 .85) (make-vect .15 .6))
(make-segment (make-vect .15 .6) (make-vect .3 .65))
(make-segment (make-vect .3 .65) (make-vect .4 .65))
(make-segment (make-vect .4 .65) (make-vect .35 .85))
(make-segment (make-vect .35 .85) (make-vect .4 1))
(make-segment (make-vect .4 1) (make-vect .6 1))
(make-segment (make-vect .6 1) (make-vect .65 .85))
(make-segment (make-vect .65 .85) (make-vect .6 .65))
(make-segment (make-vect .6 .65) (make-vect .75 .65))
(make-segment (make-vect .75 .65) (make-vect 1 .35))
(make-segment (make-vect 1 .35) (make-vect 1 .15))
(make-segment (make-vect 1 .15) (make-vect .6 .45))
(make-segment (make-vect .6 .45) (make-vect .75 0))
(make-segment (make-vect .75 0) (make-vect .6 0))
(make-segment (make-vect .6 0) (make-vect .5 .3))
(make-segment (make-vect .5 .3) (make-vect .4 0))
(make-segment (make-vect .4 0) (make-vect .25 0))
)
)
)
#+end_src
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<pict-frame>>
<<magick-vect>>
<<make-frame>>
<<pict-segment>>
<<segments-painter>>
<<wave-segment>>
<<draw-line>>
(wave (make-frame (make-vect 0.0 0.9) (make-vect 0.7 0) (make-vect 0 -0.7)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./d9f0731a-a257-49cf-a71d-f8d3ab9e33ed.png]]
*** DONE Exercise 2.50 flip-horiz and rotate270 and rotate180
CLOSED: [2019-09-20 Fri 23:37]
0:27:00
#+begin_src scheme :exports both :results value :noweb-ref transform-painter
(define (transform-painter painter origin corner1 corner2)
(lambda (frame)
(let ((m (frame-coord-map frame)))
(let ((new-origin (m origin)))
(painter (make-frame
new-origin
(sub-vect (m corner1) new-origin)
(sub-vect (m corner2) new-origin)))))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref flip-horiz
(define (flip-horiz painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
#+end_src
#+begin_src scheme :exports both :results raw value
<<flip-horiz>>
<<pict-vect>>
<<pict-segment>>
<<segments-painter>>
<<transform-painter>>
<<make-frame>>
<<pict-frame>>
<<draw-line>>
<<wave-segment>>
(define bltr-line-painter
(segments->painter
(list
(make-segment (make-vect 0.0 0.00) (make-vect 1 1.0)))))
((flip-horiz wave) (make-frame (make-vect 0 1) (make-vect 1 0) (make-vect 0 -1)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./869de2d3-55f5-429a-ad9d-4941405a8d73.png]]
#+begin_src scheme :exports both :results value :noweb-ref rotate180
(define (rotate180 painter)
(transform-painter painter
(make-vect 1.0 1.0)
(make-vect 0.0 1.0)
(make-vect 1.0 0.0)))
#+end_src
#+begin_src scheme :exports both :results raw value
<<rotate180>>
<<pict-vect>>
<<pict-segment>>
<<segments-painter>>
<<transform-painter>>
<<make-frame>>
<<pict-frame>>
<<draw-line>>
<<wave-segment>>
(define ne-arrow-painter
(segments->painter
(list
(make-segment (make-vect 0.0 0.00) (make-vect 0.9 0.9))
(make-segment (make-vect 0.9 0.9) (make-vect 0.9 0.7))
(make-segment (make-vect 0.9 0.9) (make-vect 0.7 0.9)))))
#;(ne-arrow-painter (make-frame (make-vect 0 0) (make-vect 0 1) (make-vect 1 0)))
((rotate180 wave) (make-frame (make-vect 0 1) (make-vect 1 0) (make-vect 0 -1)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./51986072-473e-425b-959a-1bd81f471447.png]]
#+begin_src scheme :exports both :results value :noweb-ref rotate270
(define (rotate270 painter)
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
#+end_src
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<make-frame>>
<<rogers>>
<<transform-painter>>
<<pict-frame>>
<<draw-line>>
<<beside>>
<<below-beside>>
<<rotate270>>
<<pict-segment>>
<<segments-painter>>
<<wave-segment>>
#;((below rogers wave) (make-frame (make-vect 0.0 0.0) (make-vect 1.0 0.0) (make-vect 0.0 1.0)))
((rotate270 wave) (make-frame (make-vect 0.0 1.0) (make-vect 1.0 0.0) (make-vect 0.0 -1.0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./33a0bb01-aa51-420c-964d-73d089388c6c.png]]
*** DONE Exercise 2.51 below
CLOSED: [2019-09-22 Sun 18:50]
#+begin_src scheme :exports both :results value :noweb-ref beside
(define (beside painter1 painter2)
(let ((split-point (make-vect 0.5 0.0)))
(let ((paint-left
(transform-painter
painter1
(make-vect 0.0 0.0)
split-point
(make-vect 0.0 1.0)))
(paint-right
(transform-painter
painter2
split-point
(make-vect 1.0 0.0)
(make-vect 0.5 1.0))))
(lambda (frame)
(paint-left frame)
(paint-right frame)))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value :noweb-ref below
(define (below painter1 painter2)
(let ((split-point (make-vect 0.0 0.5)))
(let ((paint-bottom
(transform-painter
painter1
(make-vect 0.0 0.5)
(make-vect 1.0 0.5)
(make-vect 0.0 1.0)))
(paint-top
(transform-painter
painter2
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point)))
(lambda (frame)
(paint-top frame)
(paint-bottom frame)))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<make-frame>>
<<wave-segment>>
<<rogers>>
<<below>>
<<transform-painter>>
<<pict-frame>>
<<draw-line>>
((below wave wave) (make-frame (make-vect 0.0 0.0) (make-vect 1.0 0.0) (make-vect 0.0 1.0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./24869881-98d4-4a72-87e8-8b3c095f408c.png]]
#+begin_src scheme :exports both :results value :noweb-ref below-beside
(define (below painter1 painter2)
(rotate90 (beside (rotate270 painter1) (rotate270 painter2))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value :noweb-ref rotate90
(define (rotate90 painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results raw value
<<pict-vect>>
<<make-frame>>
<<pict-segment>>
<<segments-painter>>
<<wave-segment>>
<<transform-painter>>
<<pict-frame>>
<<draw-line>>
<<magick-vect>>
<<beside>>
<<below-beside>>
<<rotate270>>
<<rotate90>>
((below wave wave) (make-frame (make-vect 0.0 1.0) (make-vect 1.0 0.0) (make-vect 0.0 -1.0)))
#;((rotate270 rogers) (make-frame (make-vect 0.0 0.0) (make-vect 1.0 0.0) (make-vect 0.0 1.0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./13aec801-0171-4497-841c-5fa9c603c73b.png]]
Remark: imagemagick is a horrible piece of software, even though we have
nothing better.
*** DONE Exercise 2.52 modify square-limit
CLOSED: [2019-09-24 Tue 12:25]
To complete this exercise, we would first need to implement the square limit.
#+begin_src scheme :exports both :results value :noweb-ref square-limit
(define (square-limit painter n)
(let ((combine4 (square-of-four flip-horiz identity
rotate180 flip-vert)))
(combine4 (corner-split painter n))))
(define (square-of-four tl tr bl br)
(lambda (painter)
(let ((top (beside (tl painter) (tr painter)))
(bottom (beside (bl painter) (br painter))))
(below bottom top))))
(define (corner-split painter n)
(if (= n 0)
painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1))))
(let ((top-left (beside up up))
(bottom-right (below right right))
(corner (corner-split painter (- n 1))))
(beside (below painter top-left)
(below bottom-right corner))))))
(define (flip-vert painter)
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))
(define (identity x)
x)
#+end_src
Because the exercise requires modification of the existing functions (and I
don't want to advise them), I'd just splice all the source code into one block.
#+begin_src scheme :exports both :results raw value
(define (square-limit painter n)
(let ((combine4 (square-of-four flip-horiz identity
rotate180 flip-vert)))
(combine4 (corner-split painter n))))
(define (square-of-four tl tr bl br)
(lambda (painter)
(let ((top (beside (flip-horiz (tl painter)) (tr painter)))
(bottom (beside (bl painter) (br painter))))
(below bottom top))))
(define (corner-split painter n)
(if (= n 0)
painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1))))
(let ((top-left (beside up up))
(bottom-right (below right right))
(corner (corner-split painter (- n 1))))
(below (below painter top-left)
(below bottom-right corner))))))
(define (flip-vert painter)
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))
(define (identity x)
x)
(define (make-vect xcor ycor . o)
(append (list xcor) (list ycor) o))
(define (xcor-vect vect)
(car vect))
(define (ycor-vect vect)
(cadr vect))
(define (scale-vect scale vect)
(map (lambda (x) (* x scale)) vect))
(define (add-vect vec1 vec2)
(map (lambda (cor1 cor2) (+ cor1 cor2)) vec1 vec2))
(define (sub-vect vec1 vec2)
(map (lambda (cor1 cor2) (- cor1 cor2)) vec1 vec2))
(define (make-frame origin edge1 edge2)
(list origin edge1 edge2))
(define (origin-frame frame)
(car frame))
(define (edge1-frame frame)
(cadr frame))
(define (edge2-frame frame)
(caddr frame))
(define (make-segment start-vector end-vector)
(list start-vector end-vector))
(define (start-segment segment)
(car segment))
(define (end-segment segment)
(cadr segment))
(define (segments->painter segment-list)
(lambda (frame)
(for-each
(lambda (segment)
(draw-line
((frame-coord-map frame)
(start-segment segment))
((frame-coord-map frame)
(end-segment segment))))
segment-list)))
(define wave
(segments->painter
(list
(make-segment (make-vect .25 0) (make-vect .35 .5))
(make-segment (make-vect .35 .5) (make-vect .3 .6))
(make-segment (make-vect .3 .6) (make-vect .15 .4))
(make-segment (make-vect .15 .4) (make-vect 0 .65))
(make-segment (make-vect 0 .65) (make-vect 0 .85))
(make-segment (make-vect 0 .85) (make-vect .15 .6))
(make-segment (make-vect .15 .6) (make-vect .3 .65))
(make-segment (make-vect .3 .65) (make-vect .4 .65))
(make-segment (make-vect .4 .65) (make-vect .35 .85))
(make-segment (make-vect .35 .85) (make-vect .4 1))
(make-segment (make-vect .4 1) (make-vect .6 1))
(make-segment (make-vect .6 1) (make-vect .65 .85))
(make-segment (make-vect .65 .85) (make-vect .6 .65))
(make-segment (make-vect .6 .65) (make-vect .75 .65))
(make-segment (make-vect .75 .65) (make-vect 1 .35))
(make-segment (make-vect 1 .35) (make-vect 1 .15))
(make-segment (make-vect 1 .15) (make-vect .6 .45))
(make-segment (make-vect .6 .45) (make-vect .75 0))
(make-segment (make-vect .75 0) (make-vect .6 0))
(make-segment (make-vect .6 0) (make-vect .5 .3))
(make-segment (make-vect .5 .3) (make-vect .4 0))
(make-segment (make-vect .4 0) (make-vect .25 0))
(make-segment (make-vect 0.45 0.5) (make-vect 0.50 0.45))
(make-segment (make-vect 0.5 0.45) (make-vect 0.55 0.50))
)
)
)
(define (transform-painter painter origin corner1 corner2)
(lambda (frame)
(let ((m (frame-coord-map frame)))
(let ((new-origin (m origin)))
(painter (make-frame
new-origin
(sub-vect (m corner1) new-origin)
(sub-vect (m corner2) new-origin)))))))
(define (frame-coord-map frame)
(lambda (v)
(add-vect
(origin-frame frame)
(add-vect (scale-vect (xcor-vect v) (edge1-frame frame))
(scale-vect (ycor-vect v) (edge2-frame frame))))))
(define canvas-size
(make-parameter
200
(lambda (size)
(if (and (exact-integer? size) (<= 2 size 1000))
size
(error "invalid canvas size")))))
(define canvas-file-name
(make-parameter
(string-append "./" (substring (process->string "uuidgen") 0 36) ".png")
(lambda (name)
(if (string? name)
name
(error "invalid canvas file name")))))
(define (canvas-reset)
(system "rm" (canvas-file-name))
(system "convert" "xc:white"
"-scale" (string-append
(number->string (canvas-size))
"x"
(number->string (canvas-size)))
(canvas-file-name)))
(define (canvas-refresh)
(string-append "[[" (canvas-file-name) "]]"))
(canvas-reset)
(define (draw-line point1 point2)
(system "mogrify"
"-fill" "black"
"-draw" (string-append "line "
(number->string (* (canvas-size) (car point1)))
","
(number->string (* (canvas-size) (cadr point1)))
" "
(number->string (* (canvas-size) (car point2)))
","
(number->string (* (canvas-size) (cadr point2))))
(canvas-file-name))
(string-append "[[" (canvas-file-name) "]]"))
(define (beside painter1 painter2)
(let ((split-point (make-vect 0.5 0.0)))
(let ((paint-left
(transform-painter
painter1
(make-vect 0.0 0.0)
split-point
(make-vect 0.0 1.0)))
(paint-right
(transform-painter
painter2
split-point
(make-vect 1.0 0.0)
(make-vect 0.5 1.0))))
(lambda (frame)
(paint-left frame)
(paint-right frame)))))
(define (below painter1 painter2)
(rotate90 (beside (rotate270 painter1) (rotate270 painter2))))
(define (rotate270 painter)
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
(define (rotate90 painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))
(define (rotate180 painter)
(transform-painter painter
(make-vect 1.0 1.0)
(make-vect 0.0 1.0)
(make-vect 1.0 0.0)))
(define (split op1 op2)
(define (split-inner painter n)
(if (= n 0)
painter
(let ((smaller (split-inner painter (- n 1))))
(op2 painter (op1 smaller smaller)))))
(lambda (painter n)
(split-inner painter n)))
(define up-split (split beside below))
(define right-split (split below beside))
(define (flip-horiz painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
((square-limit wave 1) (make-frame (make-vect 0.0 1.0) (make-vect 1.0 0.0) (make-vect 0.0 -1.0)))
(canvas-refresh)
#+end_src
#+RESULTS:
[[./f2d16f96-de16-45f7-9f7f-1e31397e4d61.png]]
a. I added a check-mark at the segments->painter level.
b. Replaced the last ~beside~ with ~below~ at the lowest level.
c. Added a ~flip-horiz~ at the level of the ~square-of-four~.
*** Remark. Here the picture language chapter stops
The bitmap loader used by the ~rogers~ painter is not very reliable, so it
will not probably be able to replicate the full ~square-limit~. You can try
though.
*** DONE Exercise 2.53 quote introduction
CLOSED: [2019-09-24 Tue 12:36]
#+begin_src scheme :exports both :results output
(show #t (list 'a 'b 'c) "\n")
(show #t (list (list 'george)) "\n")
(show #t (cdr '((x1 x2) (y1 y2))) "\n")
(show #t (cadr '((x1 x2) (y1 y2))) "\n")
(show #t (pair? (car '(a short list))) "\n")
(show #t (memq 'red '((red shoes) (blue socks))) "\n")
(show #t (memq 'red '(red shoes blue socks)) "\n")
#+end_src
#+RESULTS:
: (a b c)
: ((george))
: ((y1 y2))
: (y1 y2)
: #f
: #f
: (red shoes blue socks)
*** DONE Exercise 2.54 equal? implementation
CLOSED: [2019-09-24 Tue 13:48]
#+begin_src scheme :exports both :results output :noweb-ref equal-implementation
(define (equal? o1 o2)
(cond ((eq? o1 o2) #t)
((and (list? o1) (list? o2)) (accumulate (lambda (x y) (and x y)) #t (map equal? o1 o2)))
((and (number? o1) (number? o2)) (= o1 o2))
(else #f)))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<accumulate>>
<<equal-implementation>>
(show #t (equal? '(this is a list) '(this is a list)) "\n")
(show #t (equal? '(this is a list) '(this (is a) list)) "\n")
#+end_src
#+RESULTS:
: #t
: #f
*** DONE Exercise 2.55 quote quote
CLOSED: [2019-09-24 Tue 13:48]
This is really easy.
~(car ''abracadabra)~ is in reality ~(car (quote (quote abracadabra)))~. The
second ~'~ gets automatically translated into a ~quote~ and is not interpreted.
*** DONE Exercise 2.56 differentiation-exponentiation
CLOSED: [2019-09-24 Tue 23:14]
#+begin_src scheme :exports both :results value :noweb-ref deriv-basic
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
((sum? exp) (make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp))))
(else
(error "unknown expression type: DERIV" exp))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref deriv-components
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref deriv-operations
(define (make-sum a1 a2 . rest)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2))
(+ a1 a2))
(else (list '+ a1 a2))))
(define (make-product m1 m2)
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2)) (* m1 m2))
(else (list '* m1 m2))))
(define (sum? x) (and (pair? x) (eq? (car x) '+)))
(define (addend s) (cadr s))
(define (augend s) (caddr s))
(define (product? x) (and (pair? x) (eq? (car x) '*)))
(define (multiplier p) (cadr p))
(define (multiplicand p) (caddr p))
#+end_src
#+begin_src scheme :exports both :results output
<<deriv-basic>>
<<deriv-components>>
<<deriv-operations>>
(show #t (deriv '(+ x 3) 'x) "\n")
(show #t (deriv '(* x y) 'x) "\n")
(show #t (deriv '(* (* x y) (+ x 3)) 'x) "\n")
#+end_src
#+RESULTS:
: 1
: y
: (+ (* x y) (* y (+ x 3)))
#+begin_src scheme :exports both :results value :noweb-ref deriv-and-exponent
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
((sum? exp) (make-sum (deriv (addend exp) var)
(deriv (augend exp) var)))
((product? exp)
(make-sum
(make-product
(multiplier exp)
(deriv
(multiplicand exp)
var))
(make-product
(deriv
(multiplier exp)
var)
(multiplicand exp))))
((exponentiation? exp)
(make-product (exponent exp)
(make-product
(make-exponentiation
(base exp)
(make-sum (exponent exp) -1))
(deriv (base exp) var))))
(else
(error "unknown expression type: DERIV" exp))))
(define (make-exponentiation base power)
(cond ((=number? power 0) 1)
((=number? power 1) base)
((and (number? base) (number? power))
(expt base power))
(else (list '** base power))))
(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))
(define (base s) (cadr s))
(define (exponent s) (caddr s))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<deriv-and-exponent>>
<<deriv-components>>
<<deriv-operations>>
(show #t (deriv '(** x 3) 'x) "\n")
(show #t (deriv '(** (* (* x y) (+ x 3)) 5) 'x) "\n")
#+end_src
#+RESULTS:
: (* 3 (** x 2))
: (* 5 (* (** (* (* x y) (+ x 3)) 4) (+ (* x y) (* y (+ x 3)))))
*** DONE Exercise 2.57 differentiate-three-sum
CLOSED: [2019-09-25 Wed 12:40]
#+begin_src scheme :exports both :results value :noweb-ref deriv-operations-three
(define (make-sum a1 a2 . rest)
(if (null? rest)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2))
(+ a1 a2))
(else (list '+ a1 a2)))
(make-sum a1 (apply make-sum a2 (car rest) (cdr rest)))))
(define (make-product m1 m2 . rest)
(if (null? rest)
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
((=number? m1 1) m2)
((=number? m2 1) m1)
((and (number? m1) (number? m2)) (* m1 m2))
(else (list '* m1 m2)))
(make-product m1 (apply make-product m2 (car rest) (cdr rest)))))
(define (sum? x) (and (pair? x) (eq? (car x) '+)))
(define (addend s) (cadr s))
(define (augend s)
(if (null? (cdddr s))
(caddr s)
(apply make-sum (cddr s))))
(define (product? x) (and (pair? x) (eq? (car x) '*)))
(define (multiplier p) (cadr p))
(define (multiplicand p)
(if (null? (cdddr p))
(caddr p)
(apply make-product (cddr p))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<deriv-and-exponent>>
<<deriv-components>>
<<deriv-operations-three>>
(show #t (deriv '(** x 3) 'x) "\n")
(show #t (deriv '(* x y z) 'y) "\n")
(show #t (deriv '(** (* (* x y z) (+ x 3)) 5) 'x) "\n")
#+end_src
#+RESULTS:
: (* 3 (** x 2))
: (* x z)
: (* 5 (* (** (* (* x y z) (+ x 3)) 4) (+ (* x y z) (* (* y z) (+ x 3)))))
*** DONE Exercise 2.58 infix-notation
CLOSED: [2019-09-25 Wed 15:21]
This solution is copied from http://community.schemewiki.org/?sicp-ex2.58
almost verbatim. Courtesy of sgm.
#+begin_src scheme :exports both :results output
(define (singleton? lst)
(= 1 (length lst)))
(define (sum? expr)
(eq? '+ (smallest-op expr)))
(define (product? expr)
(eq? '* (smallest-op expr)))
(define (smallest-op expr)
(accumulate (lambda (a b)
(if (operator? b)
(min-precedence a b)
a))
'maxop
expr))
(define *precedence-table*
'( (maxop . 10000)
(minop . -10000)
(+ . 0)
(* . 1) ))
(define (operator? x)
(define (loop op-pair)
(cond ((null? op-pair) #f)
((eq? x (caar op-pair)) #t)
(else (loop (cdr op-pair)))))
(loop *precedence-table*))
(define (min-precedence a b)
(if (precedence<? a b)
a
b))
(define (precedence<? a b)
(< (precedence a) (precedence b)))
(define (precedence op)
(define (loop op-pair)
(cond ((null? op-pair)
(error "Operator not defined -- PRECEDENCE:" op))
((eq? op (caar op-pair))
(cdar op-pair))
(else
(loop (cdr op-pair)))))
(loop *precedence-table*))
(define (augend expr)
(let ((a (cdr (memq '+ expr))))
(if (singleton? a)
(car a)
a)))
(define (prefix sym list)
(if (or (null? list) (eq? sym (car list)))
'()
(cons (car list) (prefix sym (cdr list)))))
(define (addend expr)
(let ((a (prefix '+ expr)))
(if (singleton? a)
(car a)
a)))
(define (make-sum a1 a2)
(cond ((=number? a1 0) a2)
((=number? a2 0) a1)
((and (number? a1) (number? a2))
(+ a1 a2))
(else (list a1 '+ a2))))
(define (multiplier expr)
(let ((m (prefix '* expr)))
(if (singleton? m)
(car m)
m)))
(define (multiplicand expr)
(let ((m (cdr (memq '* expr))))
(if (singleton? m)
(car m)
m)))
(define (make-product m1 m2)
(cond ((=number? m1 1) m2)
((=number? m2 1) m1)
((or (=number? m1 0) (=number? m2 0)) 0)
((and (number? m1) (number? m2))
(* m1 m2))
(else (list m1 '* m2))))
<<deriv-components>>
<<deriv-and-exponent>>
<<accumulate>>
(show #t (smallest-op '(t + k)) "\n")
(show #t (deriv '(x + 3) 'x) "\n")
(show #t (deriv '(x * y * (x + 3)) 'x) "\n")
(show #t (deriv '((x * y) * (x + 3)) 'x) "\n")
(show #t (deriv '(x * (y * (x + 3))) 'x) "\n")
#+end_src
#+RESULTS:
: +
: 1
: ((x * y) + (y * (x + 3)))
: ((x * y) + (y * (x + 3)))
: ((x * y) + (y * (x + 3)))
As a side-note: sometimes people say that copying other people's code
prevents us from learning. I disagree. Only copying sgm's code allowed me to
find a serious bug in my implementation of "accumulate".
*** DONE Exercise 2.59 union-set
CLOSED: [2019-09-25 Wed 22:00]
#+begin_src scheme :exports both :results value :noweb-ref element-of-set
(define (element-of-set? x set)
(cond ((null? set) false)
((equal? x (car set)) true)
(else (element-of-set? x (cdr set)))))
#+end_src
#+begin_src scheme :exports both :results value :noweb-ref union-set
<<element-of-set>>
(define (union-set set1 set2)
(append set1 (filter (lambda (x) (not (element-of-set? x set1))) set2)))
(define true #t)
(define false #f)
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<union-set>>
<<filter>>
(show #t " " (union-set '(1 2 3 4) '(3 4 5 6)))
#+end_src
#+RESULTS:
: (1 2 3 4 5 6)
*** DONE Exercise 2.60 duplicate-set
CLOSED: [2019-09-25 Wed 22:17]
#+begin_src scheme :exports both :results output
(define (element-of-set? x set)
(cond ((null? set) false)
((equal? x (car set)) true)
(else (element-of-set? x (cdr set)))))
#;(The element-of-set? predicate stays the same)
(define (adjoin x set)
(cons x set))
(define (intersection-set set1 set2)
(cond ((or (null? set1) (null? set2)) '())
((element-of-set? (car set1) set2)
(cons (car set1) (intersection-set (cdr set1) set2)))
(else (intersection-set (cdr set1) set2))))
#;(The intersection-set stays the same, moreover, every time it is called,
the duplicates are removed.)
(define (union-set set1 set2)
(append set1 set2))
(define true #t)
(define false #f)
(show #t " " (element-of-set? 2 '(1 2 3)) "\n")
(show #t " " (adjoin 2 '(1 2)) "\n")
(show #t " " (intersection-set '(1 2 3 4 5) '(2 2 2 2 2)) "\n")
(show #t " " (union-set '(1 2 3 4 5) '(1 2 2 2 2 3 4)) "\n")
#+end_src
#+RESULTS:
: #t
: (2 1 2)
: (2)
: (1 2 3 4 5 1 2 2 2 2 3 4)
The efficiency of ~element-of-set?~ is still O(n), although on average sets
would be larger. ~adjoin~ takes O(1), instead of O(n). ~intersection-set~
takes the same \(O(n^2)\), although again, the sets may be larger. ~union-set~
takes \(O(1)\) instead of \(O(n^2)\), which sounds even too good to be true.
Well, if the amount of calls to ~intersection-set~ is big enough, I think
that this representation would be good enough, or even faster.
*** DONE Exercise 2.61 sets as ordered lists
CLOSED: [2019-09-26 Thu 21:44]
#+begin_src scheme :exports both :results value
(define (adjoin-set x set)
(cond ((null? set) x)
((= x (car set)) set)
((< x (car set)) (cons x set))
(else (cons (car set) (adjoin-set x (cdr set))))))
(adjoin-set 3 '(1 2 4 5))
#+end_src
#+RESULTS:
| 1 | 2 | 3 | 4 | 5 |
*** DONE Exercise 2.62 ordered-union-set (ordered list)
CLOSED: [2019-09-26 Thu 21:38]
#+begin_src scheme :exports both :results raw value :noweb-ref ordered-set
(define (element-of-set? x set)
(cond ((null? set) false)
((= x (car set)) true)
((< x (car set)) false)
(else (element-of-set? x (cdr set)))))
(define (intersection-set set1 set2)
(if (or (null? set1) (null? set2))
'()
(let ((x1 (car set1)) (x2 (car set2)))
(cond ((= x1 x2)
(cons x1
(intersection-set (cdr set1)
(cdr set2))))
((< x1 x2)
(intersection-set (cdr set1) set2))
((< x2 x1)
(intersection-set set1 (cdr set2)))))))
(define (remove-duplicates-set set)
(define (r-d-iter set accumulator)
(cond ((null? set) accumulator)
((null? accumulator) (r-d-iter (cdr set) (cons (car set) accumulator)))
((= (car set) (car accumulator)) (r-d-iter (cdr set) accumulator))
(else (r-d-iter (cdr set) (cons (car set) accumulator)))))
(reverse (r-d-iter set '())))
(define (union-set set1 set2)
(define (union-iter set1 set2 result)
(cond ((null? set1) (append (reverse result) set2))
((null? set2) (append (reverse result) set1))
((<= (car set1) (car set2)) (union-iter (cdr set1) set2 (cons (car set1) result)))
((<= (car set2) (car set1)) (union-iter set1 (cdr set2) (cons (car set2) result)))))
(remove-duplicates-set (union-iter set1 set2 '())))
#+end_src
#+begin_src scheme :exports both :results raw value
<<ordered-set>>
(cons (union-set '(1 3 10) '(1 2 4 5))
(intersection-set '(1 3 10) '(1 2 4 5)))
#+end_src
#+RESULTS:
| (1 2 3 4 5 10) | 1 |
*** TODO Figure 2.16 Various binary trees that represent the set {1,3,5,7,9,11}.
*** DONE Exercise 2.63 tree->list (binary search tree)
CLOSED: [2019-09-26 Thu 23:37]
Let me copy the two code pieces here, I will need them later.
#+begin_src scheme :exports both :results raw value
(define (tree->list-1 tree)
(if (null? tree)
'()
(append (tree->list-1 (left-branch tree))
(cons (entry tree)
(tree->list-1 (right-branch tree))))))
#+end_src
#+begin_src scheme :exports both :results raw value :noweb-ref tree-list
(define (tree->list-2 tree)
(define (copy-to-list tree result-list)
(if (null? tree)
result-list
(copy-to-list (left-branch tree)
(cons (entry tree)
(copy-to-list (right-branch tree)
result-list)))))
(copy-to-list tree '()))
#+end_src
a. The difference between the two functions is the order of traversing the
tree. The function ~tree->list-1~ traverses the tree from the left, whereas
the function ~tree->list-2~ does it from the right. The outcome would be the
same, and for the trees on the figure 2.16 would give the same answer:
~'(1 2 3 4 5 6 7 8 9 10 11)~.
b. The difference in performance would be significant. The function 2 uses
~cons~, which uses O(1) operations, so the opppprder of growth is ~O(n)~ in
total. ~append~ in the function 1 takes O(n) operations in the worst case,
which would make the total complexity \(O(n^2)\).p
*** DONE Exercise 2.64 balanced-tree
CLOSED: [2019-09-29 Sun 17:22]
Firstly, I want to see what it is exactly that the function outputs.
#+begin_src scheme :exports both :results output :noweb-ref list-tree
(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define (make-tree entry left right)
(list entry left right))
(define (list->tree elements)
(car (partial-tree elements (length elements))))
(define (partial-tree elts n)
(if (= n 0)
(cons '() elts)
(let ((left-size (quotient (- n 1) 2)))
(let ((left-result (partial-tree elts left-size)))
(let ((left-tree (car left-result))
(non-left-elts (cdr left-result))
(right-size (- n (+ left-size 1))))
(let ((this-entry (car non-left-elts))
(right-result (partial-tree (cdr non-left-elts)
right-size)))
(let ((right-tree (car right-result))
(remaining-elts (cdr right-result)))
(cons (make-tree this-entry left-tree right-tree)
remaining-elts))))))))
#+end_src
#+begin_src scheme :exports both :results output
<<list-tree>>
(show #t " " (pretty (list->tree '(1 3 5 7 9 11))))
#+end_src
#+RESULTS:
: (5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))
Since I already got the result, I will just draw it.
#+begin_src plantuml :exports both :file figure-1-1-dot.png
@startdot
graph g {
node [shape=plaintext];
A1 [label="5"];
B1 [label="1"];
B3 [label="9"];
C1 [label="7"];
C2 [label="11"];
C0 [label="'()"];
C3 [label="3"]
// edges
A1 -- B1;
A1 -- B3;
B1 -- C0;
B1 -- C3;
B3 -- C1;
B3 -- C2;
{ rank=same; A1 }
{ rank=same; B1 B3 }
{ rank=same; C1 C2 C3 }
}
@enddot
#+end_src
#+RESULTS:
[[file:figure-1-1-dot.png]]
a. How exactly did this tree appear? The algorithm given by Abelson
and Sussman is actually quite straightforward: divide a list into two
roughly equal parts, separated by the middle element, make the element into a
node, and attach the right and the left sub-lists of the list as its left and
right children.
b. The function ~partial-tree~ doesn't contain any full passes through the list,
works in constant time, and is evaluated once per node. Therefore the
complexity is O(1).
*** DONE Exercise 2.65 tree-union-set
CLOSED: [2019-10-09 Wed 12:13]
Well, I am required to make a union-set and an intersection-set.
So far, we have the operations tree->list, which works in O(n); list->tree,
which works as O(n) too, and union-set and intersection-set for list-based
set implementations, which both work in O(n). The solution then seems
straightforward.
#+begin_src scheme :exports both :results raw value :noweb-ref set-tree
(define (union-set-tree set1 set2)
(list->tree (union-set (tree->list-2 set1) (tree->list-2 set2))))
(define (intersection-set-tree set1 set2)
(list->tree (intersection-set (tree->list-2 set1) (tree->list-2 set2))))
#+end_src
#+begin_src scheme :exports both :results output
<<list-tree>>
<<tree-list>>
<<ordered-set>>
<<set-tree>>
(show #t (union-set-tree (list->tree '(1 3 10)) (list->tree '(1 2 4 5))) "\n")
(show #t (intersection-set-tree (list->tree '(1 3 10)) (list->tree '(1 2 4 5))) "\n")
#+end_src
#+RESULTS:
: (3 (1 () (2 () ())) (5 (4 () ()) (10 () ())))
: (1 () ())
*** DONE Exercise 2.66 tree-lookup
CLOSED: [2019-10-09 Wed 13:03]
The excellent property of the ~list->tree~ procedure is that is asserts that
the list given as an argument is already sorted in some way appropriate for
this represented data. Therefore we can use the function verbatim.
#+begin_src scheme :exports both :results raw value :noweb-ref tree-lookup
(define-record-type dict-entry-type
(dict-entry x y)
dict-entry?
(x entry-key)
(y entry-value))
(define (tree-lookup key dictionary)
(cond ((null? dictionary) #f)
((= (entry-key (entry dictionary)) key) (entry dictionary))
((<= key (entry-key (entry dictionary))) (tree-lookup key (left-branch dictionary)))
((>= key (entry-key (entry dictionary))) (tree-lookup key (right-branch dictionary)))
(else (error "Corrupt dictionary"))))
#+end_src
#+begin_src scheme :exports both :results output
<<list-tree>>
<<tree-lookup>>
(show #t " " (list->tree (list (dict-entry 1 'John) (dict-entry 2 'James) (dict-entry 3 'Baloo) (dict-entry 4 'Carry))) "\n")
(show #t " " (tree-lookup 3 (list->tree (list (dict-entry 1 'John) (dict-entry 2 'James) (dict-entry 3 'Baloo) (dict-entry 4 'Carry)))) "\n")
#+end_src
#+RESULTS:
: ({dict-entry-type #63 2 James} ({dict-entry-type #63 1 John} () ()) ({dict-entry-type #63 3 Baloo} () ({dict-entry-type #63 4 Carry} () ())))
: {dict-entry-type #63 3 Baloo}
This exercise used the r7rs ~define-record-type~. It is not strictly
necessary here, but I used it do add more "encapsulation" to the data base.
*** DONE Exercise 2.67 Huffman decode a simple message
CLOSED: [2019-10-09 Wed 20:20]
#+begin_src scheme :exports both :results value :noweb-ref huffman-base
(define (make-leaf symbol weight)
(list 'leaf symbol weight))
(define (leaf? object)
(eq? (car object) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))
(define (make-code-tree left right)
(list left
right
(append (symbols left) (symbols right))
(+ (weight left) (weight right))))
(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))
(define (symbols tree)
(if (leaf? tree)
(list (symbol-leaf tree))
(caddr tree)))
(define (weight tree)
(if (leaf? tree)
(weight-leaf tree)
(cadddr tree)))
(define (decode bits tree)
(define (decode-1 bits current-branch)
(if (null? bits)
'()
(let ((next-branch
(choose-branch (car bits) current-branch)))
(if (leaf? next-branch)
(cons (symbol-leaf next-branch)
(decode-1 (cdr bits) tree))
(decode-1 (cdr bits) next-branch)))))
(decode-1 bits tree))
(define (choose-branch bit branch)
(cond ((= bit 0) (left-branch branch))
((= bit 1) (right-branch branch))
(else (error "bad bit -- CHOOSE-BRANCH" bit))))
(define (adjoin-set x set)
(cond ((null? set) (list x))
((< (weight x) (weight (car set))) (cons x set))
(else (cons (car set)
(adjoin-set x (cdr set))))))
(define (make-leaf-set pairs)
(if (null? pairs)
'()
(let ((pair (car pairs)))
(adjoin-set (make-leaf (car pair) #;(symbol)
(cadr pair)) #;(frequency)
(make-leaf-set (cdr pairs))))))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results value :noweb-ref huffman-sample-tree
(define sample-tree
(make-code-tree (make-leaf 'A 4)
(make-code-tree
(make-leaf 'B 2)
(make-code-tree (make-leaf 'D 1)
(make-leaf 'C 1)))))
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
#+end_src
#+begin_src scheme :exports both :results value
<<huffman-base>>
<<huffman-sample-tree>>
(decode sample-message sample-tree)
#+end_src
#+RESULTS:
| A | D | A | B | B | C | A |
This is a rather easy exercise, who's main goal is to make us test that the
chapter code is actually working.
*** DONE Exercise 2.68 Huffman encode a simple message
CLOSED: [2019-10-09 Wed 20:53]
#+begin_src scheme :exports both :results raw value :noweb-ref huffman-encode
(define (encode message tree)
(if (null? message)
'()
(append (encode-symbol (car message) tree)
(encode (cdr message) tree))))
(define (encode-symbol symbol tree)
(cond ((not (element-of-set? symbol (symbols tree)))
(error "Error: Huffman tree does not support encoding symbol" symbol))
((leaf? tree) '())
((element-of-set? symbol (symbols (left-branch tree))) (cons 0 (encode-symbol symbol (left-branch tree))))
((element-of-set? symbol (symbols (right-branch tree))) (cons 1 (encode-symbol symbol (right-branch tree))))))
#+end_src
#+begin_src scheme :exports both :results value
(define true #t)
(define false #f)
<<huffman-base>>
<<huffman-encode>>
<<element-of-set>>
<<huffman-sample-tree>>
(encode (list 'A 'D 'A 'B 'B 'C 'A) sample-tree)
#+end_src
#+RESULTS:
| 0 | 1 | 1 | 0 | 0 | 1 | 0 | 1 | 0 | 1 | 1 | 1 | 0 |
My implementation of encode-symbol is not iterative, but for educational
purposes it should be enough.
*** DONE Exercise 2.69 Generate Huffman tree
CLOSED: [2019-10-10 Thu 11:28]
I spent an hour trying to debug why my code doesn't work, and it turns out
that although Abelson and Sussman use the word "pair" for the (symbol,
weight) tuples, they are actually lists.
#+begin_src scheme :exports both :results value :noweb-ref huffman-generate-tree
(define (generate-huffman-tree pairs)
(successive-merge (make-leaf-set pairs)))
#;(leaf-set is sorted by weight)
(define (successive-merge leaf-set)
(cond ((null? leaf-set) '())
((null? (cdr leaf-set)) (car leaf-set))
(else (successive-merge (adjoin-set
(make-code-tree
(car leaf-set)
(cadr leaf-set))
(cddr leaf-set))))))
#+end_src
#+begin_src scheme :exports both :results output
(define true #t)
(define false #f)
<<huffman-base>>
<<huffman-encode>>
<<element-of-set>>
<<huffman-sample-tree>>
<<huffman-generate-tree>>
(define pairs (list (list 'A 4) (list 'B 2) (list 'C 1) (list 'D 1)))
n#;(generate-huffman-tree (list (cons 'A 4) (cons 'B 2) (cons 'C 1) (cons 'D 1)))
#n;(make-leaf-set pairs)
(show #t "Sample-tree:" (pretty (generate-huffman-tree pairs)) "\n")
(show #t "Our tree :" (pretty sample-tree) "\n")
#+end_src
#+RESULTS:
#+begin_example
Sample-tree:((leaf A 4)
((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4)
(A B D C)
8)
Our tree :((leaf A 4)
((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4)
(A B D C)
8)
#+end_example
*** DONE Exercise 2.70 Generate a tree and encode a song
CLOSED: [2019-10-10 Thu 13:11]
This exercise has a small caveat. The scheme used to create examples for SICP
back when it was written, had a case-independent reader, therefore the text
of the book ignores the case difference between, say, 'Sha, 'SHA, and 'sha.
Luckily, in the given song, there are no instances of the same symbol
consisting of letters of different cases, so to make the code work, the only
thing needed is to correct the case in the dictionary.
Let's generate a tree first:
#+begin_src scheme :exports both :results output
(define true #t)
(define false #f)
<<huffman-base>>
<<huffman-encode>>
<<element-of-set>>
<<huffman-sample-tree>>
<<huffman-generate-tree>>
(define pairs
(list
(list 'a 4) (list 'Get 2) (list 'Sha 1) (list 'Wah 1)
(list 'boom 1) (list 'job 2) (list 'na 16) (list 'yip 9)))
(define coding-tree (generate-huffman-tree pairs))
(show #t "Tree:" (pretty coding-tree) "\n")
(define song '(
Get a job
Sha na na na na na na na na
Get a job
Sha na na na na na na na na
Wah yip yip yip yip yip yip yip yip yip
Sha boom
))
(define encoded-song (encode song coding-tree))
(show #t encoded-song "\n")
(show #t (decode encoded-song coding-tree) "\n")
#+end_src
#+RESULTS:
#+begin_example
Tree:((leaf na 16)
((leaf yip 9)
(((leaf Get 2) ((leaf boom 1) (leaf Wah 1) (boom Wah) 2)
(Get boom Wah)
4)
(((leaf Sha 1) (leaf job 2) (Sha job) 3) (leaf a 4) (Sha job a) 7)
(Get boom Wah Sha job a)
11)
(yip Get boom Wah Sha job a)
20)
(na yip Get boom Wah Sha job a)
36)
(1 1 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0 1 1 0 1 0)
(Get a job Sha na na na na na na na na Get a job Sha na na na na na na na na Wah yip yip yip yip yip yip yip yip yip Sha boom)
#+end_example
*** DONE Exercise 2.71 Huffman tree for frequencies 5 and 10
CLOSED: [2019-10-10 Thu 19:22]
#+begin_src scheme :exports both :results output
(define true #t)
(define false #f)
<<huffman-base>>
<<huffman-encode>>
<<element-of-set>>
<<huffman-sample-tree>>
<<huffman-generate-tree>>
(define pairs
(list
(list 'a 1) (list 'b 2) (list 'c 4) (list 'd 8)))
(define coding-tree (generate-huffman-tree pairs))
(show #t "Tree:" (pretty coding-tree) "\n")
#+end_src
#+RESULTS:
: Tree:((((leaf a 1) (leaf b 2) (a b) 3) (leaf c 4) (a b c) 7) (leaf d 8)
: (a b c d)
: 15)
:
#+begin_src plantuml :exports both :file Exercise-2.71.png
@startmindmap
skinparam monochrome true
+_ ((((leaf a 1)\n (leaf b 2) (a b) 3)\n (leaf c 4) (a b c) 7)\n (leaf d 8) (a b c d) 15)
++_ (leaf d 8)
++_ (((leaf a 1)\n (leaf b 2) (a b) 3) \n(leaf c 4) (a b c) 7)
+++_ (leaf c 4)
+++_ ((leaf a 1) \n(leaf b 2) (a b) 3)
++++_ (leaf b 2)
++++_ (leaf a 1)
@endmindmap
#+end_src
#+RESULTS:
[[file:Exercise-2.71.png]]
#+begin_src scheme :exports both :results output
(define true #t)
(define false #f)
<<huffman-base>>
<<huffman-encode>>
<<element-of-set>>
<<huffman-sample-tree>>
<<huffman-generate-tree>>
(define pairs
(list
(list 'a 1) (list 'b 2) (list 'c 4) (list 'd 8)
(list 'e 16) (list 'f 32) (list 'g 64) (list 'h 128) (list 'j 256)))
(define coding-tree (generate-huffman-tree pairs))
(show #t "Tree:" (pretty coding-tree) "\n")
#+end_src
#+RESULTS:
#+begin_example
Tree:(((((((((leaf a 1) (leaf b 2) (a b) 3) (leaf c 4) (a b c) 7) (leaf d 8)
(a b c d)
15)
(leaf e 16)
(a b c d e)
31) (leaf f 32)
(a b c d e f)
63) (leaf g 64)
(a b c d e f g)
127) (leaf h 128)
(a b c d e f g h)
255) (leaf j 256)
(a b c d e f g h j)
511)
#+end_example
#+begin_src plantuml :exports both :file Exercise-2.71.png
@startmindmap
skinparam monochrome true
+_ (a b c d e f g h j) 511
++_ (leaf j 256)
++_ (a b c d e f g h) 255
+++_ (leaf h 128)
+++_ (a b c d e f g) 127
++++_ (a b c d e f) 63
++++_ (leaf g 64)
+++++_ (a b c d e) 31
+++++_ (leaf f 32)
++++++_ (a b c d) 15
++++++_ (leaf e 16)
+++++++_ (a b c) 7
+++++++_ (leaf d 8)
++++++++_ (a b) 3
++++++++_ (leaf c 4)
+++++++++_ (leaf a 1)
+++++++++_ (leaf b 2)
@endmindmap
#+end_src
#+RESULTS:
[[file:Exercise-2.71.png]]
We can clearly see that if the probabilities decrease exponentially, the
length of the tree is n. So to encode the most frequent symbol we would need
just one bit, and the least frequent would require 8 bit.
*** DONE Exercise 2.72 Huffman order of growth
CLOSED: [2019-10-10 Thu 20:34]
If we consider Exercise 2.71, we'll see that the amount of elements mentioned
at every level of k the tree is n-k. Therefore, if we want to encode the most
frequent element, we would need to perform O(n-k) operations on every level
of the tree. Since we would need to eventually reach the bottom-most level,
the total number of operations would be \(\sum_1^n (n-k) = O(n^2)\).
The most frequent element is always on
level 1, so to encode it we would need O(1) operations, and we don't even
need to go through the list.
*** Remark Complex packages
The following several exercises can only be considered "functional"
loosely.
In this subsection I will copy the source of the two complex packages given
as examples.
#+begin_src scheme :exports both :results output
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
#+end_src
#+RESULTS:
*** Remark Reference to the put and get functions
~put~ and ~get~ functions are defined later, however, you can use them if
tangling in the block called: <<put-and-get>>. It is a stateful block, so be
sure to include it first.
*** DONE Exercise 2.73 data-driven-deriv
CLOSED: [2019-10-11 Fri 11:05]
#+begin_src scheme :exports both :results output :noweb-ref data-driven-deriv
(define (deriv exp var)
(cond ((number? exp) 0)
((variable? exp) (if (same-variable? exp var) 1 0))
(else ((get 'deriv (operator exp)) (operands exp)
var))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
#+end_src
**** DONE a
CLOSED: [2019-10-11 Fri 10:29]
We replaced the fixed ~product?~ and ~sum?~ predicate functions with the
ones dispatched on the table. Both of these predicates require their tested
variable to be a ~cons~. This is why ~number?~ and ~variable?~ cannot be
replaced with a dispatched version − they are not a pair.
**** DONE b
Surprise-surprise, the prototype of the two ~deriv~ functions we are
supposed to write is incompatible with the derivatives we had to write in the Exercise-2.56.
#+begin_src scheme :exports both :results output :noweb-ref data-driven-sum-mul
(define (differentiate-sum operands var)
(make-sum (deriv (car operands) var)
(deriv (cadr operands) var)))
(define (differentiate-multiplication operands var)
(make-sum
(make-product (car operands)
(deriv (cadr operands) var))
(make-product (deriv (car operands) var)
(cadr operands))))
(put 'deriv '+ differentiate-sum)
(put 'deriv '* differentiate-multiplication)
#+end_src
#+begin_src scheme :exports both :results output
<<put-and-get>>
<<deriv-components>>
<<deriv-operations>>
<<data-driven-deriv>>
<<data-driven-sum-mul>>
(show #t "Test:" (deriv '(+ a (* b a)) 'a) "\n")
#+end_src
#+RESULTS:
: Test:(+ 1 b)
**** DONE c
CLOSED: [2019-10-11 Fri 11:03]
#+begin_src scheme :exports both :results output :noweb-ref data-driven-exponentiation
(define (make-exponentiation base power)
(cond ((=number? power 0) 1)
((=number? power 1) base)
((and (number? base) (number? power))
(expt base power))
(else (list '** base power))))
(define (differentiate-exponentiation exp var)
(make-product (cadr exp)
(make-product
(make-exponentiation
(car exp)
(make-sum (cadr exp) -1))
(deriv (car exp) var))))
(put 'deriv '** differentiate-exponentiation)
#+end_src
#+begin_src scheme :exports both :results output
(define false #f)
<<put-and-get>>
<<deriv-components>>
<<deriv-operations>>
<<data-driven-deriv>>
<<data-driven-sum-mul>>
<<data-driven-exponentiation>>
(show #t "Test:" (deriv '(+ a (* b (** a c))) 'a) "\n")
#;(show #t "Test:" (deriv '(** a b) 'a) "\n")
#+end_src
#+RESULTS:
: Test:(+ 1 (* b (* c (** a (+ c -1)))))
**** DONE d
CLOSED: [2019-10-11 Fri 11:05]
The only change needed is to change the order of parameters in ~put~ just as
it is changed in ~get~. The rest should be absolutely the same.
*** DONE Exercise 2.74 Insatiable Enterprises
CLOSED: [2019-10-11 Fri 20:56]
This task is a bit weird and too vaguely formulated. For the start, let's
assume that the company only has two divisions.
#+begin_src scheme :exports both :results output :noweb-ref insatiable-enterprises-data
(define division-1-set-of-records
(cons 'division-1 (list (list 'Jack (cons 'salary 100) (cons 'address #f)) (list 'Jill (cons 'salary 200) '(address #t)))))
(define (division-1-get-record record-set key)
(define (crawler records key)
(cond ((null? records) '())
((eq? key (caar records)) (car records))
(else (crawler (cdr records) key))))
(crawler (cdr record-set) key))
(define (division-1-get-salary record)
(cdr (list-ref record 1)))
(define division-2-set-of-records
(cons 'division-2 (list (list 'placeholder 'WangYi 'salary 100 'address 'neverland) (list 'placeholder 'ZhangEr 'salary 200 'address 'this-world))))
(define (division-2-get-record record-set key)
(define (crawler records key)
(cond ((null? records) '())
((eq? key (list-ref (car records) 1)) (car records))
(else (crawler (cdr records) key))))
(crawler (cdr record-set) key))
(define (division-2-get-salary record)
(list-ref record 3))
(put 'get-record 'division-1 division-1-get-record)
(put 'get-record 'division-2 division-2-get-record)
(put 'get-salary 'division-1 division-1-get-salary)
(put 'get-salary 'division-2 division-2-get-salary)
#+end_src
#+begin_src scheme :exports both :results output
<<put-and-get>>
<<insatiable-enterprises-data>>
(show #t "Division-1: " (division-1-get-record division-1-set-of-records 'Jack) "\n")
(show #t "Division-2: " (division-2-get-record division-2-set-of-records 'WangYi) "\n")
(show #t "Division-2: " (division-2-get-record division-2-set-of-records 'ZhangEr) "\n")
(show #t "Salary-1: " (division-1-get-salary (division-1-get-record division-1-set-of-records 'Jill)) "\n")
(show #t "Salary-2: " (division-2-get-salary (division-2-get-record division-2-set-of-records 'WangYi)) "\n")
(show #t "Division-1: " ((get 'get-record 'division-1) division-1-set-of-records 'Jack) "\n")
(show #t "Division-2: " ((get 'get-record 'division-2) division-2-set-of-records 'WangYi) "\n")
(show #t "Division-1: " ((get 'get-salary 'division-1) (division-1-get-record division-1-set-of-records 'Jill)) "\n")
(show #t "Division-2: " ((get 'get-salary 'division-2) (division-2-get-record division-2-set-of-records 'WangYi)) "\n")
#+end_src
#+RESULTS:
: Division-1: (Jack (salary . 100) (address . #f))
: Division-2: (placeholder WangYi salary 100 address neverland)
: Division-2: (placeholder ZhangEr salary 200 address this-world)
: Salary-1: 200
: Salary-2: 100
: Division-1: (Jack (salary . 100) (address . #f))
: Division-2: (placeholder WangYi salary 100 address neverland)
: Division-1: 200
: Division-2: 100
**** DONE a
CLOSED: [2019-10-11 Fri 18:39]
The key thing in our implementation of the two datasets is that we have a
department tag at the beginning. This lets us dispatch on the origin of the
data.
#+begin_src scheme :exports both :results output :noweb-ref insatiable-a
(define (get-record dataset key)
((get 'get-record (car dataset)) dataset key))
#+end_src
#+begin_src scheme :exports both :results output
<<put-and-get>>
<<insatiable-enterprises-data>>
<<insatiable-a>>
(show #t (get-record division-1-set-of-records 'Jill) "\n")
(show #t (get-record division-2-set-of-records 'ZhangEr) "\n")
#+end_src
#+RESULTS:
: (Jill (salary 200) (address #t))
: (placeholder ZhangEr salary 200 address this-world)
**** DONE b
CLOSED: [2019-10-11 Fri 20:22]
#+begin_src scheme :exports both :results output :noweb-ref insatiable-b
(define (get-salary records key)
(let ((record (get-record records key)))
(if record
((get 'get-salary (car records)) record)
#f)))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<put-and-get>>
<<insatiable-enterprises-data>>
<<insatiable-a>>
<<insatiable-b>>
(show #t "Salary wrong : " (get-salary division-2-set-of-records 'Jill) "\n")
(show #t "Salary correct: " (get-salary division-1-set-of-records 'Jill) "\n")
#+end_src
#+RESULTS:
: Salary wrong : #f
: Salary correct: 200
Because all the dispatch is organized on a tag in the file records, there is
no specific requirements to the record structure.
**** DONE c
CLOSED: [2019-10-11 Fri 20:54]
#+begin_src scheme :exports both :results output :noweb-ref insatiable-find-employee-record
<<accumulate>>
(define (find-employee-record key . record-files)
(car (accumulate
append
'()
(map (lambda (x)
(list (get-record x key))) record-files))))
#+end_src
#+begin_src scheme :exports both :results output
<<put-and-get>>
<<insatiable-enterprises-data>>
<<insatiable-a>>
<<insatiable-b>>
<<insatiable-find-employee-record>>
(show #t "Result: " (find-employee-record 'Jill division-1-set-of-records division-2-set-of-records) "\n")
#+end_src
#+RESULTS:
: Result: (Jill (salary . 200) (address #t))
**** DONE d
CLOSED: [2019-10-11 Fri 20:56]
The new company would need to prepend their files with ~('companyname)~, and
their functions ~get-record~ and ~get-salary~ need to be registered with the
new the function table.
*** DONE Exercise 2.75 make-from-mag-ang message passing
CLOSED: [2019-10-11 Fri 21:24]
#+begin_src scheme :exports both :results output :noweb-ref message-mag-angle
(define (make-from-mag-angle mag angle)
(define (dispatch op)
(cond ((eq? op 'real-part) (* mag (cos angle)))
((eq? op 'imag-part) (* mag (sin angle)))
((eq? op 'magnitude) mag)
((eq? op 'angle) angle)
(else
(error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
dispatch)
#+end_src
#+begin_src scheme :exports both :results output
<<message-mag-angle>>
(show #t "Magnitude: " ((make-from-mag-angle 1 1) 'magnitude) "\n")
(show #t "Angle : " ((make-from-mag-angle 1 1) 'angle ) "\n")
(show #t "Real-part: " ((make-from-mag-angle 1 1) 'real-part) "\n")
(show #t "Imag-part: " ((make-from-mag-angle 1 1) 'imag-part) "\n")
#+end_src
#+RESULTS:
: Magnitude: 1
: Angle : 1
: Real-part: 0.5403023058681398
: Imag-part: 0.8414709848078965
*** DONE Exercise 2.76 types or functions?
CLOSED: [2019-10-11 Fri 21:29]
Dispatching on the types seems more appropriate for the case when there are
more operations that types. This way there is no need to adjust types when
new operations are created. Just add new operations to the table.
The message-passing style seems more appropriate for the situations when
new operations are relatively rare, but new types appear often. Existing
operations would work with the new types, if the types satisfy some contract.
*** Remark Three arithmetic packages
#+begin_src scheme :exports both :results output :noweb-ref generic-arithmetic-packages
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output :noweb-ref apply-generic
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
#+end_src
*** DONE Exercise 2.77 generic-algebra-magnitude
CLOSED: [2019-10-12 Sat 16:01]
Yeah, great, Dr. Abelson. You're casually referring to the ~apply-generic~,
not really specifying which one to use. Also, I never had to use the
~type-tag~ and ~contents~, which suddenly appear here.
#+begin_src scheme :exports both :results output :noweb-ref alyssa-complex-suggestion
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
#+end_src
#+begin_src scheme :exports both :results output
(define false #f)
(define true #t)
<<put-and-get>>
<<apply-generic>>
<<generic-arithmetic-packages>>
(install-rectangular-package)
(install-complex-package)
<<alyssa-complex-suggestion>>
(show #t "Louis's result: " (magnitude (make-complex-from-real-imag 3 4)) "\n")
#+end_src
#+RESULTS:
: Louis's result: 5
This example illustrates what can, perhaps, be called "double
dispatch". Indeed, our "complex" implementation still keeps the 'rectangular
and 'polar tags, so the only thing that the complex ~magnitude~ should do is
to call (through the dispatch table) the old function ~magnitude~, which
will, by itself, dispatch on the old tags. ~apply-generic~ is called twice,
first for a 'complex tag, an later for the 'polar tag.
Remark: this "easy" exercise took more than 4 hours to debug and consists of
227 lines of code.
*** DONE Exercise 2.78 Ordinary numbers for scheme
CLOSED: [2019-10-12 Sat 21:06]
#+begin_src scheme :exports both :results output :noweb-ref simplified-scheme-number
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (attach-tag type-tag contents)
(if (eq? type-tag 'scheme-number)
contents
(cons type-tag contents)))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((number? datum) 'scheme-number)
(else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((number? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
#+end_src
#+begin_src scheme :exports both :results output
<<put-and-get>>
<<simplified-scheme-number>>
(install-scheme-number-package)
(show #t "Adding: (+ 1 2) : " (add (make-scheme-number 1) (make-scheme-number 2)) "\n")
#+end_src
#+RESULTS:
: Adding: (+ 1 2) : 3
The task is to "Modify the definitions of `type-tag', `contents', and
`attach-tag'", therefore (as this doesn't seem really useful), I am only
copying those functions for modification in this particular exercise.
*** DONE Exercise 2.79 generic-equality
CLOSED: [2019-10-14 Mon 15:58]
In this exercise I am copying the whole package again, as due to the poor
architecture of the algebra system, adding such a tiny feature is not additive.
#+begin_src scheme :exports both :results output
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(show #t "Scheme-number: " (equ? (make-scheme-number 1) (make-scheme-number 2)) "\n")
(show #t "Rational: " (equ? (make-rational 1 2) (make-rational 2 4)) "\n")
(show #t "Complex: " (equ? (make-complex-from-mag-ang 1 0)
(make-complex-from-real-imag 1 0)) "\n")
#+end_src
#+RESULTS:
: Scheme-number: #f
: Rational: #t
: Complex: #t
*** DONE Exercise 2.80 Generic arithmetic zero?
CLOSED: [2019-10-14 Mon 17:18]
#+begin_src scheme :exports both :results output
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags))))))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(show #t "Scheme-number: " (zero? (make-scheme-number 0)) "\n")
(show #t "Rational: " (zero? (make-rational 0 2)) "\n")
(show #t "Complex: " (zero? (make-complex-from-mag-ang 0 0)) "\n")
#+end_src
#+RESULTS:
: Scheme-number: #t
: Rational: #t
: Complex: #t
*** Snippet put-coercion
I added the ~put-coercion~ and ~get-coercion~ procedures to the
<<put-and-get>> noweb fragment. This doesn't seem to be much of a problem,
because these operations are not used before this point.
*** Snippet coercion procedures
We are modifying ~apply-generic~ in this snippet, which means that we may
need to do a lot of copying of the old code in order to make it work with the
new code.
#+begin_src scheme :exports both :results output :noweb-ref coercion-procedures-apply-generic
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic op (t1->t2 a1) a2))
(t2->t1
(apply-generic op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags))))))
(error "No method for these types"
(list op type-tags)))))))
#+end_src
#+RESULTS:
: Exception: {Exception #19 user "undefined variable" (put-coercion) #<procedure #f> (#f . 4)}
*** DONE Exercise 2.81 coercion to-itself
CLOSED: [2019-10-15 Tue 11:16]
Another extremely ill-defined problem.
Let us try to do some mind-reading to understand which parts of code we need
to tangle to solve it letter by letter.
**** a
I will tangle in the version of the algebra package from the Exercise-2.80,
but I will replace the ~apply-generic~ with a coercing version.
#+begin_src scheme :exports both :results output
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic op (t1->t2 a1) a2))
(t2->t1
(apply-generic op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags))))))
(error "No method for these types"
(list op type-tags)))))))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)
(put-coercion 'scheme-number 'scheme-number
scheme-number->scheme-number)
(put-coercion 'complex 'complex complex->complex)
(show #t (displayed (exp (make-complex-from-mag-ang 2 0) (make-complex-from-mag-ang 2 0))))
#+end_src
#+RESULTS:
: Geiser-eval--retort-output returned nil.
: The interpreter produced no output
: or there is a bug in geiser (likely!)
We can see that this code doesn't work as expected. Why?
The answer is because the new version of ~apply-generic~ only checks if the
coercions exist, not whether the function on the new coerced types exists.
This seems like making sense, as in order to "find a common denominator",
more than one coercion may be needed, but the result is not good in the sense
that if the final function doesn't exist, ~apply-generic~ ends up applying
itself over and over. So the strategy proposed by Louis is not very good.
**** b
#+begin_src scheme :exports both :results output
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (= (length args) 2)
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic op (t1->t2 a1) a2))
(t2->t1
(apply-generic op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags))))))
(error "No method for these types"
(list op type-tags)))))))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(show #t " " (displayed (exp (make-scheme-number 2) (make-scheme-number 2))) "\n")
(show #t " " (displayed (exp (make-complex-from-mag-ang 2 0)
(make-complex-from-mag-ang 2 0))))
#+end_src
#+RESULTS:
: (scheme-number . 4)
: Exception: {Exception #19 user "No method for these types" ((exp (complex complex))) #f #f}
This seems correct. There may be a problem when the function is actually
defined for some types that the given ones are coerce-able to, but the system
doesn't try that.
**** c
#+begin_src scheme :exports both :results output
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (and (= (length args) 2) (not (eq? (car type-tags) (cadr type-tags))))
(let ((type1 (car type-tags))
(type2 (cadr type-tags))
(a1 (car args))
(a2 (cadr args)))
(let ((t1->t2 (get-coercion type1 type2))
(t2->t1 (get-coercion type2 type1)))
(cond (t1->t2
(apply-generic op (t1->t2 a1) a2))
(t2->t1
(apply-generic op a1 (t2->t1 a2)))
(else
(error "No method for these types"
(list op type-tags))))))
(error "No method for these types"
(list op type-tags)))))))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(show #t " " (displayed (exp (make-scheme-number 2) (make-scheme-number 2))))
#+end_src
#+RESULTS:
: (scheme-number . 4)
*** DONE Exercise 2.82 three-argument-coercion
CLOSED: [2019-10-15 Tue 21:40]
I am copying the whole "algebra" mess, because I already lost track of which
functions are needed for the tests to work. Bad practice, don't do so.
#+begin_src scheme :exports both :results output :noweb-ref generic-arithmetic-packages-multidispatch
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
#+end_src
#+RESULTS:
: (scheme-number . 4)
#+begin_src scheme :exports both :results output :noweb-ref apply-generic-many-args
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "Even coercions failed. No method for these types.")))))
(error "No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
#+end_src
#+begin_src scheme :exports both :results output
<<accumulate>>
<<generic-arithmetic-packages-multidispatch>>
<<alyssa-complex-suggestion>>
<<apply-generic-many-args>>
(show #t " " (displayed
(max3-magnitude
(make-scheme-number 1)
(make-scheme-number 2)
(make-complex-from-real-imag 3 0))))
#+end_src
#+RESULTS:
: 3
Well, this solution works, but is not perfect. Indeed, we can promote the
numbers to one of the arguments, but this implementation would fail if the
types are coerce-able, but the operation is not implemented.
*** DONE Exercise 2.83 Numeric Tower and (raise)
CLOSED: [2019-10-16 Wed 14:53]
This exercise has a problem: the name of the ~(raise)~ function coincides
with the R7RS' built-in name for an operation to raise exceptions. Therefore,
I have to name my operation ~raise-type~.
#+begin_src scheme :exports both :results output
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types))))))
(define (integer->rational x)
(make-rational integer 1))
(define (rational->scheme-number x)
(/ (numer x) (denom x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x) ((get-coercion (type-tag x) (higher-type (type-tag x))) x))
#+end_src
*** DONE Exercise 2.84 Using ~raise~ (~raise-type~) in ~apply-generic~
CLOSED: [2019-10-17 Thu 11:39]
This exercise is also extremely confusing. Scheme-number, I guess, can
effectively be considered "real", so "rational" numbers should be lower in
the hierarchy than "scheme-number"s. But what about integers? We never had
any operations concerning integers.
In this exercise I will try to implement the following strategy:
1. Modify ~type-tag~ to return ~'integer~ for scheme integers.
2. Will not implement any operations for ~'integer~'s, because those will be
covered by the ~'rational~ class.
#+begin_src scheme :exports both :results output
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'to-real '(rational) (lambda (x) (/ (numer x) (denom x))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(cond (proc (apply proc (map contents args)))
((= 2 (length args))
(if (type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
((and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "Even coercions failed. No method for these types."))))))
(else (error "No method for these types"
(list op type-tags))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex)
(lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real 'rational) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(show #t "Remainder-integer : " (remainder-generalized 4 2) "\n")
(show #t "Adding (coercion to rational): " (add 5 6))
#+end_src
#+RESULTS:
: Remainder-integer : 0
: Adding (coercion to rational): (rational 11 . 1)
This seems to do the job.
*** DONE Exercise 2.85 Dropping a type
CLOSED: [2019-10-20 Sun 13:47]
(I didn't count the time spent on every exercise individually (although it
can be deduced from the total time spent between the CLOSED operations.), but
this exercise took me a lot of time.)
In this exercise I will use the r7rs standard library procedures ~numerator~
and ~denominator~ in order to project numbers from ~'scheme-number~ to
~'rational~.
Once again, it tangling doesn't help much in dealing with packages, so I will
copy the whole source code again.
In this exercise, I spent quite a lot of time debugging the ~(project)~,
which is how your life in programming will be any way. You spend most of your
time debugging seemingly obvious things and finding bugs in the code you
believed to be working fine. It turns out that I had to fix several bugs in
the coercion functions from the previous exercises. I am not describing those
fixed explicitly, but you may get them by comparing the code.
#+begin_src scheme :exports both :results output
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(make-rational
(exact (numerator x))
(exact (denominator x)))))
'done)
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'project '(rational) (lambda (x) (exact (truncate (/ (numer x) (denom x))))))
(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (make-scheme-number (real-part z))))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(cond (proc (apply proc (map contents args)))
((= 2 (length args))
(if (type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
((and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj) (apply-generic 'project obj))
(define (droppable? obj)
(cond ((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
#;(show #t "Test: " (droppable? (make-complex-from-real-imag 1 0)))
#;(show #t "Test 2: projecting a 'scheme-number: " (displayed (project (make-scheme-number 1))) "\n")
#;(show #t "Test 3:" (drop (make-complex-from-real-imag 1 0)) "\n")
(show #t "Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1 2)
(make-complex-from-real-imag 0 2)) "\n")
#;(show #t "Dropping #t: " (drop #t) "\n")
#;(show #t "Dropping #f: " (drop #f) "\n")
#;(show #t
"(equ? (raise-type (project '(complex rectangular 1 0))) '(complex rectangular 1 0))"
(equ? (raise-type (project '(complex rectangular 1 0))) '(complex rectangular 1 0)))
#;(show #t (drop '(complex rectangular 1 0)) "\n")
#;(show #t "Testing project: " (displayed (project (make-complex-from-real-imag 1 0))) "\n")
#;(show #t "Testing: " (displayed (equ? (make-complex-from-real-imag 2 0) (raise-type (project (make-complex-from-real-imag 2 1))))) "\n")
#+end_src
#+RESULTS:
: Subtracting complex numbers: 1
*** DONE Exercise 2.86 Compound complex numbers
CLOSED: [2019-10-20 Sun 20:22]
At the moment, our complex numbers are pairs of two built-in real numbers. We
need to be able to build them from rational and integer numbers too.
Again, since the changes we are doing here are not additive, I will just copy
the whole system in one block.
It seems that implementing sines and cosines over 'scheme-number's is enough,
because the other types should be covered by coercion.
#+begin_src scheme :exports both :results output
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(show #t "Calling project 'scheme-number\n")
(make-rational
(exact (numerator x))
(exact (denominator x)))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'project '(rational) (lambda (x) (show #t "Calling project rational, x=" x "\n")
(exact (truncate (/ (numer x) (denom x))))))
(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(if (type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
((and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(show #t "Project function: " obj "\n")
(apply-generic 'project obj))
(define (droppable? obj)
(cond ((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
#+end_src
#+RESULTS:
#+begin_example
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: 1.1
Calling project 'scheme-number
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: 1.1
Calling project 'scheme-number
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (complex rectangular (rational 2476979795053773 . 2251799813685248) . 0)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: 2476979795053773/2251799813685248
Calling project 'scheme-number
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: 2476979795053773/2251799813685248
Calling project 'scheme-number
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: 2476979795053773/2251799813685248
Calling project 'scheme-number
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: 2476979795053773/2251799813685248
Calling project 'scheme-number
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: (rational 0 . 1)
Calling project rational, x=(0 . 1)
Project function: (complex rectangular (rational 2476979795053773 . 2251799813685248) . 0)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Project function: (rational 2476979795053773 . 2251799813685248)
Calling project rational, x=(2476979795053773 . 2251799813685248)
Subtracting complex numbers: (rational 2476979795053773 . 2251799813685248)
#+end_example
All right, this seems super fragile, but somehow works.
This piece will probably also be quite hairy, so it probably will be a good
idea to write down the code examples.
#+begin_src scheme :exports both :results output polynomial-package
(define (install-polynomial-package)
#;(internal procedures)
#;(representation of poly)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
#;(representation of terms and term lists)
(define (adjoin-term term term-list)
(if (=zero? (coeff term))
term-list
(cons term term-list)))
(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
#;(continued on next page)
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
#;(interface to rest of the system)
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
'done)
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
#+end_src
#+RESULTS:
*** DONE Exercise 2.87 Generalized zero?
CLOSED: [2019-10-21 Mon 18:25]
Remark 1: Even before I started solving anything, it required me 2.5 hours in
order to just make the examples run and add a couple of simple polynomials.
#+begin_src scheme :exports both :results output
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(make-rational
(exact (numerator x))
(exact (denominator x)))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
(show #t "No proc found for op=" op ", type-tags=" type-tags "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(if (type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
((and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
(cond ((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
#;(internal procedures)
#;(representation of poly)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
#;(representation of terms and term lists)
(define (adjoin-term term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
#;(continued on next page)
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
(show #t "zero-poly?: poly=" poly "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((every (lambda (x) (apply-generic 'zero? (coeff x))) (term-list poly)) #t)
(else #f)))
#;(interface to rest of the system)
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put 'zero? '(polynomial) zero-poly?)
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
(show #t "Test 3: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
#+end_src
#+RESULTS:
: Test 1: Subtracting complex numbers: (rational 2476979795053773 . 2251799813685248)
: Test 2: Making polynomials: (polynomial x (5 1) (4 2))
: No proc found for op=zero?, type-tags=(integer)
: Test 3: Adding polynomials: (polynomial x (5 2) (4 2) (0 1))
: zero-poly?: poly=(x (5 0) (3 1))
: No proc found for op=zero?, type-tags=(integer)
: No proc found for op=zero?, type-tags=(integer)
: Test 4: Zero?: #f
Even though making the example code turned out to be a huge pain, actually
solving the puzzle wasn't that hard. Just added a predicate to check if every
coefficient of a polynomial is zero.
*** DONE Exercise 2.88 Subtraction of polynomials
CLOSED: [2019-10-22 Tue 09:55]
I am copying the code again. We would need to implement a generalized
subtraction function.
This task turned out to be super-easy.
#+begin_src scheme :exports both :results output
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(make-rational
(exact (numerator x))
(exact (denominator x)))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(if (type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
((and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
(cond ((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
#;(internal procedures)
#;(representation of poly)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
#;(representation of terms and term lists)
(define (adjoin-term term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
#;(continued on next page)
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
(show #t "zero-poly?: poly=" poly "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((every (lambda (x) (apply-generic 'zero? (coeff x))) (term-list poly)) #t)
(else #f)))
#;(interface to rest of the system)
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put 'zero? '(polynomial) zero-poly?)
'done)
(install-polynomial-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
(show #t "Test 3: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
#+end_src
#+RESULTS:
: Test 1: Subtracting complex numbers: (rational 2476979795053773 . 2251799813685248)
: Test 2: Making polynomials: (polynomial x (5 1) (4 2))
: Test 3: Adding polynomials: (polynomial x (5 2) (4 2) (0 1))
: zero-poly?: poly=(x (5 0) (3 1))
: Test 4: Zero?: #f
: Test 5: Subtracting polynomials: (polynomial x (5 1) (4 2))
*** DONE Exercise 2.89 Dense term-lists
CLOSED: [2019-10-22 Tue 11:55]
This is a contrived exercise, frankly. It's purpose, I guess, is to just
prepare the reader for the next exercise, which would be too big
otherwise. The functions we are going to write here will serve as a basis for
the Exercise 2.90, where we will pack them into a separate package.
This exercise is also easy, the main trick is to understand that a term and a
term-list are two separate things and that the latter is not necessarily the
set of the former.
The sparse list-based ~adjoin-term~ seems to be only adjoining higher terms, not
lower, so my dense list-based only supports that too. In any case, adding the
option to adjoin smaller terms seems to be possible if needed.
#+begin_src scheme :exports both :results output
(define (adjoin-term term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (the-empty-termlist) '())
(define (first-term term-list) (make-term (car term-list)) (length (cdr term-list)))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(show #t "Test 1: appending zero: " (adjoin-term (make-term 100 0) (the-empty-termlist)) "\n")
(show #t "Test 2: appending zero: " (adjoin-term (make-term 100 0) '(1)) "\n")
(show #t "Test 2: appending zero: " (adjoin-term (make-term 10 1) '(1)) "\n")
#+end_src
#+RESULTS:
: Test 1: appending zero: ()
: Test 2: appending zero: (1)
: Test 2: appending zero: (1 0 0 0 0 0 0 0 0 0 1)
*** DONE Exercise 2.90 Implementing dense polynomials as a separate package
CLOSED: [2019-10-22 Tue 21:31]
Again, since implementing the new package will require a major rewrite of the
system, it's better to copy the code rather than tangle.
#+begin_src scheme :exports both :results output
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(make-rational
(exact (numerator x))
(exact (denominator x)))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(if (type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
((and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
(cond ((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
#;(continued on next page)
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
#;(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (= 0 (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (tag p) (attach-tag 'polynomial p))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
#;(show #t "first-term: term-list=" (displayed term-list) "\n")
#;(show #t "first-term: term-list-type=" (displayed (termlist-type-of term-list)) "\n")
((get 'first-term (termlist-type-of term-list)) term-list))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put 'zero? '(polynomial) zero-poly?)
'done)
(install-polynomial-package)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
(put 'first-term 'dense first-term-dense)
'done)
(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
#;(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
#+end_src
#+RESULTS:
#+begin_example
Test 1: Subtracting complex numbers: (rational 2476979795053773 . 2251799813685248)
Test 2: Making polynomials: (polynomial x (5 1) (4 2))
Test 3: Zero?: #f
Test 4: Adding polynomials: (polynomial x (5 2) (4 2) (0 1))
Test 5: Subtracting polynomials: (polynomial x (5 1) (4 2))
Test 6: Making a dense polynomial: (polynomial x 1 2 3 4 5)
Test 7: zero? dense polynomial: #t
Test 8: zero? dense polynomial: #f
Test 9: Adding dense polynomials: (polynomial x (5 2) (4 2) (0 1))
Test10: Subtracting dense polynomials: (polynomial x 2 0 0 0 1)
Test11: Subtracting dense and sparse polynomials: (polynomial x 1 0 0 0 0 1)
#+end_example
This also turned out to be not such a difficult exercise. The slightly
controversial thing that I am concerned with is that the function
~termlist-type-of~ is not based on tags, and is not even using the main
generic dispatch subsystem. But so far this seems good enough.
*** DONE Exercise 2.91 Division of polynomials
CLOSED: [2019-10-23 Wed 00:11]
And again, since div-poly is an internal procedure of the polynomial package,
let me copy the whole code.
#+begin_src scheme :exports both :results output
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(make-rational
(exact (numerator x))
(exact (denominator x)))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(if (type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
((and (>= (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (higher-type x)
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
(cond ((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
#;(continued on next page)
(define (add-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- ADD-POLY"
(list p1 p2))))
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((quotient-and-remainder (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car quotient-and-remainder))
(make-poly (variable p1) (cadr quotient-and-remainder))))
(error "div-poly: Polys not in the same var" p1 p2)))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (term-list
(sub-poly
(make-poly 'fake-var L1)
(mul-poly
(make-poly 'fake-var (list (make-term new-o new-c)))
(make-poly 'fake-var L2))))
L2)
))
(show #t "div-terms: rest-of-result: " (displayed rest-of-result) "\n")
(list (adjoin-term (make-term new-o new-c) (car rest-of-result)) (cadr rest-of-result))
))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
#;(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (= 0 (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (tag p) (attach-tag 'polynomial p))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
#;(show #t "first-term: term-list=" (displayed term-list) "\n")
#;(show #t "first-term: term-list-type=" (displayed (termlist-type-of term-list)) "\n")
((get 'first-term (termlist-type-of term-list)) term-list))
(put 'add '(polynomial polynomial)
(lambda (p1 p2) (tag (add-poly p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
(put 'zero? '(polynomial) zero-poly?)
(put 'div '(polynomial polynomial) div-poly)
'done)
(install-polynomial-package)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
(put 'first-term 'dense first-term-dense)
'done)
(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
#;(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
(show #t "Test12: Dividing x^2 + 2x + 1 by x+1: "
(displayed
(div (make-polynomial 'x '((2 1) (1 2) (0 1)))
(make-polynomial 'x '( (1 1) (0 1)))) ) "\n")
#+end_src
#+RESULTS:
#+begin_example
Test 1: Subtracting complex numbers: (rational 2476979795053773 . 2251799813685248)
Test 2: Making polynomials: (polynomial x (5 1) (4 2))
Test 3: Zero?: #f
Test 4: Adding polynomials: (polynomial x (5 2) (4 2) (0 1))
Test 5: Subtracting polynomials: (polynomial x (5 1) (4 2))
Test 6: Making a dense polynomial: (polynomial x 1 2 3 4 5)
Test 7: zero? dense polynomial: #t
Test 8: zero? dense polynomial: #f
Test 9: Adding dense polynomials: (polynomial x (5 2) (4 2) (0 1))
Test10: Subtracting dense polynomials: (polynomial x 2 0 0 0 1)
Test11: Subtracting dense and sparse polynomials: (polynomial x 1 0 0 0 0 1)
div-terms: rest-of-result: (() ())
div-terms: rest-of-result: (((0 1)) ())
Test12: Dividing x^2 + 2x + 1 by x+1: ((x (1 1) (0 1)) (x))
#+end_example
This task also wasn't very difficult. The only problem here is that
~div-poly~ returns two polynomials, not one. This is a problem, because this
breaks the closure property.
*** DONE Exercise 2.92 Ordering of variables so that addition and multiplication work for different variables
CLOSED: [2019-10-27 Sun 13:32]
"This is not easy, Prof. Abelson". Indeed, at the very beginning we are
meeting a problem: we need to add polynomials and numbers. This problem seems
to be extraordinarily laborious.
Well, the sketch of the idea was to rearrange the polynomials to a canonical
form, so that the variables are ordered sequentially. So we will need a way
to compare the variables, say, alphabetically.
To help us in this business, we shall use R^7 RS standard procedures
~symbol->string~ and ~string<?~.
Essentially, this code does a bubble-sort on the variables. The
~normalize-once~ procedure makes one pass of the exchanges, that is, it
effectively allows one "bubble" to float up.
The ~normalize-fully~ procedure repeats the normalization until it's done,
which may lead to infinite loops in case there are some bugs inside, but it
should work as \(n^2\) .
The thing that does not work in this implementation is the division of
polynomials of different variables. To be hones, because I am not sure what
it is semantically.
In total, this exercise took me several days, and the net amount of hours
spent is about 10.
#+begin_src scheme :exports both :results output
(define (thingy-source thingy)
(cond ((lambda? thingy) (list "lambda" (lambda-source thingy)))
((procedure? thingy) (list "procedure" (procedure-name thingy)))
((pair? thingy) (list "pair" (pair-source thingy)))
(else "No source? refactor")))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(make-rational
(exact (numerator x))
(exact (denominator x)))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))
(define (add-rat x y)
(make-rat (+ (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (- (* (numer x) (denom y))
(* (numer y) (denom x)))
(* (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (* (numer x) (numer y))
(* (denom x) (denom y))))
(define (div-rat x y)
(make-rat (* (numer x) (denom y))
(* (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (= 0 (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (= 0 (numer x))))
(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
#;(show #t "apply-generic:entry\n")
#;(error "debug")
(define (variable poly) (car poly))
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
#;(show #t "apply-generic: type-tags="
(displayed type-tags)
" proc=" (written proc)
" proc-source=" (thingy-source proc) "\n")
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags ", arg=" (displayed args) "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(cond ((and (eq? 'polynomial (car type-tags))
(numeric? (cadr type-tags)))
(apply-generic op
(car args)
(make-polynomial (variable (contents (car args)))
(list (list 0 (cadr args))))))
((and (numeric? (car type-tags))
(eq? 'polynomial (cadr type-tags)))
(apply-generic op
(make-polynomial (variable (contents (cadr args)))
(list (list 0 (car args))))
(cadr args)))
((and (get-coercion (car type-tags) (cadr type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
((get-coercion
(car type-tags)
(cadr type-tags)) (car args))
(cadr args)))
((and (get-coercion (cadr type-tags) (car type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
(car args)
((get-coercion
(cadr type-tags)
(car type-tags)) (cadr args) )))
((comparable? (car type-tags) (cadr type-tags))
(if
(type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
(else (error "apply-generic:Incomparable types: (type-tags,args)=" type-tags args))))
((and (> (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define (comparable? type1 type2) (and (memq type1 numeric-tower) (memq type2 numeric-tower)))
#;(define (higher-type x)
(show #t "higher-type:x=" (displayed x) "\n")
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x types))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (numeric? x)
(memq x numeric-tower))
(define (polynomial? x)
(eq? (type-tag x) 'polynomial))
(define (higher-type x)
(let ((tail (memq x numeric-tower)))
(cond ((eq? #f tail) (error "Type not in the tower" x))
((null? (cdr tail)) (error "Already the highest type:" x))
(else (cadr tail)))))
(show #t "Test: Higher than 'integer: " (higher-type 'integer) "\n")
#;(show #t "Test: Higher than 'complex: " (higher-type 'complex) "\n")
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (integer->rational x)
(make-rational x 1))
(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
(put-coercion 'integer 'rational integer->rational)
(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (raise-type x)
#;(show #t "Raising type of: " (displayed x) "\n")
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
(cond ((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
#;(define (contents generic-object)
(cdr generic-object))
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
#;(continued on next page)
(define (add-poly p1 p2)
#;(show #t "add-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(let ((res (cdr (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(add (tag p1) (tag (make-poly (variable p1) (list (make-term 0 (tag p2))))))
(add (tag (make-poly (variable p2) (list (make-term 0 (tag p1))))) (tag p2))))))
#;(show #t "add-poly:result: " (displayed res) "\n") res)))
(show #t "TestY2: poly of poly: "
(make-poly 'x (list
(make-term 3 (make-poly
'y (list (make-term 1 1) (make-term 0 1))))
(make-term 1 2)
(make-term 0 4))) "\n")
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(contents (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(mul (tag p1)
(make-polynomial (variable p1)
(adjoin-term
(make-term 0
(tag p2)) (the-empty-termlist))))
(mul (tag p2)
(make-polynomial (variable p2)
(adjoin-term
(make-term 0
(tag p1)) (the-empty-termlist))))))
#;(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((quotient-and-remainder (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car quotient-and-remainder))
(make-poly (variable p1) (cadr quotient-and-remainder))))
(error "div-poly: Polys not in the same var" p1 p2)))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (term-list
(sub-poly
(make-poly 'fake-var L1)
(mul-poly
(make-poly 'fake-var (list (make-term new-o new-c)))
(make-poly 'fake-var L2))))
L2)
))
#;(show #t "div-terms: rest-of-result: " (displayed rest-of-result) "\n")
(list (adjoin-term (make-term new-o new-c) (car rest-of-result)) (cadr rest-of-result))
))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
#;(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (zero? (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
((get 'first-term (termlist-type-of term-list)) term-list))
(define (variable_1-order<variable_2-order variable_1 variable_2)
#;(show #t "var_1-..: variable_1=" variable_1 " variable_2=" variable_2 "\n")
#;(show #t "var12string=" (symbol->string variable_1) "var22string=" (symbol->string variable_2) "\n")
(string<=? (symbol->string variable_1) (symbol->string variable_2)))
(define (normalize-fully poly)
(if (normal-polynomial? poly)
poly
(normalize-fully (normalize-once poly))))
(put 'add '(polynomial polynomial)
(lambda (p1 p2)
#;(show #t "generic-add-poly:Polynomial dispatch found: p1="
(displayed p1) " p2=" (displayed p2) "\n")
(normalize-fully (tag (add-poly p1 p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (normalize-fully (tag (mul-poly p1 p2)))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'zero? '(polynomial) zero-poly?)
(put 'div '(polynomial polynomial) div-poly)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (monomial-flip-variables monomial)
#;(show #t "m-f-v: monomial=" monomial "\n")
(let* ((mono (contents monomial))
(inner-polynomial (contents (coeff (first-term (term-list mono)))))
(inner-poly (contents inner-polynomial))
(outer-order (order (first-term (term-list mono))))
(outer-var (variable mono))
(inner-var (variable inner-polynomial))
(inner-term-list (term-list inner-poly)))
#;(show #t "m-f-v: inner-poly=" inner-poly "\n")
(if (same-variable? inner-var outer-var)
(mul
(make-polynomial outer-var (adjoin-term (make-term outer-order 1) (the-empty-termlist)))
(tag inner-polynomial))
(tag (make-poly inner-var
(mul-term-by-all-terms (make-term
0
(make-polynomial
outer-var
(list (make-term
outer-order
1)))) inner-poly))))))
#;(show #t "TestXX: sorting variables: Is 'x < 'y?: "
(variable_1-order<variable_2-order 'x 'y) "\n")
#;(show #t "TestXX: sorting variables: Is 'z < 'y?: "
(variable_1-order<variable_2-order 'z 'y) "\n")
#;(show #t "TestXX: (adding two basic poly): "
(add (make-polynomial 'x (list (make-term 1 2) (make-term 0 4)))
(make-polynomial 'y (list (make-term 2 3) (make-term 0 5)))) "\n")
(define (polynomial->sum-of-first-and-rest poly)
#;(show #t "p->s-o-f-a-r: " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (first-term (term-list poly1)))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
first-monomial
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test13: Expanding a polynomial as monomials: "
(displayed
(polynomial->sum-of-first-and-rest
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))))) "\n")
(show #t "\nTest20: start monomial: "
(displayed (make-polynomial 'x
(list
(make-term
2
(make-polynomial
'y
(list
(make-term 2 1) (make-term 0 1))))))) "\n")
(show #t "Test20: Flipping a monomial variable: "
(displayed
(monomial-flip-variables
(make-polynomial 'x
(list (make-term 1 (make-polynomial
'y
(list
(make-term 2 1)
(make-term 0 1)))))))) "\n\n")
(define (normal-polynomial? poly)
#;(show #t "n-p?: poly=" poly "\n")
(cond ((not (polynomial? poly)) #t)
((null? (term-list (contents poly))) #t)
(else (let* ((poly1 (contents poly))
(outer-var (variable poly1)))
#;(show #t "Inner-let: outer-var=" (displayed outer-var) "\n")
(let loop ((terms (term-list poly1)))
#;(show #t "n-p?-loop: terms=" (displayed terms) "\n")
(cond ((null? terms) #t)
((not (polynomial? (coeff (first-term terms)))) (loop (rest-terms terms)))
((not (variable_1-order<variable_2-order
outer-var
(variable (contents (coeff (first-term terms)))))) (begin #;(show #t "wrong variable order \n") #f))
((not (normal-polynomial? (coeff (first-term terms)))) (begin #;(show #t "not normal poly\n") #f))
(else (loop (rest-terms terms)))))
))))
(define (normalize-once poly)
#;(show #t "normalize-once poly= " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (make-term
(order (first-term (term-list poly1)))
(if (polynomial? (coeff (first-term (term-list poly1))))
(normalize-once (coeff (first-term (term-list poly1))))
(coeff (first-term (term-list poly1))))))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
(if (and (polynomial?
(coeff
(first-term
(term-list
(contents first-monomial)))))
(variable_1-order<variable_2-order
(variable
(contents
(coeff
(first-term
(term-list
(contents first-monomial))))))
(variable
(contents first-monomial))))
(monomial-flip-variables first-monomial)
first-monomial)
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test21: normal-polynomial?:start: " (displayed (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test21: normal-polynomial?:result:" (normal-polynomial? (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:start: "
(displayed
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:result:"
(normal-polynomial?
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test23:input: normalizing a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test23:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalizing a bad polynomial: "
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalize-fully a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalize-fully a bad polynomial: "
(normalize-fully (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
'done)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
(put 'first-term 'dense first-term-dense)
'done)
#;(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(install-polynomial-package)
#;(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
#;(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
#;(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
#;(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
#;(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
#;(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
#;(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
#;(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
#;(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
#;(show #t "Test12: Dividing x^2 + 2x + 1 by x+1: "
(displayed
(div (make-polynomial 'x '((2 1) (1 2) (0 1)))
(make-polynomial 'x '( (1 1) (0 1)))) ) "\n")
#;(show #t "Test14: Adding polynomials of two variables: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))))
#;(show #t "Test14: Adding polynomials of two variables, when one of them is nonexistant: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((0 1))))))
(show #t "Test25: multiplying different variables: "
(displayed (mul (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))) "\n")
#+end_src
#+RESULTS:
#+begin_example
Test: Higher than 'integer: rational
Test 1: Subtracting complex numbers: (rational 2476979795053773 . 2251799813685248)
TestY2: poly of poly: (x (3 (y (1 1) (0 1))) (1 2) (0 4))
Test13: Expanding a polynomial as monomials: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test20: start monomial: (polynomial x (2 (polynomial y (2 1) (0 1))))
Test20: Flipping a monomial variable: (polynomial y (2 (polynomial x (1 1))) (0 (polynomial x (1 1))))
Test21: normal-polynomial?:start: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test21: normal-polynomial?:result:#f
Test22: normal-polynomial?-good:start: (polynomial x (2 (polynomial y (2 1) (0 1))) (0 2))
Test22: normal-polynomial?-good:result:#t
Test23:input: normalizing a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test23:result: normalizing a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test24:input: normalizing a bad polynomial: (polynomial x (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalizing a bad polynomial: (polynomial x (4 1) (2 1) (0 2))
Test24:input: normalize-fully a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalize-fully a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test25: multiplying different variables: (polynomial x (1 (polynomial y (1 1))))
#+end_example
*** DONE Exercise 2.93 Rational polynomials
CLOSED: [2019-10-27 Sun 22:36]
I do not have any other choice rather than copy everything again.
This turned out to be quite an easy exercise. The architectural decision was
to stop using rational numbers entirely and remove them from the numeric
tower. In principle, rationals can be added as a super-type of polynomials,
but so far this has not been requested.
Note that the normalization algorithm developed in the Exercise 2.92 is still
hooked into the system, even though it would only be used for the case when
the "inner" and "outer" polynomials are of the same variable.
#+begin_src scheme :exports both :results output
(define (thingy-source thingy)
(cond ((lambda? thingy) (list "lambda" (lambda-source thingy)))
((procedure? thingy) (list "procedure" (procedure-name thingy)))
((pair? thingy) (list "pair" (pair-source thingy)))
(else "No source? refactor")))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(exact (truncate x))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
#;(let ((g (gcd n d)))
(cons (/ n g) (/ d g)))
(cons n d))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (sub (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (mul (numer x) (numer y))
(mul (denom x) (denom y))))
(define (div-rat x y)
(make-rat (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (zero? (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (zero? (numer x))))
#;(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
#;(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
#;(show #t "apply-generic:entry\n")
#;(error "debug")
(define (variable poly) (car poly))
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
#;(show #t "apply-generic: type-tags="
(displayed type-tags)
" proc=" (written proc)
" proc-source=" (thingy-source proc) "\n")
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags ", arg=" (displayed args) "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(cond ((and (eq? 'polynomial (car type-tags))
(numeric? (cadr type-tags)))
(apply-generic op
(car args)
(make-polynomial (variable (contents (car args)))
(list (list 0 (cadr args))))))
((and (numeric? (car type-tags))
(eq? 'polynomial (cadr type-tags)))
(apply-generic op
(make-polynomial (variable (contents (cadr args)))
(list (list 0 (car args))))
(cadr args)))
((and (get-coercion (car type-tags) (cadr type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
((get-coercion
(car type-tags)
(cadr type-tags)) (car args))
(cadr args)))
((and (get-coercion (cadr type-tags) (car type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
(car args)
((get-coercion
(cadr type-tags)
(car type-tags)) (cadr args) )))
((comparable? (car type-tags) (cadr type-tags))
(if
(type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
(else (error "apply-generic:Incomparable types: (type-tags,args)=" type-tags args))))
((and (> (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
#;(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define numeric-tower (list 'integer 'scheme-number 'complex))
(define (comparable? type1 type2) (and (memq type1 numeric-tower) (memq type2 numeric-tower)))
#;(define (higher-type x)
(show #t "higher-type:x=" (displayed x) "\n")
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x types))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (numeric? x)
(memq x numeric-tower))
(define (polynomial? x)
(eq? (type-tag x) 'polynomial))
(define (higher-type x)
(let ((tail (memq x numeric-tower)))
(cond ((eq? #f tail) (error "Type not in the tower" x))
((null? (cdr tail)) (error "Already the highest type:" x))
(else (cadr tail)))))
(show #t "Test: Higher than 'integer: " (higher-type 'integer) "\n")
#;(show #t "Test: Higher than 'complex: " (higher-type 'complex) "\n")
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
#;(define (integer->rational x)
(make-rational x 1))
#;(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
#;(put-coercion 'integer 'rational integer->rational)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (integer->scheme-number x)
(make-scheme-number (contents (exact->inexact x))))
(put-coercion 'integer 'scheme-number integer->scheme-number)
(define (raise-type x)
#;(show #t "Raising type of: " (displayed x) "\n")
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
#;(show #t "droppable?: obj=" obj ", type-tag=" (type-tag obj) "\n")
(cond ((eq? (type-tag obj) 'rational) (begin (show #t "rational not droppable: #f\n") #f))
((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
#;(define (contents generic-object)
(cdr generic-object))
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
#;(continued on next page)
(define (add-poly p1 p2)
#;(show #t "add-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(let ((res (cdr (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(add (tag p1) (tag (make-poly (variable p1) (list (make-term 0 (tag p2))))))
(add (tag (make-poly (variable p2) (list (make-term 0 (tag p1))))) (tag p2))))))
#;(show #t "add-poly:result: " (displayed res) "\n") res)))
(show #t "TestY2: poly of poly: "
(make-poly 'x (list
(make-term 3 (make-poly
'y (list (make-term 1 1) (make-term 0 1))))
(make-term 1 2)
(make-term 0 4))) "\n")
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(contents (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(mul (tag p1)
(make-polynomial (variable p1)
(adjoin-term
(make-term 0
(tag p2)) (the-empty-termlist))))
(mul (tag p2)
(make-polynomial (variable p2)
(adjoin-term
(make-term 0
(tag p1)) (the-empty-termlist))))))
#;(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((quotient-and-remainder (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car quotient-and-remainder))
(make-poly (variable p1) (cadr quotient-and-remainder))))
(error "div-poly: Polys not in the same var" p1 p2)))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (term-list
(sub-poly
(make-poly 'fake-var L1)
(mul-poly
(make-poly 'fake-var (list (make-term new-o new-c)))
(make-poly 'fake-var L2))))
L2)
))
#;(show #t "div-terms: rest-of-result: " (displayed rest-of-result) "\n")
(list (adjoin-term (make-term new-o new-c) (car rest-of-result)) (cadr rest-of-result))
))))))
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
#;(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (zero? (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
((get 'first-term (termlist-type-of term-list)) term-list))
(define (variable_1-order<variable_2-order variable_1 variable_2)
#;(show #t "var_1-..: variable_1=" variable_1 " variable_2=" variable_2 "\n")
#;(show #t "var12string=" (symbol->string variable_1) "var22string=" (symbol->string variable_2) "\n")
(string<=? (symbol->string variable_1) (symbol->string variable_2)))
(define (normalize-fully poly)
(if (normal-polynomial? poly)
poly
(normalize-fully (normalize-once poly))))
(put 'add '(polynomial polynomial)
(lambda (p1 p2)
#;(show #t "generic-add-poly:Polynomial dispatch found: p1="
(displayed p1) " p2=" (displayed p2) "\n")
(normalize-fully (tag (add-poly p1 p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (normalize-fully (tag (mul-poly p1 p2)))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'zero? '(polynomial) zero-poly?)
(put 'div '(polynomial polynomial) div-poly)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (monomial-flip-variables monomial)
#;(show #t "m-f-v: monomial=" monomial "\n")
(let* ((mono (contents monomial))
(inner-polynomial (contents (coeff (first-term (term-list mono)))))
(inner-poly (contents inner-polynomial))
(outer-order (order (first-term (term-list mono))))
(outer-var (variable mono))
(inner-var (variable inner-polynomial))
(inner-term-list (term-list inner-poly)))
#;(show #t "m-f-v: inner-poly=" inner-poly "\n")
(if (same-variable? inner-var outer-var)
(mul
(make-polynomial outer-var (adjoin-term (make-term outer-order 1) (the-empty-termlist)))
(tag inner-polynomial))
(tag (make-poly inner-var
(mul-term-by-all-terms (make-term
0
(make-polynomial
outer-var
(list (make-term
outer-order
1)))) inner-poly))))))
#;(show #t "TestXX: sorting variables: Is 'x < 'y?: "
(variable_1-order<variable_2-order 'x 'y) "\n")
#;(show #t "TestXX: sorting variables: Is 'z < 'y?: "
(variable_1-order<variable_2-order 'z 'y) "\n")
#;(show #t "TestXX: (adding two basic poly): "
(add (make-polynomial 'x (list (make-term 1 2) (make-term 0 4)))
(make-polynomial 'y (list (make-term 2 3) (make-term 0 5)))) "\n")
(define (polynomial->sum-of-first-and-rest poly)
#;(show #t "p->s-o-f-a-r: " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (first-term (term-list poly1)))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
first-monomial
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test13: Expanding a polynomial as monomials: "
(displayed
(polynomial->sum-of-first-and-rest
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))))) "\n")
(show #t "\nTest20: start monomial: "
(displayed (make-polynomial 'x
(list
(make-term
2
(make-polynomial
'y
(list
(make-term 2 1) (make-term 0 1))))))) "\n")
(show #t "Test20: Flipping a monomial variable: "
(displayed
(monomial-flip-variables
(make-polynomial 'x
(list (make-term 1 (make-polynomial
'y
(list
(make-term 2 1)
(make-term 0 1)))))))) "\n\n")
(define (normal-polynomial? poly)
#;(show #t "n-p?: poly=" poly "\n")
(cond ((not (polynomial? poly)) #t)
((null? (term-list (contents poly))) #t)
(else (let* ((poly1 (contents poly))
(outer-var (variable poly1)))
#;(show #t "Inner-let: outer-var=" (displayed outer-var) "\n")
(let loop ((terms (term-list poly1)))
#;(show #t "n-p?-loop: terms=" (displayed terms) "\n")
(cond ((null? terms) #t)
((not (polynomial? (coeff (first-term terms)))) (loop (rest-terms terms)))
((not (variable_1-order<variable_2-order
outer-var
(variable (contents (coeff (first-term terms)))))) (begin #;(show #t "wrong variable order \n") #f))
((not (normal-polynomial? (coeff (first-term terms)))) (begin #;(show #t "not normal poly\n") #f))
(else (loop (rest-terms terms)))))
))))
(define (normalize-once poly)
#;(show #t "normalize-once poly= " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (make-term
(order (first-term (term-list poly1)))
(if (polynomial? (coeff (first-term (term-list poly1))))
(normalize-once (coeff (first-term (term-list poly1))))
(coeff (first-term (term-list poly1))))))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
(if (and (polynomial?
(coeff
(first-term
(term-list
(contents first-monomial)))))
(variable_1-order<variable_2-order
(variable
(contents
(coeff
(first-term
(term-list
(contents first-monomial))))))
(variable
(contents first-monomial))))
(monomial-flip-variables first-monomial)
first-monomial)
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test21: normal-polynomial?:start: " (displayed (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test21: normal-polynomial?:result:" (normal-polynomial? (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:start: "
(displayed
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:result:"
(normal-polynomial?
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test23:input: normalizing a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test23:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalizing a bad polynomial: "
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalize-fully a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalize-fully a bad polynomial: "
(normalize-fully (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
'done)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
(put 'first-term 'dense first-term-dense)
'done)
#;(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(install-polynomial-package)
#;(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
#;(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
#;(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
#;(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
#;(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
#;(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
#;(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
#;(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
#;(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
#;(show #t "Test12: Dividing x^2 + 2x + 1 by x+1: "
(displayed
(div (make-polynomial 'x '((2 1) (1 2) (0 1)))
(make-polynomial 'x '( (1 1) (0 1)))) ) "\n")
#;(show #t "Test14: Adding polynomials of two variables: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))))
#;(show #t "Test14: Adding polynomials of two variables, when one of them is nonexistant: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((0 1))))))
(show #t "Test25: multiplying different variables: "
(displayed (mul (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))) "\n")
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
(show #t "Test 26: make-rational-polynomial: " rf "\n")
(show #t "Test 27: add-rational\n")
(show #t "Test 27: " (add rf rf) "\n")
#+end_src
#+RESULTS:
#+begin_example
Test: Higher than 'integer: scheme-number
Test 1: Subtracting complex numbers: (scheme-number . 1.1)
TestY2: poly of poly: (x (3 (y (1 1) (0 1))) (1 2) (0 4))
Test13: Expanding a polynomial as monomials: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test20: start monomial: (polynomial x (2 (polynomial y (2 1) (0 1))))
Test20: Flipping a monomial variable: (polynomial y (2 (polynomial x (1 1))) (0 (polynomial x (1 1))))
Test21: normal-polynomial?:start: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test21: normal-polynomial?:result:#f
Test22: normal-polynomial?-good:start: (polynomial x (2 (polynomial y (2 1) (0 1))) (0 2))
Test22: normal-polynomial?-good:result:#t
Test23:input: normalizing a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test23:result: normalizing a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test24:input: normalizing a bad polynomial: (polynomial x (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalizing a bad polynomial: (polynomial x (4 1) (2 1) (0 2))
Test24:input: normalize-fully a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalize-fully a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test25: multiplying different variables: (polynomial x (1 (polynomial y (1 1))))
Test 26: make-rational-polynomial: (rational (polynomial x (3 1) (0 1)) polynomial x (2 1) (0 1))
Test 27: add-rational
rational not droppable: #f
Test 27: (rational (polynomial x (5 2) (3 2) (2 2) (0 2)) polynomial x (4 1) (2 2) (0 1))
#+end_example
*** DONE Exercise 2.94 Greatest-common-divisor for polynomials
CLOSED: [2019-10-28 Mon 00:47]
I will still copy the source code of the whole Computer Algebra System,
because extending the system with a GCD subroutine would require adding
functions to the polynomial package, which cannot be done with a mere
include.
#+begin_src scheme :exports both :results output :noweb-ref cas-with-rational-polynomials
(define (thingy-source thingy)
(cond ((lambda? thingy) (list "lambda" (lambda-source thingy)))
((procedure? thingy) (list "procedure" (procedure-name thingy)))
((pair? thingy) (list "pair" (pair-source thingy)))
(else "No source? refactor")))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(exact (truncate x))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
#;(let ((g (gcd n d)))
(cons (/ n g) (/ d g)))
(cons n d))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (sub (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (mul (numer x) (numer y))
(mul (denom x) (denom y))))
(define (div-rat x y)
(make-rat (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (zero? (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (zero? (numer x))))
#;(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
#;(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
#;(show #t "apply-generic:entry\n")
#;(error "debug")
(define (variable poly) (car poly))
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
#;(show #t "apply-generic: type-tags="
(displayed type-tags)
" proc=" (written proc)
" proc-source=" (thingy-source proc) "\n")
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags ", arg=" (displayed args) "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(cond ((and (eq? 'polynomial (car type-tags))
(numeric? (cadr type-tags)))
(apply-generic op
(car args)
(make-polynomial (variable (contents (car args)))
(list (list 0 (cadr args))))))
((and (numeric? (car type-tags))
(eq? 'polynomial (cadr type-tags)))
(apply-generic op
(make-polynomial (variable (contents (cadr args)))
(list (list 0 (car args))))
(cadr args)))
((and (get-coercion (car type-tags) (cadr type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
((get-coercion
(car type-tags)
(cadr type-tags)) (car args))
(cadr args)))
((and (get-coercion (cadr type-tags) (car type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
(car args)
((get-coercion
(cadr type-tags)
(car type-tags)) (cadr args) )))
((comparable? (car type-tags) (cadr type-tags))
(if
(type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
(else (error "apply-generic:Incomparable types: (type-tags,args)=" type-tags args))))
((and (> (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
#;(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define numeric-tower (list 'integer 'scheme-number 'complex))
(define (comparable? type1 type2) (and (memq type1 numeric-tower) (memq type2 numeric-tower)))
#;(define (higher-type x)
(show #t "higher-type:x=" (displayed x) "\n")
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x types))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (numeric? x)
(memq x numeric-tower))
(define (polynomial? x)
(eq? (type-tag x) 'polynomial))
(define (higher-type x)
(let ((tail (memq x numeric-tower)))
(cond ((eq? #f tail) (error "Type not in the tower" x))
((null? (cdr tail)) (error "Already the highest type:" x))
(else (cadr tail)))))
(show #t "Test: Higher than 'integer: " (higher-type 'integer) "\n")
#;(show #t "Test: Higher than 'complex: " (higher-type 'complex) "\n")
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
#;(define (integer->rational x)
(make-rational x 1))
#;(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
#;(put-coercion 'integer 'rational integer->rational)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (integer->scheme-number x)
(make-scheme-number (contents (exact->inexact x))))
(put-coercion 'integer 'scheme-number integer->scheme-number)
(define (raise-type x)
#;(show #t "Raising type of: " (displayed x) "\n")
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
#;(show #t "droppable?: obj=" obj ", type-tag=" (type-tag obj) "\n")
(cond ((eq? (type-tag obj) 'rational) (begin (show #t "rational not droppable: #f\n") #f))
((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
#;(define (contents generic-object)
(cdr generic-object))
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
#;(continued on next page)
(define (add-poly p1 p2)
#;(show #t "add-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(let ((res (cdr (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(add (tag p1) (tag (make-poly (variable p1) (list (make-term 0 (tag p2))))))
(add (tag (make-poly (variable p2) (list (make-term 0 (tag p1))))) (tag p2))))))
#;(show #t "add-poly:result: " (displayed res) "\n") res)))
(show #t "TestY2: poly of poly: "
(make-poly 'x (list
(make-term 3 (make-poly
'y (list (make-term 1 1) (make-term 0 1))))
(make-term 1 2)
(make-term 0 4))) "\n")
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(contents (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(mul (tag p1)
(make-polynomial (variable p1)
(adjoin-term
(make-term 0
(tag p2)) (the-empty-termlist))))
(mul (tag p2)
(make-polynomial (variable p2)
(adjoin-term
(make-term 0
(tag p1)) (the-empty-termlist))))))
#;(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((quotient-and-remainder (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car quotient-and-remainder))
(make-poly (variable p1) (cadr quotient-and-remainder))))
(error "div-poly: Polys not in the same var" p1 p2)))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (term-list
(sub-poly
(make-poly 'fake-var L1)
(mul-poly
(make-poly 'fake-var (list (make-term new-o new-c)))
(make-poly 'fake-var L2))))
L2)
))
#;(show #t "div-terms: rest-of-result: " (displayed rest-of-result) "\n")
(list (adjoin-term (make-term new-o new-c) (car rest-of-result)) (cadr rest-of-result))
))))))
(define (gcd-terms a b)
(if (empty-termlist? b)
a
(gcd-terms b (remainder-terms a b))))
(define (remainder-terms a b)
(cadr (div-terms a b)))
(define (gcd-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1) (gcd-terms (term-list p1) (term-list p2)))
(error "div-poly: Polys not in the same var" p1 p2)))
(put 'gcd '(polynomial polynomial)
(lambda (x y) (tag (gcd-poly x y))))
(put 'gcd '(integer integer) gcd)
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
#;(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (zero? (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
((get 'first-term (termlist-type-of term-list)) term-list))
(define (variable_1-order<variable_2-order variable_1 variable_2)
#;(show #t "var_1-..: variable_1=" variable_1 " variable_2=" variable_2 "\n")
#;(show #t "var12string=" (symbol->string variable_1) "var22string=" (symbol->string variable_2) "\n")
(string<=? (symbol->string variable_1) (symbol->string variable_2)))
(define (normalize-fully poly)
(if (normal-polynomial? poly)
poly
(normalize-fully (normalize-once poly))))
(put 'add '(polynomial polynomial)
(lambda (p1 p2)
#;(show #t "generic-add-poly:Polynomial dispatch found: p1="
(displayed p1) " p2=" (displayed p2) "\n")
(normalize-fully (tag (add-poly p1 p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (normalize-fully (tag (mul-poly p1 p2)))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'zero? '(polynomial) zero-poly?)
(put 'div '(polynomial polynomial) div-poly)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (monomial-flip-variables monomial)
#;(show #t "m-f-v: monomial=" monomial "\n")
(let* ((mono (contents monomial))
(inner-polynomial (contents (coeff (first-term (term-list mono)))))
(inner-poly (contents inner-polynomial))
(outer-order (order (first-term (term-list mono))))
(outer-var (variable mono))
(inner-var (variable inner-polynomial))
(inner-term-list (term-list inner-poly)))
#;(show #t "m-f-v: inner-poly=" inner-poly "\n")
(if (same-variable? inner-var outer-var)
(mul
(make-polynomial outer-var (adjoin-term (make-term outer-order 1) (the-empty-termlist)))
(tag inner-polynomial))
(tag (make-poly inner-var
(mul-term-by-all-terms (make-term
0
(make-polynomial
outer-var
(list (make-term
outer-order
1)))) inner-poly))))))
#;(show #t "TestXX: sorting variables: Is 'x < 'y?: "
(variable_1-order<variable_2-order 'x 'y) "\n")
#;(show #t "TestXX: sorting variables: Is 'z < 'y?: "
(variable_1-order<variable_2-order 'z 'y) "\n")
#;(show #t "TestXX: (adding two basic poly): "
(add (make-polynomial 'x (list (make-term 1 2) (make-term 0 4)))
(make-polynomial 'y (list (make-term 2 3) (make-term 0 5)))) "\n")
(define (polynomial->sum-of-first-and-rest poly)
#;(show #t "p->s-o-f-a-r: " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (first-term (term-list poly1)))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
first-monomial
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test13: Expanding a polynomial as monomials: "
(displayed
(polynomial->sum-of-first-and-rest
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))))) "\n")
(show #t "\nTest20: start monomial: "
(displayed (make-polynomial 'x
(list
(make-term
2
(make-polynomial
'y
(list
(make-term 2 1) (make-term 0 1))))))) "\n")
(show #t "Test20: Flipping a monomial variable: "
(displayed
(monomial-flip-variables
(make-polynomial 'x
(list (make-term 1 (make-polynomial
'y
(list
(make-term 2 1)
(make-term 0 1)))))))) "\n\n")
(define (normal-polynomial? poly)
#;(show #t "n-p?: poly=" poly "\n")
(cond ((not (polynomial? poly)) #t)
((null? (term-list (contents poly))) #t)
(else (let* ((poly1 (contents poly))
(outer-var (variable poly1)))
#;(show #t "Inner-let: outer-var=" (displayed outer-var) "\n")
(let loop ((terms (term-list poly1)))
#;(show #t "n-p?-loop: terms=" (displayed terms) "\n")
(cond ((null? terms) #t)
((not (polynomial? (coeff (first-term terms)))) (loop (rest-terms terms)))
((not (variable_1-order<variable_2-order
outer-var
(variable (contents (coeff (first-term terms)))))) (begin #;(show #t "wrong variable order \n") #f))
((not (normal-polynomial? (coeff (first-term terms)))) (begin #;(show #t "not normal poly\n") #f))
(else (loop (rest-terms terms)))))
))))
(define (normalize-once poly)
#;(show #t "normalize-once poly= " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (make-term
(order (first-term (term-list poly1)))
(if (polynomial? (coeff (first-term (term-list poly1))))
(normalize-once (coeff (first-term (term-list poly1))))
(coeff (first-term (term-list poly1))))))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
(if (and (polynomial?
(coeff
(first-term
(term-list
(contents first-monomial)))))
(variable_1-order<variable_2-order
(variable
(contents
(coeff
(first-term
(term-list
(contents first-monomial))))))
(variable
(contents first-monomial))))
(monomial-flip-variables first-monomial)
first-monomial)
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test21: normal-polynomial?:start: " (displayed (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test21: normal-polynomial?:result:" (normal-polynomial? (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:start: "
(displayed
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:result:"
(normal-polynomial?
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test23:input: normalizing a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test23:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalizing a bad polynomial: "
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalize-fully a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalize-fully a bad polynomial: "
(normalize-fully (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
'done)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
(put 'first-term 'dense first-term-dense)
'done)
#;(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(install-polynomial-package)
#;(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
#;(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
#;(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
#;(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
#;(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
#;(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
#;(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
#;(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
#;(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
#;(show #t "Test12: Dividing x^2 + 2x + 1 by x+1: "
(displayed
(div (make-polynomial 'x '((2 1) (1 2) (0 1)))
(make-polynomial 'x '( (1 1) (0 1)))) ) "\n")
#;(show #t "Test14: Adding polynomials of two variables: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))))
#;(show #t "Test14: Adding polynomials of two variables, when one of them is nonexistant: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((0 1))))))
(show #t "Test25: multiplying different variables: "
(displayed (mul (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))) "\n")
(begin
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
(show #t "Test 26: make-rational-polynomial: " rf "\n")
(show #t "Test 27: add-rational\n")
(show #t "Test 27: " (add rf rf) "\n")
)
(show #t "Test 28: polynomial-gcd: start\n")
(define (greatest-common-divisor p1 p2) (apply-generic 'gcd p1 p2))
(begin
(define p1 (make-polynomial
'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2 (make-polynomial 'x '((3 1) (1 -1))))
(show #t "Test 28: polynomial-gcd: " (greatest-common-divisor p1 p2) "\n"))
#+end_src
#+RESULTS:
#+begin_example
Test: Higher than 'integer: scheme-number
Test 1: Subtracting complex numbers: (scheme-number . 1.1)
TestY2: poly of poly: (x (3 (y (1 1) (0 1))) (1 2) (0 4))
Test13: Expanding a polynomial as monomials: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test20: start monomial: (polynomial x (2 (polynomial y (2 1) (0 1))))
Test20: Flipping a monomial variable: (polynomial y (2 (polynomial x (1 1))) (0 (polynomial x (1 1))))
Test21: normal-polynomial?:start: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test21: normal-polynomial?:result:#f
Test22: normal-polynomial?-good:start: (polynomial x (2 (polynomial y (2 1) (0 1))) (0 2))
Test22: normal-polynomial?-good:result:#t
Test23:input: normalizing a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test23:result: normalizing a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test24:input: normalizing a bad polynomial: (polynomial x (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalizing a bad polynomial: (polynomial x (4 1) (2 1) (0 2))
Test24:input: normalize-fully a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalize-fully a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test25: multiplying different variables: (polynomial x (1 (polynomial y (1 1))))
Test 26: make-rational-polynomial: (rational (polynomial x (3 1) (0 1)) polynomial x (2 1) (0 1))
Test 27: add-rational
rational not droppable: #f
Test 27: (rational (polynomial x (5 2) (3 2) (2 2) (0 2)) polynomial x (4 1) (2 2) (0 1))
Test 28: polynomial-gcd: start
Test 28: polynomial-gcd: (polynomial x (2 -1) (1 1))
#+end_example
So the answer is \(-x^2 + x\). Now we need to check this. Luckily, the number
of iterations is not very big.
Wolfram Alpha gives me \(x^2 - x\), which is the same thing, I guess.
*** DONE Exercise 2.95 Illustrate the non-integer problem
CLOSED: [2019-10-28 Mon 11:35]
#+begin_src scheme :exports both :results output
(define (thingy-source thingy)
(cond ((lambda? thingy) (list "lambda" (lambda-source thingy)))
((procedure? thingy) (list "procedure" (procedure-name thingy)))
((pair? thingy) (list "pair" (pair-source thingy)))
(else "No source? refactor")))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
(attach-tag 'scheme-number x))
(put 'add '(scheme-number scheme-number)
(lambda (x y) (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(exact (truncate x))))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
#;(let ((g (gcd n d)))
(cons (/ n g) (/ d g)))
(cons n d))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (sub (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (mul (numer x) (numer y))
(mul (denom x) (denom y))))
(define (div-rat x y)
(make-rat (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (zero? (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (zero? (numer x))))
#;(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
#;(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (apply-generic op . args)
#;(show #t "apply-generic:entry\n")
#;(error "debug")
(define (variable poly) (car poly))
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
#;(show #t "apply-generic: type-tags="
(displayed type-tags)
" proc=" (written proc)
" proc-source=" (thingy-source proc) "\n")
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags ", arg=" (displayed args) "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(cond ((and (eq? 'polynomial (car type-tags))
(numeric? (cadr type-tags)))
(apply-generic op
(car args)
(make-polynomial (variable (contents (car args)))
(list (list 0 (cadr args))))))
((and (numeric? (car type-tags))
(eq? 'polynomial (cadr type-tags)))
(apply-generic op
(make-polynomial (variable (contents (cadr args)))
(list (list 0 (car args))))
(cadr args)))
((and (get-coercion (car type-tags) (cadr type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
((get-coercion
(car type-tags)
(cadr type-tags)) (car args))
(cadr args)))
((and (get-coercion (cadr type-tags) (car type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
(car args)
((get-coercion
(cadr type-tags)
(car type-tags)) (cadr args) )))
((comparable? (car type-tags) (cadr type-tags))
(if
(type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
(else (error "apply-generic:Incomparable types: (type-tags,args)=" type-tags args))))
((and (> (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
#;(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
(define numeric-tower (list 'integer 'scheme-number 'complex))
(define (comparable? type1 type2) (and (memq type1 numeric-tower) (memq type2 numeric-tower)))
#;(define (higher-type x)
(show #t "higher-type:x=" (displayed x) "\n")
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x types))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
(define (numeric? x)
(memq x numeric-tower))
(define (polynomial? x)
(eq? (type-tag x) 'polynomial))
(define (higher-type x)
(let ((tail (memq x numeric-tower)))
(cond ((eq? #f tail) (error "Type not in the tower" x))
((null? (cdr tail)) (error "Already the highest type:" x))
(else (cadr tail)))))
(show #t "Test: Higher than 'integer: " (higher-type 'integer) "\n")
#;(show #t "Test: Higher than 'complex: " (higher-type 'complex) "\n")
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
#;(define (integer->rational x)
(make-rational x 1))
#;(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
#;(put-coercion 'integer 'rational integer->rational)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (integer->scheme-number x)
(make-scheme-number (contents (exact->inexact x))))
(put-coercion 'integer 'scheme-number integer->scheme-number)
(define (raise-type x)
#;(show #t "Raising type of: " (displayed x) "\n")
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
#;(show #t "droppable?: obj=" obj ", type-tag=" (type-tag obj) "\n")
(cond ((eq? (type-tag obj) 'rational) (begin (show #t "rational not droppable: #f\n") #f))
((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(show #t "Test 1: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(define (install-polynomial-package)
#;(define (contents generic-object)
(cdr generic-object))
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
#;(continued on next page)
(define (add-poly p1 p2)
#;(show #t "add-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(let ((res (cdr (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(add (tag p1) (tag (make-poly (variable p1) (list (make-term 0 (tag p2))))))
(add (tag (make-poly (variable p2) (list (make-term 0 (tag p1))))) (tag p2))))))
#;(show #t "add-poly:result: " (displayed res) "\n") res)))
(show #t "TestY2: poly of poly: "
(make-poly 'x (list
(make-term 3 (make-poly
'y (list (make-term 1 1) (make-term 0 1))))
(make-term 1 2)
(make-term 0 4))) "\n")
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(contents (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(mul (tag p1)
(make-polynomial (variable p1)
(adjoin-term
(make-term 0
(tag p2)) (the-empty-termlist))))
(mul (tag p2)
(make-polynomial (variable p2)
(adjoin-term
(make-term 0
(tag p1)) (the-empty-termlist))))))
#;(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((quotient-and-remainder (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car quotient-and-remainder))
(make-poly (variable p1) (cadr quotient-and-remainder))))
(error "div-poly: Polys not in the same var" p1 p2)))
(define (div-terms L1 L2)
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (term-list
(sub-poly
(make-poly 'fake-var L1)
(mul-poly
(make-poly 'fake-var (list (make-term new-o new-c)))
(make-poly 'fake-var L2))))
L2)
))
#;(show #t "div-terms: rest-of-result: " (displayed rest-of-result) "\n")
(list (adjoin-term (make-term new-o new-c) (car rest-of-result)) (cadr rest-of-result))
))))))
(define (gcd-terms a b)
(if (empty-termlist? b)
a
(begin
(show #t "gcd-terms: (term-list b)=" (term-list b) "\n")
(gcd-terms b (remainder-terms a b)))))
(define (remainder-terms a b)
(cadr (div-terms a b)))
(define (gcd-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1) (gcd-terms (term-list p1) (term-list p2)))
(error "div-poly: Polys not in the same var" p1 p2)))
(put 'gcd '(polynomial polynomial)
(lambda (x y) (tag (gcd-poly x y))))
(put 'gcd '(integer integer) gcd)
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
#;(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (zero? (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
((get 'first-term (termlist-type-of term-list)) term-list))
(define (variable_1-order<variable_2-order variable_1 variable_2)
#;(show #t "var_1-..: variable_1=" variable_1 " variable_2=" variable_2 "\n")
#;(show #t "var12string=" (symbol->string variable_1) "var22string=" (symbol->string variable_2) "\n")
(string<=? (symbol->string variable_1) (symbol->string variable_2)))
(define (normalize-fully poly)
(if (normal-polynomial? poly)
poly
(normalize-fully (normalize-once poly))))
(put 'add '(polynomial polynomial)
(lambda (p1 p2)
#;(show #t "generic-add-poly:Polynomial dispatch found: p1="
(displayed p1) " p2=" (displayed p2) "\n")
(normalize-fully (tag (add-poly p1 p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (normalize-fully (tag (mul-poly p1 p2)))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'zero? '(polynomial) zero-poly?)
(put 'div '(polynomial polynomial) div-poly)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (monomial-flip-variables monomial)
#;(show #t "m-f-v: monomial=" monomial "\n")
(let* ((mono (contents monomial))
(inner-polynomial (contents (coeff (first-term (term-list mono)))))
(inner-poly (contents inner-polynomial))
(outer-order (order (first-term (term-list mono))))
(outer-var (variable mono))
(inner-var (variable inner-polynomial))
(inner-term-list (term-list inner-poly)))
#;(show #t "m-f-v: inner-poly=" inner-poly "\n")
(if (same-variable? inner-var outer-var)
(mul
(make-polynomial outer-var (adjoin-term (make-term outer-order 1) (the-empty-termlist)))
(tag inner-polynomial))
(tag (make-poly inner-var
(mul-term-by-all-terms (make-term
0
(make-polynomial
outer-var
(list (make-term
outer-order
1)))) inner-poly))))))
#;(show #t "TestXX: sorting variables: Is 'x < 'y?: "
(variable_1-order<variable_2-order 'x 'y) "\n")
#;(show #t "TestXX: sorting variables: Is 'z < 'y?: "
(variable_1-order<variable_2-order 'z 'y) "\n")
#;(show #t "TestXX: (adding two basic poly): "
(add (make-polynomial 'x (list (make-term 1 2) (make-term 0 4)))
(make-polynomial 'y (list (make-term 2 3) (make-term 0 5)))) "\n")
(define (polynomial->sum-of-first-and-rest poly)
#;(show #t "p->s-o-f-a-r: " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (first-term (term-list poly1)))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
first-monomial
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test13: Expanding a polynomial as monomials: "
(displayed
(polynomial->sum-of-first-and-rest
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))))) "\n")
(show #t "\nTest20: start monomial: "
(displayed (make-polynomial 'x
(list
(make-term
2
(make-polynomial
'y
(list
(make-term 2 1) (make-term 0 1))))))) "\n")
(show #t "Test20: Flipping a monomial variable: "
(displayed
(monomial-flip-variables
(make-polynomial 'x
(list (make-term 1 (make-polynomial
'y
(list
(make-term 2 1)
(make-term 0 1)))))))) "\n\n")
(define (normal-polynomial? poly)
#;(show #t "n-p?: poly=" poly "\n")
(cond ((not (polynomial? poly)) #t)
((null? (term-list (contents poly))) #t)
(else (let* ((poly1 (contents poly))
(outer-var (variable poly1)))
#;(show #t "Inner-let: outer-var=" (displayed outer-var) "\n")
(let loop ((terms (term-list poly1)))
#;(show #t "n-p?-loop: terms=" (displayed terms) "\n")
(cond ((null? terms) #t)
((not (polynomial? (coeff (first-term terms)))) (loop (rest-terms terms)))
((not (variable_1-order<variable_2-order
outer-var
(variable (contents (coeff (first-term terms)))))) (begin #;(show #t "wrong variable order \n") #f))
((not (normal-polynomial? (coeff (first-term terms)))) (begin #;(show #t "not normal poly\n") #f))
(else (loop (rest-terms terms)))))
))))
(define (normalize-once poly)
#;(show #t "normalize-once poly= " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (make-term
(order (first-term (term-list poly1)))
(if (polynomial? (coeff (first-term (term-list poly1))))
(normalize-once (coeff (first-term (term-list poly1))))
(coeff (first-term (term-list poly1))))))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
(if (and (polynomial?
(coeff
(first-term
(term-list
(contents first-monomial)))))
(variable_1-order<variable_2-order
(variable
(contents
(coeff
(first-term
(term-list
(contents first-monomial))))))
(variable
(contents first-monomial))))
(monomial-flip-variables first-monomial)
first-monomial)
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test21: normal-polynomial?:start: " (displayed (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test21: normal-polynomial?:result:" (normal-polynomial? (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:start: "
(displayed
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test22: normal-polynomial?-good:result:"
(normal-polynomial?
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test23:input: normalizing a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test23:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalizing a bad polynomial: "
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
(show #t "Test24:input: normalize-fully a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
(show #t "Test24:result: normalize-fully a bad polynomial: "
(normalize-fully (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
'done)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
#;(put 'first-term 'dense first-term-dense)
'done)
#;(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(install-polynomial-package)
#;(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
#;(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
#;(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
#;(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
#;(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
#;(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
#;(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
#;(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
#;(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
#;(show #t "Test12: Dividing x^2 + 2x + 1 by x+1: "
(displayed
(div (make-polynomial 'x '((2 1) (1 2) (0 1)))
(make-polynomial 'x '( (1 1) (0 1)))) ) "\n")
#;(show #t "Test14: Adding polynomials of two variables: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))))
#;(show #t "Test14: Adding polynomials of two variables, when one of them is nonexistant: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((0 1))))))
(show #t "Test25: multiplying different variables: "
(displayed (mul (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))) "\n")
(begin
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
(show #t "Test 26: make-rational-polynomial: " rf "\n")
(show #t "Test 27: add-rational\n")
(show #t "Test 27: " (add rf rf) "\n")
)
(show #t "Test 28: polynomial-gcd: start\n")
(define (greatest-common-divisor p1 p2) (apply-generic 'gcd p1 p2))
(begin
(define p1 (make-polynomial
'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2 (make-polynomial 'x '((3 1) (1 -1))))
(show #t "Test 28: polynomial-gcd: " (greatest-common-divisor p1 p2) "\n"))
(begin
(define p1 (make-polynomial
'x '((2 1) (1 -2) (0 1))))
(define p2 (make-polynomial 'x '((2 11) (0 7))))
(define p3 (make-polynomial 'x '((1 13) (0 5))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
(show #t "Test 29: gcd-integer-problem: start\n")
(show #t "Test 29: gcd : " (greatest-common-divisor q1 q2) "\n")
)
#+end_src
#+RESULTS:
#+begin_example
Test: Higher than 'integer: scheme-number
Test 1: Subtracting complex numbers: (scheme-number . 1.1)
TestY2: poly of poly: (x (3 (y (1 1) (0 1))) (1 2) (0 4))
Test13: Expanding a polynomial as monomials: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test20: start monomial: (polynomial x (2 (polynomial y (2 1) (0 1))))
Test20: Flipping a monomial variable: (polynomial y (2 (polynomial x (1 1))) (0 (polynomial x (1 1))))
Test21: normal-polynomial?:start: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test21: normal-polynomial?:result:#f
Test22: normal-polynomial?-good:start: (polynomial x (2 (polynomial y (2 1) (0 1))) (0 2))
Test22: normal-polynomial?-good:result:#t
Test23:input: normalizing a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test23:result: normalizing a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test24:input: normalizing a bad polynomial: (polynomial x (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalizing a bad polynomial: (polynomial x (4 1) (2 1) (0 2))
Test24:input: normalize-fully a bad polynomial: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test24:result: normalize-fully a bad polynomial: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test25: multiplying different variables: (polynomial x (1 (polynomial y (1 1))))
Test 26: make-rational-polynomial: (rational (polynomial x (3 1) (0 1)) polynomial x (2 1) (0 1))
Test 27: add-rational
rational not droppable: #f
Test 27: (rational (polynomial x (5 2) (3 2) (2 2) (0 2)) polynomial x (4 1) (2 2) (0 1))
Test 28: polynomial-gcd: start
gcd-terms: (term-list b)=((1 -1))
gcd-terms: (term-list b)=((1 1))
Test 28: polynomial-gcd: (polynomial x (2 -1) (1 1))
Test 29: gcd-integer-problem: start
gcd-terms: (term-list b)=((2 -21) (1 3) (0 5))
gcd-terms: (term-list b)=((1 (scheme-number . -17.254437869822485)) (0 (scheme-number . 8.627218934911243)))
gcd-terms: (term-list b)=((0 (scheme-number . 7.993605777301127e-15)))
gcd-terms: (term-list b)=()
Test 29: gcd : (polynomial x (0 (scheme-number . 1.100410578432558)))
#+end_example
The answer is a polynomial \(x^0 \times 1.100410578432558\), which is
essentially just a number. Clearly, this is not the greatest common
divisor. I believe, this problem happens because at some point, the
comparison "(if (= 0 b))" fails, because b is very small, but still nonzero
due to precision problems. In principle, this should be possible to fix by
carefully studying the algorithm and ensuring that every operation in
"div-terms" preserves exactness. Still, this should give a polynomial with
very long coefficients.
When I was doing the manual repetition of the algorithm, I found that the
numerators and denominators of the numbers grow very fast, so it quickly
becomes very hard to operate with these numbers.
*** DONE Exercise 2.96 Integerizing factor
CLOSED: [2019-10-28 Mon 19:23]
This is not a very hard exercise. The only problem here is still the messy
part in the division by the gcd, but hey, formally the exercise is done.
#+begin_src scheme :exports both :results output
(define (thingy-source thingy)
(cond ((lambda? thingy) (list "lambda" (lambda-source thingy)))
((procedure? thingy) (list "procedure" (procedure-name thingy)))
((pair? thingy) (list "pair" (pair-source thingy)))
(else "No source? refactor")))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y)
#;(show #t "debug:add: x=" x ", y=" y ", starting apply-generic\n")
#;(show #t "debug:add: (type-tags x,y)=(" (type-tag x) "," (type-tag y) ")" "\n")
#;(show #t "debug:add:can we access apply-generic?" (written apply-generic)
"\n" )
#;(error "Debug1")
(apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
#;(attach-tag 'scheme-number x) x)
(show #t "(tag 5)=" (tag 5) "\n")
(put 'add '(scheme-number scheme-number)
(lambda (x y) #;(show #t "debug:found plus dispatch\n") (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) #;(show #t "debug:found 'make 'scheme-number\n") (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(if (finite? x)
(exact (truncate x))
0)))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(install-scheme-number-package)
(define (integer->scheme-number x)
(make-scheme-number (inexact (contents x))))
(put-coercion 'integer 'scheme-number integer->scheme-number)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
#;(show #t "debug:make-scheme-number: n=" n "\n")
((get 'make 'scheme-number) n))
#;(check (+ 1 1) => 2)
(show #t "Test 31: start\n")
(show #t "Test 31:" (equal? (make-scheme-number 1) 1) "\n")
#;(check (add (make-scheme-number 1) (make-scheme-number 1)) => 2)
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
#;(let ((g (gcd n d)))
(cons (/ n g) (/ d g)))
(cons n d))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (sub (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (mul (numer x) (numer y))
(mul (denom x) (denom y))))
(define (div-rat x y)
(make-rat (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (zero? (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (zero? (numer x))))
#;(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
#;(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (polynomial? x)
(eq? (type-tag x) 'polynomial))
(define numeric-tower (list 'integer 'scheme-number 'complex))
(define (numeric? x)
(memq x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (comparable? type1 type2)
(and (memq type1 numeric-tower)
(memq type2 numeric-tower)))
(define (raise-type x)
#;(show #t "Raising type of: " (displayed x) "\n")
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (higher-type x)
(let ((tail (memq x numeric-tower)))
(cond ((eq? #f tail) (error "Type not in the tower" x))
((null? (cdr tail)) (error "Already the highest type:" x))
(else (cadr tail)))))
(show #t "Test: Higher than 'integer: " (higher-type 'integer) "\n")
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
#;(show #t "droppable?: obj=" obj ", type-tag=" (type-tag obj) "\n")
(cond ((eq? (type-tag obj) 'rational) (begin (show #t "rational not droppable: #f\n") #f))
((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(define (apply-generic op . args)
#;(show #t "apply-generic:entry\n")
#;(error "debug")
(define (variable poly) (car poly))
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
#;(show #t "apply-generic: type-tags="
(displayed type-tags)
" proc=" (written proc)
" proc-source=" (thingy-source proc) "\n")
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags ", arg=" (displayed args) "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(cond ((and (eq? 'polynomial (car type-tags))
(numeric? (cadr type-tags)))
(apply-generic op
(car args)
(make-polynomial (variable (contents (car args)))
(list (list 0 (cadr args))))))
((and (numeric? (car type-tags))
(eq? 'polynomial (cadr type-tags)))
(apply-generic op
(make-polynomial (variable (contents (cadr args)))
(list (list 0 (car args))))
(cadr args)))
((and (get-coercion (car type-tags) (cadr type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
((get-coercion
(car type-tags)
(cadr type-tags)) (car args))
(cadr args)))
((and (get-coercion (cadr type-tags) (car type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
(car args)
((get-coercion
(cadr type-tags)
(car type-tags)) (cadr args) )))
((comparable? (car type-tags) (cadr type-tags))
(if
(type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
(else (error "apply-generic:Incomparable types: (type-tags,args)=" type-tags args))))
((and (> (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(show #t "Test 30: start\n")
(show #t "Test 30:(add (make-scheme-number 1) (make-scheme-number 1))= "
(add (make-scheme-number 1) (make-scheme-number 1)) "\n")
#;(error "Debug6")
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(show #t "Test 32: start")
(show #t "Test 32: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
#;(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
#;(define (higher-type x)
(show #t "higher-type:x=" (displayed x) "\n")
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x types))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
#;(show #t "Test: Higher than 'complex: " (higher-type 'complex) "\n")
#;(define (integer->rational x)
(make-rational x 1))
#;(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
#;(put-coercion 'integer 'rational integer->rational)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (install-polynomial-package)
#;(define (contents generic-object)
(cdr generic-object))
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
#;(continued on next page)
(define (add-poly p1 p2)
#;(show #t "add-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(let ((res (cdr (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(add (tag p1) (tag (make-poly (variable p1) (list (make-term 0 (tag p2))))))
(add (tag (make-poly (variable p2) (list (make-term 0 (tag p1))))) (tag p2))))))
#;(show #t "add-poly:result: " (displayed res) "\n") res)))
(show #t "TestY2: poly of poly: "
(make-poly 'x (list
(make-term 3 (make-poly
'y (list (make-term 1 1) (make-term 0 1))))
(make-term 1 2)
(make-term 0 4))) "\n")
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(contents (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(mul (tag p1)
(make-polynomial (variable p1)
(adjoin-term
(make-term 0
(tag p2)) (the-empty-termlist))))
(mul (tag p2)
(make-polynomial (variable p2)
(adjoin-term
(make-term 0
(tag p1)) (the-empty-termlist))))))
#;(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(let ((quotient-and-remainder (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car quotient-and-remainder))
(make-poly (variable p1) (cadr quotient-and-remainder))))
(error "div-poly: Polys not in the same var" p1 p2)))
(define (div-terms L1 L2)
(show #t "div-terms: L1=" L1 ", L2=" L2 "\n")
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (term-list
(sub-poly
(make-poly 'fake-var L1)
(mul-poly
(make-poly 'fake-var (list (make-term new-o new-c)))
(make-poly 'fake-var L2))))
L2)
))
#;(show #t "div-terms: rest-of-result: " (displayed rest-of-result) "\n")
(list (adjoin-term (make-term new-o new-c) (car rest-of-result)) (cadr rest-of-result))
))))))
(define (gcd-terms a b)
(show #t "gcd-terms: a=" a ", b=" b "\n")
(if (empty-termlist? b)
a
(gcd-terms b (pseudoremainder-terms a b))))
(define (pseudoremainder-terms P Q)
(let ((O1 (order (first-term P)))
(O2 (order (first-term Q)))
(c (coeff (first-term Q))))
(show #t "pseudoremainder-terms: P=" P "\n")
(show #t "pseudoremainder-terms: Q=" Q "\n")
(show #t "pseudoremainder-terms: O1=" O1 "\n")
(show #t "pseudoremainder-terms: O2=" O2 "\n")
(show #t "pseudoremainder-terms: c=" c "\n")
(show #t "pseudoremainder-terms: the integerizing factor="
(make-term 0 (exp c (add 1 (sub O1 O2)))) "\n" )
(show #t "pseudoremainder-terms: P after multiplication="
(mul-term-by-all-terms
(make-term 0 (exp c (add 1 (sub O1 O2)))) P) "\n" )
(cadr (div-terms (mul-term-by-all-terms
(make-term 0 (exp c (add 1 (sub O1 O2)))) P) Q))))
(define (gcd-poly p1 p2)
(show #t "gcd-poly:p1=" p1 ", p2=" p2 "\n")
(define (maprest operation term-list)
(if (empty-termlist? term-list)
'()
(cons (operation term-list) (maprest operation (rest-terms term-list))))
)
(if (same-variable? (variable p1) (variable p2))
(let* ((unoptimized-termlist (gcd-terms (term-list p1) (term-list p2)))
(first-terms (maprest first-term unoptimized-termlist))
(coefficients (map coeff first-terms))
(coeff-gcd (apply gcd coefficients))
(optimized-termlist (mul-term-by-all-terms
(make-term 0 (div 1 coeff-gcd)) unoptimized-termlist)))
(show #t "gcd-poly: unoptimized-termlist=" unoptimized-termlist "\n")
(show #t "gcd-poly: first-terms=" first-terms "\n")
(show #t "gcd-poly: coefficients=" coefficients "\n")
(show #t "gcd-poly: coeff-gcd=" coeff-gcd "\n")
(make-poly (variable p1) optimized-termlist))
(error "div-poly: Polys not in the same var" p1 p2)))
(put 'gcd '(polynomial polynomial)
(lambda (x y) (tag (gcd-poly x y))))
(put 'gcd '(integer integer) gcd)
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (zero-poly? poly)
(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (zero? (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
((get 'first-term (termlist-type-of term-list)) term-list))
(define (variable_1-order<variable_2-order variable_1 variable_2)
#;(show #t "var_1-..: variable_1=" variable_1 " variable_2=" variable_2 "\n")
#;(show #t "var12string=" (symbol->string variable_1) "var22string=" (symbol->string variable_2) "\n")
(string<=? (symbol->string variable_1) (symbol->string variable_2)))
(define (normalize-fully poly)
(if (normal-polynomial? poly)
poly
(normalize-fully (normalize-once poly))))
(put 'add '(polynomial polynomial)
(lambda (p1 p2)
#;(show #t "generic-add-poly:Polynomial dispatch found: p1="
(displayed p1) " p2=" (displayed p2) "\n")
(normalize-fully (tag (add-poly p1 p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (normalize-fully (tag (mul-poly p1 p2)))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'zero? '(polynomial) zero-poly?)
(put 'div '(polynomial polynomial) div-poly)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (monomial-flip-variables monomial)
#;(show #t "m-f-v: monomial=" monomial "\n")
(let* ((mono (contents monomial))
(inner-polynomial (contents (coeff (first-term (term-list mono)))))
(inner-poly (contents inner-polynomial))
(outer-order (order (first-term (term-list mono))))
(outer-var (variable mono))
(inner-var (variable inner-polynomial))
(inner-term-list (term-list inner-poly)))
#;(show #t "m-f-v: inner-poly=" inner-poly "\n")
(if (same-variable? inner-var outer-var)
(mul
(make-polynomial outer-var (adjoin-term (make-term outer-order 1) (the-empty-termlist)))
(tag inner-polynomial))
(tag (make-poly inner-var
(mul-term-by-all-terms (make-term
0
(make-polynomial
outer-var
(list (make-term
outer-order
1)))) inner-poly))))))
#;(show #t "TestXX: sorting variables: Is 'x < 'y?: "
(variable_1-order<variable_2-order 'x 'y) "\n")
#;(show #t "TestXX: sorting variables: Is 'z < 'y?: "
(variable_1-order<variable_2-order 'z 'y) "\n")
#;(show #t "TestXX: (adding two basic poly): "
(add (make-polynomial 'x (list (make-term 1 2) (make-term 0 4)))
(make-polynomial 'y (list (make-term 2 3) (make-term 0 5)))) "\n")
(define (polynomial->sum-of-first-and-rest poly)
#;(show #t "p->s-o-f-a-r: " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (first-term (term-list poly1)))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
first-monomial
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test13: Expanding a polynomial as monomials: "
(displayed
(polynomial->sum-of-first-and-rest
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))))) "\n")
(show #t "\nTest20: start monomial: "
(displayed (make-polynomial 'x
(list
(make-term
2
(make-polynomial
'y
(list
(make-term 2 1) (make-term 0 1))))))) "\n")
(show #t "Test20: Flipping a monomial variable: "
(displayed
(monomial-flip-variables
(make-polynomial 'x
(list (make-term 1 (make-polynomial
'y
(list
(make-term 2 1)
(make-term 0 1)))))))) "\n\n")
(define (normal-polynomial? poly)
#;(show #t "n-p?: poly=" poly "\n")
(cond ((not (polynomial? poly)) #t)
((null? (term-list (contents poly))) #t)
(else (let* ((poly1 (contents poly))
(outer-var (variable poly1)))
#;(show #t "Inner-let: outer-var=" (displayed outer-var) "\n")
(let loop ((terms (term-list poly1)))
#;(show #t "n-p?-loop: terms=" (displayed terms) "\n")
(cond ((null? terms) #t)
((not (polynomial? (coeff (first-term terms)))) (loop (rest-terms terms)))
((not (variable_1-order<variable_2-order
outer-var
(variable (contents (coeff (first-term terms)))))) (begin #;(show #t "wrong variable order \n") #f))
((not (normal-polynomial? (coeff (first-term terms)))) (begin #;(show #t "not normal poly\n") #f))
(else (loop (rest-terms terms)))))
))))
(define (normalize-once poly)
#;(show #t "normalize-once poly= " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (make-term
(order (first-term (term-list poly1)))
(if (polynomial? (coeff (first-term (term-list poly1))))
(normalize-once (coeff (first-term (term-list poly1))))
(coeff (first-term (term-list poly1))))))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
(if (and (polynomial?
(coeff
(first-term
(term-list
(contents first-monomial)))))
(variable_1-order<variable_2-order
(variable
(contents
(coeff
(first-term
(term-list
(contents first-monomial))))))
(variable
(contents first-monomial))))
(monomial-flip-variables first-monomial)
first-monomial)
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test21: normal-polynomial?:start: " (displayed (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test21: normal-polynomial?:result:" (normal-polynomial? (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test22: normal-polynomial?-good:start: "
(displayed
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test22: normal-polynomial?-good:result:"
(normal-polynomial?
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test23:input: normalizing a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
#;(show #t "Test23:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test24:input: normalizing a bad polynomial: "
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
#;(show #t "Test24:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test24:input: normalize-fully a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
#;(show #t "Test24:result: normalize-fully a bad polynomial: "
(normalize-fully (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
'done)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
(put 'first-term 'dense first-term-dense)
'done)
#;(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(install-polynomial-package)
(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
#;(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
#;(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
#;(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
#;(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
(show #t "Test12: Dividing x^2 + 2x + 1 by x+1: "
(displayed
(div (make-polynomial 'x '((2 1) (1 2) (0 1)))
(make-polynomial 'x '( (1 1) (0 1)))) ) "\n")
(show #t "Test14: Adding polynomials of two variables: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))))
(show #t "Test14: Adding polynomials of two variables, when one of them is nonexistant: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((0 1))))))
(show #t "Test25: multiplying different variables: "
(displayed (mul (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))) "\n")
(begin
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
(show #t "Test 26: make-rational-polynomial: " rf "\n")
(show #t "Test 27: add-rational\n")
(show #t "Test 27: " (add rf rf) "\n")
)
(show #t "Test 28: polynomial-gcd: start\n")
(define (greatest-common-divisor p1 p2) (apply-generic 'gcd p1 p2))
(begin
(define p1 (make-polynomial
'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2 (make-polynomial 'x '((3 1) (1 -1))))
(show #t "Test 28: polynomial-gcd: " (greatest-common-divisor p1 p2) "\n"))
(begin
(define p1 (make-polynomial
'x '((2 1) (1 -2) (0 1))))
(define p2 (make-polynomial 'x '((2 11) (0 7))))
(define p3 (make-polynomial 'x '((1 13) (0 5))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
(show #t "Test 29: gcd-integer-problem: start\n")
(show #t "Test 29: p1=" p1 "\n")
(show #t "Test 29: p2=" p2 "\n")
(show #t "Test 29: p3=" p3 "\n")
(show #t "Test 29: q1=" q1 "\n")
(show #t "Test 29: q2=" q2 "\n")
(show #t "Test 29: gcd : " (greatest-common-divisor q1 q2) "\n")
)
#+end_src
#+RESULTS:
#+begin_example
(tag 5)=5
Test 31: start
Test 31:#t
Test: Higher than 'integer: scheme-number
Test 30: start
Test 30:(add (make-scheme-number 1) (make-scheme-number 1))= 2
Test 32: startTest 32: Subtracting complex numbers: 1.1
TestY2: poly of poly: (x (3 (y (1 1) (0 1))) (1 2) (0 4))
zero-poly?: poly=(y (2 (polynomial x (2 1) (0 1))) (0 2))
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(y (0 2))
zero-poly?: poly=(y)
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(y (2 (polynomial x (2 1) (0 1))) (0 2))
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(x (0 1))
zero-poly?: poly=(x)
zero-poly?: poly=(y (0 2))
zero-poly?: poly=(y)
zero-poly?: poly=(y (2 1))
zero-poly?: poly=(y (2 1))
zero-poly?: poly=(y (2 1) (0 2))
zero-poly?: poly=(y (2 1))
Test13: Expanding a polynomial as monomials: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test20: start monomial: (polynomial x (2 (polynomial y (2 1) (0 1))))
zero-poly?: poly=(x (1 1))
zero-poly?: poly=(x (1 1))
Test20: Flipping a monomial variable: (polynomial y (2 (polynomial x (1 1))) (0 (polynomial x (1 1))))
Test21: normal-polynomial?:start: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test 2: Making polynomials: (polynomial x (5 1) (4 2))
zero-poly?: poly=(x (5 1) (4 2))
Test 3: Zero?: #f
Test 4: Adding polynomials: (polynomial x (5 2) (4 2) (0 1))
zero-poly?: poly=(x (5 0) (3 1))
zero-poly?: poly=(x (3 1))
Test 4: Zero?: #f
Test 5: Subtracting polynomials: (polynomial x (5 1) (4 2))
div-terms: L1=((2 1) (1 2) (0 1)), L2=((1 1) (0 1))
div-terms: L1=((1 1) (0 1)), L2=((1 1) (0 1))
div-terms: L1=(), L2=((1 1) (0 1))
Test12: Dividing x^2 + 2x + 1 by x+1: ((x (1 1) (0 1)) (x))
Test14: Adding polynomials of two variables: (polynomial x (1 1) (0 (polynomial y (1 1))))Test14: Adding polynomials of two variables, when one of them is nonexistant: (polynomial x (1 1) (0 (polynomial y (0 1))))zero-poly?: poly=(y (1 1))
zero-poly?: poly=(y (1 1))
Test25: multiplying different variables: (polynomial x (1 (polynomial y (1 1))))
Test 26: make-rational-polynomial: (rational (polynomial x (3 1) (0 1)) polynomial x (2 1) (0 1))
Test 27: add-rational
rational not droppable: #f
Test 27: (rational (polynomial x (5 2) (3 2) (2 2) (0 2)) polynomial x (4 1) (2 2) (0 1))
Test 28: polynomial-gcd: start
gcd-poly:p1=(x (4 1) (3 -1) (2 -2) (1 2)), p2=(x (3 1) (1 -1))
gcd-terms: a=((4 1) (3 -1) (2 -2) (1 2)), b=((3 1) (1 -1))
pseudoremainder-terms: P=((4 1) (3 -1) (2 -2) (1 2))
pseudoremainder-terms: Q=((3 1) (1 -1))
pseudoremainder-terms: O1=4
pseudoremainder-terms: O2=3
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((4 1) (3 -1) (2 -2) (1 2))
div-terms: L1=((4 1) (3 -1) (2 -2) (1 2)), L2=((3 1) (1 -1))
div-terms: L1=((3 -1) (2 -1) (1 2)), L2=((3 1) (1 -1))
div-terms: L1=((2 -1) (1 1)), L2=((3 1) (1 -1))
gcd-terms: a=((3 1) (1 -1)), b=((2 -1) (1 1))
pseudoremainder-terms: P=((3 1) (1 -1))
pseudoremainder-terms: Q=((2 -1) (1 1))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=-1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((3 1) (1 -1))
div-terms: L1=((3 1) (1 -1)), L2=((2 -1) (1 1))
div-terms: L1=((2 1) (1 -1)), L2=((2 -1) (1 1))
div-terms: L1=(), L2=((2 -1) (1 1))
gcd-terms: a=((2 -1) (1 1)), b=()
gcd-poly: unoptimized-termlist=((2 -1) (1 1))
gcd-poly: first-terms=((2 -1) (1 1))
gcd-poly: coefficients=(-1 1)
gcd-poly: coeff-gcd=1
Test 28: polynomial-gcd: (polynomial x (2 -1) (1 1))
Test 29: gcd-integer-problem: start
Test 29: p1=(polynomial x (2 1) (1 -2) (0 1))
Test 29: p2=(polynomial x (2 11) (0 7))
Test 29: p3=(polynomial x (1 13) (0 5))
Test 29: q1=(polynomial x (4 11) (3 -22) (2 18) (1 -14) (0 7))
Test 29: q2=(polynomial x (3 13) (2 -21) (1 3) (0 5))
gcd-poly:p1=(x (4 11) (3 -22) (2 18) (1 -14) (0 7)), p2=(x (3 13) (2 -21) (1 3) (0 5))
gcd-terms: a=((4 11) (3 -22) (2 18) (1 -14) (0 7)), b=((3 13) (2 -21) (1 3) (0 5))
pseudoremainder-terms: P=((4 11) (3 -22) (2 18) (1 -14) (0 7))
pseudoremainder-terms: Q=((3 13) (2 -21) (1 3) (0 5))
pseudoremainder-terms: O1=4
pseudoremainder-terms: O2=3
pseudoremainder-terms: c=13
pseudoremainder-terms: the integerizing factor=(0 169)
pseudoremainder-terms: P after multiplication=((4 1859) (3 -3718) (2 3042) (1 -2366) (0 1183))
div-terms: L1=((4 1859) (3 -3718) (2 3042) (1 -2366) (0 1183)), L2=((3 13) (2 -21) (1 3) (0 5))
div-terms: L1=((3 -715) (2 2613) (1 -3081) (0 1183)), L2=((3 13) (2 -21) (1 3) (0 5))
div-terms: L1=((2 1458) (1 -2916) (0 1458)), L2=((3 13) (2 -21) (1 3) (0 5))
gcd-terms: a=((3 13) (2 -21) (1 3) (0 5)), b=((2 1458) (1 -2916) (0 1458))
pseudoremainder-terms: P=((3 13) (2 -21) (1 3) (0 5))
pseudoremainder-terms: Q=((2 1458) (1 -2916) (0 1458))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=1458
pseudoremainder-terms: the integerizing factor=(0 2125764)
pseudoremainder-terms: P after multiplication=((3 27634932) (2 -44641044) (1 6377292) (0 10628820))
div-terms: L1=((3 27634932) (2 -44641044) (1 6377292) (0 10628820)), L2=((2 1458) (1 -2916) (0 1458))
div-terms: L1=((2 10628820) (1 -21257640) (0 10628820)), L2=((2 1458) (1 -2916) (0 1458))
div-terms: L1=(), L2=((2 1458) (1 -2916) (0 1458))
gcd-terms: a=((2 1458) (1 -2916) (0 1458)), b=()
gcd-poly: unoptimized-termlist=((2 1458) (1 -2916) (0 1458))
gcd-poly: first-terms=((2 1458) (1 -2916) (0 1458))
gcd-poly: coefficients=(1458 -2916 1458)
gcd-poly: coeff-gcd=1458
Test 29: gcd : (polynomial x (2 0.9999999999999999) (1 -1.9999999999999998) (0 0.9999999999999999))
#+end_example
We unfortunately, there is an error with exact-inexact numbers somewhere
here. I am too tired to fix it, but this should be doable. Let me say, I'd
also leave it as an exercise to the reader.
*** DONE Exercise 2.97 Reduction of polynomials
CLOSED: [2019-10-29 Tue 00:12]
Here is the solution of the exercise. I have to copy the code again, because
implementing term reduction requires extending the polynomial package.
#+begin_src scheme :exports both :results output
(define (thingy-source thingy)
(cond ((lambda? thingy) (list "lambda" (lambda-source thingy)))
((procedure? thingy) (list "procedure" (procedure-name thingy)))
((pair? thingy) (list "pair" (pair-source thingy)))
(else "No source? refactor")))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(accumulate op (op initial (car sequence)) (cdr sequence))))
(define false #f)
(define true #t)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(cond ((pair? datum) (car datum))
((exact-integer? datum) 'integer)
((real? datum) 'scheme-number)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(cond ((pair? datum) (cdr datum))
((integer? datum) datum)
((real? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (integer? x)
(eq? (type-tag x) 'integer))
(define (rectangular? z)
(eq? (type-tag z) 'rectangular))
(define (polar? z)
(eq? (type-tag z) 'polar))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
(define (add x y)
#;(show #t "debug:add: x=" x ", y=" y ", starting apply-generic\n")
#;(show #t "debug:add: (type-tags x,y)=(" (type-tag x) "," (type-tag y) ")" "\n")
#;(show #t "debug:add:can we access apply-generic?" (written apply-generic)
"\n" )
#;(error "Debug1")
(apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y)
(apply-generic 'equ? x y))
(define (zero? x) (apply-generic 'zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (install-scheme-number-package)
(define (tag x)
#;(attach-tag 'scheme-number x) x)
(show #t "(tag 5)=" (tag 5) "\n")
(put 'add '(scheme-number scheme-number)
(lambda (x y) #;(show #t "debug:found plus dispatch\n") (tag (+ x y))))
(put 'sub '(scheme-number scheme-number)
(lambda (x y) (tag (- x y))))
(put 'mul '(scheme-number scheme-number)
(lambda (x y) (tag (* x y))))
(put 'div '(scheme-number scheme-number)
(lambda (x y) (tag (/ x y))))
(put 'make 'scheme-number
(lambda (x) #;(show #t "debug:found 'make 'scheme-number\n") (tag x)))
(put 'equ? '(scheme-number scheme-number)
(lambda (x y) (= x y)))
(put 'zero? '(scheme-number)
(lambda (x) (= 0 x)))
(put 'exp '(scheme-number scheme-number)
(lambda (x y) (tag (expt x y))))
(put 'project '(scheme-number)
(lambda (x)
(if (finite? x)
(exact (truncate x))
0)))
(put 'sine '(scheme-number) sin)
(put 'cosine '(scheme-number) cos)
(put 'square-root '(scheme-number) sqrt)
(put 'arctangent '(schemer-number) atan)
'done)
(install-scheme-number-package)
(define (integer->scheme-number x)
(make-scheme-number (inexact (contents x))))
(put-coercion 'integer 'scheme-number integer->scheme-number)
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (square-root x) (apply-generic 'square-root x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (make-scheme-number n)
#;(show #t "debug:make-scheme-number: n=" n "\n")
((get 'make 'scheme-number) n))
#;(check (+ 1 1) => 2)
(show #t "Test 31: start\n")
(show #t "Test 31:" (equal? (make-scheme-number 1) 1) "\n")
#;(check (add (make-scheme-number 1) (make-scheme-number 1)) => 2)
(define (install-rational-package)
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (make-rat n d)
(show #t "make-rat: n=" n ", d="d "\n")
#;(let ((g (gcd n d)))
(cons (/ n g) (/ d g)))
(let ((new-list (reduce n d)))
(cons (car new-list) (cadr new-list))))
(define (add-rat x y)
(make-rat (add (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (sub-rat x y)
(make-rat (sub (mul (numer x) (denom y))
(mul (numer y) (denom x)))
(mul (denom x) (denom y))))
(define (mul-rat x y)
(make-rat (mul (numer x) (numer y))
(mul (denom x) (denom y))))
(define (div-rat x y)
(make-rat (mul (numer x) (denom y))
(mul (denom x) (numer y))))
(define (tag x) (attach-tag 'rational x))
(put 'add '(rational rational)
(lambda (x y) (tag (add-rat x y))))
(put 'sub '(rational rational)
(lambda (x y) (tag (sub-rat x y))))
(put 'mul '(rational rational)
(lambda (x y) (tag (mul-rat x y))))
(put 'div '(rational rational)
(lambda (x y) (tag (div-rat x y))))
(put 'make 'rational
(lambda (n d) (tag (make-rat n d))))
(put 'equ? '(rational rational)
(lambda (x y) (zero? (numer (sub-rat x y)))))
(put 'zero? '(rational) (lambda (x) (zero? (numer x))))
#;(put 'project '(rational) (lambda (x)
(exact (truncate (/ (numer x) (denom x))))))
#;(put 'to-real '(rational) (lambda (x) (/ (numer (contents x)) (denom (contents x)))))
'done)
(define (make-rational n d)
((get 'make 'rational) n d))
(define (install-rectangular-package)
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y) (cons x y))
(define (magnitude z)
(square-root (add (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(arctangent (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (mul r (cosine a)) (mul r (sine a))))
(define (tag x) (attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-polar-package)
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(mul (magnitude z) (cosine (angle z))))
(define (imag-part z)
(mul (magnitude z) (sine (angle z))))
(define (make-from-real-imag x y)
(cons (square-root (add (square x) (square y)))
(arctangent y x)))
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a) (tag (make-from-mag-ang r a))))
'done)
(define (install-complex-package)
(define (make-from-real-imag x y)
((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar) r a))
(define (add-complex z1 z2)
(make-from-real-imag (add (real-part z1) (real-part z2))
(add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag (sub (real-part z1) (real-part z2))
(sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang (mul (magnitude z1) (magnitude z2))
(add (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang (div (magnitude z1) (magnitude z2))
(sub (angle z1) (angle z2))))
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2) (tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2) (tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2) (tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2) (tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y) (tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a) (tag (make-from-mag-ang r a))))
(put 'equ? '(complex complex)
(lambda (x y) (and (= 0 (real-part (sub-complex x y)))
(= 0 (imag-part (sub-complex x y))))))
(put 'equ? '(rectangular polar) equ?)
(put 'equ? '(polar rectangular) equ?)
(put 'zero? '(complex)
(lambda (x) (equ? (tag x) (tag (make-from-real-imag 0 0)))))
(put 'project '(complex) (lambda (z) (real-part z)))
'done)
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-rational-package)
(install-complex-package)
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(define (polynomial? x)
(eq? (type-tag x) 'polynomial))
(define numeric-tower (list 'integer 'scheme-number 'complex))
(define (numeric? x)
(memq x numeric-tower))
(define (type1<=type2? type1 type2)
(if (not (memq type1 numeric-tower))
(error "Type 1 not in the numeric tower"))
(if (not (memq type2 numeric-tower))
(error "Type 2 not in the numeric tower"))
(let loop ((types numeric-tower))
(cond ((null? types) (error "Type 1 and type 2 are incomparable" type1 type2))
((eq? (car types) type1) #t)
((eq? (car types) type2) #f)
(else (loop (cdr types))))))
(define (comparable? type1 type2)
(and (memq type1 numeric-tower)
(memq type2 numeric-tower)))
(define (raise-type x)
#;(show #t "Raising type of: " (displayed x) "\n")
(let ((converter (get-coercion (type-tag x) (higher-type (type-tag x)))))
(if converter
(converter x)
(error "No coercion found for x" (type-tag x) x))))
(define (higher-type x)
(let ((tail (memq x numeric-tower)))
(cond ((eq? #f tail) (error "Type not in the tower" x))
((null? (cdr tail)) (error "Already the highest type:" x))
(else (cadr tail)))))
(show #t "Test: Higher than 'integer: " (higher-type 'integer) "\n")
(define (remainder-integer a b)
(when (or (not (integer? a)) (not (integer? b)))
(error "Arguments must be integers" a b))
(remainder a b))
(put 'remainder '(integer integer) remainder-integer)
(define (remainder-generalized a b) (apply-generic 'remainder a b))
(define (project obj)
(apply-generic 'project obj))
(define (droppable? obj)
#;(show #t "droppable?: obj=" obj ", type-tag=" (type-tag obj) "\n")
(cond ((eq? (type-tag obj) 'rational) (begin (show #t "rational not droppable: #f\n") #f))
((not (memq (type-tag obj) numeric-tower)) #f)
((eq? (type-tag obj) (car numeric-tower)) #f)
((equ? obj (raise-type (project obj))) #t)
(else #f)))
(define (drop obj)
(if (droppable? obj)
(drop (project obj))
obj))
(define (apply-generic op . args)
#;(show #t "apply-generic:entry\n")
#;(error "debug")
(define (variable poly) (car poly))
(define (all-argtypes-same? . args)
(let ((type (type-tag (car args))))
(accumulate (lambda (x y) (and x y)) #t (map (lambda (x) (eq? type x)) args))))
(define (coercion-if-exists? type arg-tags)
(let ((coercion-list (map (lambda (x)
(if (eq? type x)
identity
(get-coercion x type))) arg-tags)))
(if (accumulate (lambda (x y) (and x y)) #t coercion-list)
coercion-list
#f)))
(drop (let* ((type-tags (map type-tag args))
(proc (get op type-tags)))
#;(show #t "apply-generic: type-tags="
(displayed type-tags)
" proc=" (written proc)
" proc-source=" (thingy-source proc) "\n")
(cond (proc (apply proc (map contents args)))
((= 1 (length args))
#;(show #t "No proc found for op=" op ", type-tags=" type-tags ", arg=" (displayed args) "\n")
(apply-generic op (raise-type (car args))))
((= 2 (length args))
(cond ((and (eq? 'polynomial (car type-tags))
(numeric? (cadr type-tags)))
(apply-generic op
(car args)
(make-polynomial (variable (contents (car args)))
(list (list 0 (cadr args))))))
((and (numeric? (car type-tags))
(eq? 'polynomial (cadr type-tags)))
(apply-generic op
(make-polynomial (variable (contents (cadr args)))
(list (list 0 (car args))))
(cadr args)))
((and (get-coercion (car type-tags) (cadr type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
((get-coercion
(car type-tags)
(cadr type-tags)) (car args))
(cadr args)))
((and (get-coercion (cadr type-tags) (car type-tags))
(not (eq? (car type-tags) (cadr type-tags))))
(apply-generic op
(car args)
((get-coercion
(cadr type-tags)
(car type-tags)) (cadr args) )))
((comparable? (car type-tags) (cadr type-tags))
(if
(type1<=type2? (car type-tags) (cadr type-tags))
(apply-generic op (raise-type (car args)) (cadr args))
(apply-generic op (car args) (raise-type (cadr args)))))
(else (error "apply-generic:Incomparable types: (type-tags,args)=" type-tags args))))
((and (> (length args) 2) (not (all-argtypes-same? args)))
(let types-loop ((types type-tags))
(let ((list-of-coercion-functions
(coercion-if-exists? (car types) type-tags)))
(if list-of-coercion-functions
(apply apply-generic (cons op (map (lambda (fun arg) (fun arg))
list-of-coercion-functions
args)))
(if (not (null? (cdr types)))
(types-loop (cdr types))
(error "apply-generic:Even coercions failed. No method for these types."))))))
(else (error "apply-generic:No method for these types"
(list op type-tags)))))))
(show #t "Test 30: start\n")
(show #t "Test 30:(add (make-scheme-number 1) (make-scheme-number 1))= "
(add (make-scheme-number 1) (make-scheme-number 1)) "\n")
#;(error "Debug6")
(define (scheme-number->complex n)
(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number
'complex
scheme-number->complex)
(show #t "Test 32: start")
(show #t "Test 32: Subtracting complex numbers: "
(sub
(make-complex-from-real-imag 1.1 2)
(make-complex-from-real-imag 0 2)) "\n")
(put 'max3-magnitude '(complex complex complex) (lambda (z1 z2 z3)
(max (magnitude z1) (magnitude z2) (magnitude z3))))
(define (max3-magnitude x1 x2 x3) (apply-generic 'max3-magnitude x1 x2 x3))
(define (identity x) x)
#;(define numeric-tower (list 'integer 'rational 'scheme-number 'complex))
#;(define (higher-type x)
(show #t "higher-type:x=" (displayed x) "\n")
(define (find-higher-type x types)
(cond ((or (null? types) (null? (cdr types))) (error "No type higher than given" x types))
((eq? x (car types)) (cadr types))
(else (find-higher-type x (cdr types)))))
(find-higher-type x numeric-tower))
#;(show #t "Test: Higher than 'complex: " (higher-type 'complex) "\n")
#;(define (integer->rational x)
(make-rational x 1))
#;(define (rational->scheme-number x)
(make-scheme-number ((get 'to-real '(rational)) x)))
#;(put-coercion 'integer 'rational integer->rational)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (reduce-integers n d)
(let ((g (gcd n d)))
(list (/ n g) (/ d g))))
(put 'reduce '(integer integer) reduce-integers)
(define (reduce a b) (apply-generic 'reduce a b))
(define (install-polynomial-package)
#;(define (contents generic-object)
(cdr generic-object))
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p)
(cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
(and (number? exp) (= exp num)))
(define (the-empty-termlist) '())
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (tag p) (attach-tag 'polynomial p))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
#;(continued on next page)
(define (add-poly p1 p2)
#;(show #t "add-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(add-terms (term-list p1)
(term-list p2)))
(let ((res (cdr (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(add (tag p1) (tag (make-poly (variable p1) (list (make-term 0 (tag p2))))))
(add (tag (make-poly (variable p2) (list (make-term 0 (tag p1))))) (tag p2))))))
#;(show #t "add-poly:result: " (displayed res) "\n") res)))
(show #t "TestY2: poly of poly: "
(make-poly 'x (list
(make-term 3 (make-poly
'y (list (make-term 1 1) (make-term 0 1))))
(make-term 1 2)
(make-term 0 4))) "\n")
(define (sub-poly p1 p2)
(add-poly p1 (mul-poly p2 (make-poly (variable p2) (list (make-term 0 -1))))))
(define (add-terms L1 L2)
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(let ((t1 (first-term L1)) (t2 (first-term L2)))
(cond ((> (order t1) (order t2))
(adjoin-term
t1 (add-terms (rest-terms L1) L2)))
((< (order t1) (order t2))
(adjoin-term
t2 (add-terms L1 (rest-terms L2))))
(else
(adjoin-term
(make-term (order t1)
(add (coeff t1) (coeff t2)))
(add-terms (rest-terms L1)
(rest-terms L2)))))))))
(define (mul-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
(make-poly (variable p1)
(mul-terms (term-list p1)
(term-list p2)))
(contents (if (variable_1-order<variable_2-order (variable p1) (variable p2))
(mul (tag p1)
(make-polynomial (variable p1)
(adjoin-term
(make-term 0
(tag p2)) (the-empty-termlist))))
(mul (tag p2)
(make-polynomial (variable p2)
(adjoin-term
(make-term 0
(tag p1)) (the-empty-termlist))))))
#;(error "Polys not in same var -- MUL-POLY"
(list p1 p2))))
(define (div-poly p1 p2)
(show #t "div-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(let ((quotient-and-remainder (div-terms (term-list p1)
(term-list p2))))
(list (make-poly (variable p1) (car quotient-and-remainder))
(make-poly (variable p1) (cadr quotient-and-remainder))))
(error "div-poly: Polys not in the same var" p1 p2)))
(define (div-terms L1 L2)
(show #t "div-terms: L1=" L1 ", L2=" L2 "\n")
(if (empty-termlist? L1)
(list (the-empty-termlist) (the-empty-termlist))
(let ((t1 (first-term L1))
(t2 (first-term L2)))
(if (> (order t2) (order t1))
(list (the-empty-termlist) L1)
(let ((new-c (div (coeff t1) (coeff t2)))
(new-o (- (order t1) (order t2))))
(let ((rest-of-result (div-terms (term-list
(sub-poly
(make-poly 'fake-var L1)
(mul-poly
(make-poly 'fake-var (list (make-term new-o new-c)))
(make-poly 'fake-var L2))))
L2)
))
#;(show #t "div-terms: rest-of-result: " (displayed rest-of-result) "\n")
(list (adjoin-term (make-term new-o new-c) (car rest-of-result)) (cadr rest-of-result))
))))))
(define (gcd-terms a b)
(show #t "gcd-terms: a=" a ", b=" b "\n")
(if (empty-termlist? b)
a
(gcd-terms b (pseudoremainder-terms a b))))
(define (pseudoremainder-terms P Q)
(let ((O1 (order (first-term P)))
(O2 (order (first-term Q)))
(c (coeff (first-term Q))))
(show #t "pseudoremainder-terms: P=" P "\n")
(show #t "pseudoremainder-terms: Q=" Q "\n")
(show #t "pseudoremainder-terms: O1=" O1 "\n")
(show #t "pseudoremainder-terms: O2=" O2 "\n")
(show #t "pseudoremainder-terms: c=" c "\n")
(show #t "pseudoremainder-terms: the integerizing factor="
(make-term 0 (exp c (add 1 (sub O1 O2)))) "\n" )
(show #t "pseudoremainder-terms: P after multiplication="
(mul-term-by-all-terms
(make-term 0 (exp c (add 1 (sub O1 O2)))) P) "\n" )
(cadr (div-terms (mul-term-by-all-terms
(make-term 0 (exp c (add 1 (sub O1 O2)))) P) Q))))
(define (maprest operation term-list)
(show #t "maprest: operation=" (written operation) "term-list=" term-list "\n" )
(if (empty-termlist? term-list)
'()
(cons (operation term-list) (maprest operation (rest-terms term-list))))
)
(define (gcd-poly p1 p2)
(show #t "gcd-poly:p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(let* ((unoptimized-termlist (gcd-terms (term-list p1) (term-list p2)))
(first-terms (maprest first-term unoptimized-termlist))
(coefficients (map coeff first-terms))
(coeff-gcd (apply gcd coefficients))
(optimized-termlist (mul-term-by-all-terms
(make-term 0 (div 1 coeff-gcd)) unoptimized-termlist)))
(show #t "gcd-poly: unoptimized-termlist=" unoptimized-termlist "\n")
(show #t "gcd-poly: first-terms=" first-terms "\n")
(show #t "gcd-poly: coefficients=" coefficients "\n")
(show #t "gcd-poly: coeff-gcd=" coeff-gcd "\n")
(make-poly (variable p1) optimized-termlist))
(error "div-poly: Polys not in the same var" p1 p2)))
(put 'gcd '(polynomial polynomial)
(lambda (x y) (tag (gcd-poly x y))))
(put 'gcd '(integer integer) gcd)
(define (mul-terms L1 L2)
(if (empty-termlist? L1)
(the-empty-termlist)
(add-terms (mul-term-by-all-terms (first-term L1) L2)
(mul-terms (rest-terms L1) L2))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-term L)))
(adjoin-term
(make-term (+ (order t1) (order t2))
(mul (coeff t1) (coeff t2)))
(mul-term-by-all-terms t1 (rest-terms L))))))
(define (reduce-terms termlist-1 termlist-2)
(show #t "reduce-terms: termlist-1=" termlist-1
", termlist-2=" termlist-2 "\n")
(let* ((poly-gcd (gcd-terms termlist-1 termlist-2))
(O1 (max (order (first-term termlist-1))
(order (first-term termlist-2))))
(O2 (order (first-term poly-gcd)))
(c (coeff (first-term poly-gcd)))
(int-factor (exp c (+ 1 (- O1 O2))))
(int-term (make-term 0 int-factor))
(impr-termlist-1 (mul-term-by-all-terms int-term termlist-1))
(impr-termlist-2 (mul-term-by-all-terms int-term termlist-2))
(new-t1 (car (div-terms impr-termlist-1 poly-gcd)))
(new-t2 (car (div-terms impr-termlist-2 poly-gcd)))
(new-t1-terms (map coeff (maprest first-term new-t1)))
(new-t2-terms (map coeff (maprest first-term new-t2)))
(full-list (append new-t1-terms new-t2-terms))
(new-gcd (begin (show #t "full-list=" full-list "\n")
(apply gcd full-list)))
(divisor-term (make-term 0 (div 1 new-gcd)))
(new-t1-impr (mul-term-by-all-terms divisor-term new-t1))
(new-t2-impr (mul-term-by-all-terms divisor-term new-t2)))
(list new-t1-impr new-t2-impr)))
(define (reduce-poly p1 p2)
(show #t "reduce-poly: p1=" p1 ", p2=" p2 "\n")
(if (same-variable? (variable p1) (variable p2))
(let* ((num-den-list (reduce-terms (term-list p1) (term-list p2)))
(my-var (variable p1))
(new-p1 (make-poly my-var (car num-den-list)))
(new-p2 (make-poly my-var (cadr num-den-list))))
(list (tag new-p1) (tag new-p2)))
(error "reduce-poly: different variables")))
(put 'reduce '(polynomial polynomial) reduce-poly)
(define (zero-poly? poly)
(show #t "zero-poly?: poly=" (displayed poly) "\n")
(cond ((empty-termlist? (term-list poly)) #t)
((not (zero? (coeff (first-term (term-list poly))))) #f)
(else (zero-poly?
(make-poly (variable poly)
(rest-terms (term-list poly)))))))
(define (termlist-type-of term-list)
#;(show #t "t-t-o: term-list=" (displayed term-list) "\n")
(cond ((null? term-list) 'sparse)
((pair? (car term-list)) 'sparse)
((list? term-list) 'dense)
(else (error "Unknown type of list" term-list))))
(define (adjoin-term term term-list)
((get 'adjoin-term (termlist-type-of term-list)) term term-list))
(define (first-term term-list)
((get 'first-term (termlist-type-of term-list)) term-list))
(define (variable_1-order<variable_2-order variable_1 variable_2)
#;(show #t "var_1-..: variable_1=" variable_1 " variable_2=" variable_2 "\n")
#;(show #t "var12string=" (symbol->string variable_1) "var22string=" (symbol->string variable_2) "\n")
(string<=? (symbol->string variable_1) (symbol->string variable_2)))
(define (normalize-fully poly)
(if (normal-polynomial? poly)
poly
(normalize-fully (normalize-once poly))))
(put 'add '(polynomial polynomial)
(lambda (p1 p2)
#;(show #t "generic-add-poly:Polynomial dispatch found: p1="
(displayed p1) " p2=" (displayed p2) "\n")
(normalize-fully (tag (add-poly p1 p2)))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (normalize-fully (tag (mul-poly p1 p2)))))
(put 'sub '(polynomial polynomial)
(lambda (p1 p2) (tag (sub-poly p1 p2))))
(put 'zero? '(polynomial) zero-poly?)
(put 'div '(polynomial polynomial) div-poly)
#;(put-coercion 'rational 'scheme-number rational->scheme-number)
(define (monomial-flip-variables monomial)
#;(show #t "m-f-v: monomial=" monomial "\n")
(let* ((mono (contents monomial))
(inner-polynomial (contents (coeff (first-term (term-list mono)))))
(inner-poly (contents inner-polynomial))
(outer-order (order (first-term (term-list mono))))
(outer-var (variable mono))
(inner-var (variable inner-polynomial))
(inner-term-list (term-list inner-poly)))
#;(show #t "m-f-v: inner-poly=" inner-poly "\n")
(if (same-variable? inner-var outer-var)
(mul
(make-polynomial outer-var (adjoin-term (make-term outer-order 1) (the-empty-termlist)))
(tag inner-polynomial))
(tag (make-poly inner-var
(mul-term-by-all-terms (make-term
0
(make-polynomial
outer-var
(list (make-term
outer-order
1)))) inner-poly))))))
#;(show #t "TestXX: sorting variables: Is 'x < 'y?: "
(variable_1-order<variable_2-order 'x 'y) "\n")
#;(show #t "TestXX: sorting variables: Is 'z < 'y?: "
(variable_1-order<variable_2-order 'z 'y) "\n")
#;(show #t "TestXX: (adding two basic poly): "
(add (make-polynomial 'x (list (make-term 1 2) (make-term 0 4)))
(make-polynomial 'y (list (make-term 2 3) (make-term 0 5)))) "\n")
(define (polynomial->sum-of-first-and-rest poly)
#;(show #t "p->s-o-f-a-r: " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (first-term (term-list poly1)))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
first-monomial
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test13: Expanding a polynomial as monomials: "
(displayed
(polynomial->sum-of-first-and-rest
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))))) "\n")
(show #t "\nTest20: start monomial: "
(displayed (make-polynomial 'x
(list
(make-term
2
(make-polynomial
'y
(list
(make-term 2 1) (make-term 0 1))))))) "\n")
(show #t "Test20: Flipping a monomial variable: "
(displayed
(monomial-flip-variables
(make-polynomial 'x
(list (make-term 1 (make-polynomial
'y
(list
(make-term 2 1)
(make-term 0 1)))))))) "\n\n")
(define (normal-polynomial? poly)
#;(show #t "n-p?: poly=" poly "\n")
(cond ((not (polynomial? poly)) #t)
((null? (term-list (contents poly))) #t)
(else (let* ((poly1 (contents poly))
(outer-var (variable poly1)))
#;(show #t "Inner-let: outer-var=" (displayed outer-var) "\n")
(let loop ((terms (term-list poly1)))
#;(show #t "n-p?-loop: terms=" (displayed terms) "\n")
(cond ((null? terms) #t)
((not (polynomial? (coeff (first-term terms)))) (loop (rest-terms terms)))
((not (variable_1-order<variable_2-order
outer-var
(variable (contents (coeff (first-term terms)))))) (begin #;(show #t "wrong variable order \n") #f))
((not (normal-polynomial? (coeff (first-term terms)))) (begin #;(show #t "not normal poly\n") #f))
(else (loop (rest-terms terms)))))
))))
(define (normalize-once poly)
#;(show #t "normalize-once poly= " (displayed poly) "\n")
(if (zero? poly)
poly
(let* ((poly1 (contents poly))
(first-monomial (tag
(make-poly
(variable poly1)
(list (make-term
(order (first-term (term-list poly1)))
(if (polynomial? (coeff (first-term (term-list poly1))))
(normalize-once (coeff (first-term (term-list poly1))))
(coeff (first-term (term-list poly1))))))))))
#;(show #t "p->s-o-f-a-r: " (displayed first-monomial) "\n")
(add
(if (and (polynomial?
(coeff
(first-term
(term-list
(contents first-monomial)))))
(variable_1-order<variable_2-order
(variable
(contents
(coeff
(first-term
(term-list
(contents first-monomial))))))
(variable
(contents first-monomial))))
(monomial-flip-variables first-monomial)
first-monomial)
(polynomial->sum-of-first-and-rest
(tag (make-poly (variable poly1) (rest-terms (term-list poly1)))))))))
(show #t "Test21: normal-polynomial?:start: " (displayed (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test21: normal-polynomial?:result:" (normal-polynomial? (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test22: normal-polynomial?-good:start: "
(displayed
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test22: normal-polynomial?-good:result:"
(normal-polynomial?
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'y
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test23:input: normalizing a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
#;(show #t "Test23:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test24:input: normalizing a bad polynomial: "
(make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
#;(show #t "Test24:result: normalizing a bad polynomial: "
(normalize-once (make-polynomial 'x
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
#;(show #t "Test24:input: normalize-fully a bad polynomial: "
(make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2))) "\n")
#;(show #t "Test24:result: normalize-fully a bad polynomial: "
(normalize-fully (make-polynomial 'y
(list (make-term 2 (make-polynomial
'x
(list (make-term 2 1) (make-term 0 1))))
(make-term 0 2)))) "\n")
'done)
(define (install-polynomial-sparse-package)
(define (coeff term) (cadr term))
(define (first-term-sparse term-list) (car term-list))
(define (adjoin-term-sparse term term-list)
(if (zero? (coeff term))
term-list
(cons term term-list)))
(put 'adjoin-term 'sparse adjoin-term-sparse)
(put 'first-term 'sparse first-term-sparse)
'done)
(install-polynomial-sparse-package)
(define (install-polynomial-dense-package)
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))
(define (adjoin-term-dense term term-list)
(if (zero? (coeff term))
term-list
(if (> (order term) (length term-list))
(append (list (coeff term))
(make-list (- (order term) (length term-list)) 0)
term-list)
(error "adjoin-term:Appending a smaller order term. Recheck."))))
(define (first-term-dense term-list)
#;(show #t "first-term-dense: " (displayed (make-term (car term-list) (length (cdr term-list)))) "\n")
(make-term (length (cdr term-list)) (car term-list) ))
(put 'adjoin-term 'dense adjoin-term-dense)
(put 'first-term 'dense first-term-dense)
'done)
#;(install-polynomial-dense-package)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))
(install-polynomial-package)
(show #t "Test 2: Making polynomials: "
(make-polynomial 'x (list (list 5 1) (list 4 2))) "\n")
(show #t "Test 3: Zero?: "
(zero? (make-polynomial 'x (list (list 5 1) (list 4 2)))) "\n")
(show #t "Test 4: Adding polynomials: "
(add (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((5 1)))) "\n")
(show #t "Test 4: Zero?: " (zero? (make-polynomial 'x '((5 0) (3 1)))) "\n")
(show #t "Test 5: Subtracting polynomials: "
(sub (make-polynomial 'x '((5 1) (4 2) (0 1)))
(make-polynomial 'x '((0 1)))) "\n")
#;(show #t "Test 6: Making a dense polynomial: " (make-polynomial 'x '(1 2 3 4 5)) "\n")
#;(show #t "Test 7: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(0)))) "\n")
#;(show #t "Test 8: zero? dense polynomial: " (displayed (zero? (make-polynomial 'x '(1)))) "\n")
#;(show #t "Test 9: Adding dense polynomials: "
(add (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test10: Subtracting dense polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '(1 0 0 0 0 0))) "\n")
#;(show #t "Test11: Subtracting dense and sparse polynomials: "
(sub (make-polynomial 'x '(1 2 0 0 0 1))
(make-polynomial 'x '((4 2)))) "\n")
(show #t "Test12: Dividing x^2 + 2x + 1 by x+1: "
(displayed
(div (make-polynomial 'x '((2 1) (1 2) (0 1)))
(make-polynomial 'x '( (1 1) (0 1)))) ) "\n")
(show #t "Test14: Adding polynomials of two variables: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))))
(show #t "Test14: Adding polynomials of two variables, when one of them is nonexistant: "
(displayed
(add (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((0 1))))))
(show #t "Test25: multiplying different variables: "
(displayed (mul (make-polynomial 'x '((1 1)))
(make-polynomial 'y '((1 1))))) "\n")
(begin
(show #t "Test 26:start\n")
(define p1 (make-polynomial 'x '((2 1) (0 1))))
(define p2 (make-polynomial 'x '((3 1) (0 1))))
(define rf (make-rational p2 p1))
(show #t "Test 26: make-rational-polynomial: " rf "\n")
(show #t "Test 27: add-rational\n")
(show #t "Test 27: " (add rf rf) "\n")
)
(show #t "Test 28: polynomial-gcd: start\n")
(define (greatest-common-divisor p1 p2) (apply-generic 'gcd p1 p2))
(begin
(define p1 (make-polynomial
'x '((4 1) (3 -1) (2 -2) (1 2))))
(define p2 (make-polynomial 'x '((3 1) (1 -1))))
(show #t "Test 28: polynomial-gcd: " (greatest-common-divisor p1 p2) "\n"))
(begin
(define p1 (make-polynomial
'x '((2 1) (1 -2) (0 1))))
(define p2 (make-polynomial 'x '((2 11) (0 7))))
(define p3 (make-polynomial 'x '((1 13) (0 5))))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
(show #t "Test 29: gcd-integer-problem: start\n")
(show #t "Test 29: p1=" p1 "\n")
(show #t "Test 29: p2=" p2 "\n")
(show #t "Test 29: p3=" p3 "\n")
(show #t "Test 29: q1=" q1 "\n")
(show #t "Test 29: q2=" q2 "\n")
(show #t "Test 29: gcd : " (greatest-common-divisor q1 q2) "\n")
)
(begin
(show #t "Test 30: start\n")
(define p1 (make-polynomial 'x '((1 1)(0 1))))
(define p2 (make-polynomial 'x '((3 1)(0 -1))))
(define p3 (make-polynomial 'x '((1 1))))
(define p4 (make-polynomial 'x '((2 1)(0 -1))))
(define rf1 (make-rational p1 p2))
(define rf2 (make-rational p3 p4))
(show #t "Test 33: " (add rf1 rf2) "\n"))
#+end_src
#+RESULTS:
#+begin_example
(tag 5)=5
Test 31: start
Test 31:#t
Test: Higher than 'integer: scheme-number
Test 30: start
Test 30:(add (make-scheme-number 1) (make-scheme-number 1))= 2
Test 32: startTest 32: Subtracting complex numbers: 1.1
TestY2: poly of poly: (x (3 (y (1 1) (0 1))) (1 2) (0 4))
zero-poly?: poly=(y (2 (polynomial x (2 1) (0 1))) (0 2))
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(y (0 2))
zero-poly?: poly=(y)
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(y (2 (polynomial x (2 1) (0 1))) (0 2))
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(x (2 1) (0 1))
zero-poly?: poly=(x (0 1))
zero-poly?: poly=(x)
zero-poly?: poly=(y (0 2))
zero-poly?: poly=(y)
zero-poly?: poly=(y (2 1))
zero-poly?: poly=(y (2 1))
zero-poly?: poly=(y (2 1) (0 2))
zero-poly?: poly=(y (2 1))
Test13: Expanding a polynomial as monomials: (polynomial x (2 (polynomial y (2 1))) (0 (polynomial y (2 1) (0 2))))
Test20: start monomial: (polynomial x (2 (polynomial y (2 1) (0 1))))
zero-poly?: poly=(x (1 1))
zero-poly?: poly=(x (1 1))
Test20: Flipping a monomial variable: (polynomial y (2 (polynomial x (1 1))) (0 (polynomial x (1 1))))
Test21: normal-polynomial?:start: (polynomial y (2 (polynomial x (2 1) (0 1))) (0 2))
Test 2: Making polynomials: (polynomial x (5 1) (4 2))
zero-poly?: poly=(x (5 1) (4 2))
Test 3: Zero?: #f
Test 4: Adding polynomials: (polynomial x (5 2) (4 2) (0 1))
zero-poly?: poly=(x (5 0) (3 1))
zero-poly?: poly=(x (3 1))
Test 4: Zero?: #f
Test 5: Subtracting polynomials: (polynomial x (5 1) (4 2))
div-poly: p1=(x (2 1) (1 2) (0 1)), p2=(x (1 1) (0 1))
div-terms: L1=((2 1) (1 2) (0 1)), L2=((1 1) (0 1))
div-terms: L1=((1 1) (0 1)), L2=((1 1) (0 1))
div-terms: L1=(), L2=((1 1) (0 1))
Test12: Dividing x^2 + 2x + 1 by x+1: ((x (1 1) (0 1)) (x))
Test14: Adding polynomials of two variables: (polynomial x (1 1) (0 (polynomial y (1 1))))Test14: Adding polynomials of two variables, when one of them is nonexistant: (polynomial x (1 1) (0 (polynomial y (0 1))))zero-poly?: poly=(y (1 1))
zero-poly?: poly=(y (1 1))
Test25: multiplying different variables: (polynomial x (1 (polynomial y (1 1))))
Test 26:start
make-rat: n=(polynomial x (3 1) (0 1)), d=(polynomial x (2 1) (0 1))
reduce-poly: p1=(x (3 1) (0 1)), p2=(x (2 1) (0 1))
reduce-terms: termlist-1=((3 1) (0 1)), termlist-2=((2 1) (0 1))
gcd-terms: a=((3 1) (0 1)), b=((2 1) (0 1))
pseudoremainder-terms: P=((3 1) (0 1))
pseudoremainder-terms: Q=((2 1) (0 1))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((3 1) (0 1))
div-terms: L1=((3 1) (0 1)), L2=((2 1) (0 1))
div-terms: L1=((1 -1) (0 1)), L2=((2 1) (0 1))
gcd-terms: a=((2 1) (0 1)), b=((1 -1) (0 1))
pseudoremainder-terms: P=((2 1) (0 1))
pseudoremainder-terms: Q=((1 -1) (0 1))
pseudoremainder-terms: O1=2
pseudoremainder-terms: O2=1
pseudoremainder-terms: c=-1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((2 1) (0 1))
div-terms: L1=((2 1) (0 1)), L2=((1 -1) (0 1))
div-terms: L1=((1 1) (0 1)), L2=((1 -1) (0 1))
div-terms: L1=((0 2)), L2=((1 -1) (0 1))
gcd-terms: a=((1 -1) (0 1)), b=((0 2))
pseudoremainder-terms: P=((1 -1) (0 1))
pseudoremainder-terms: Q=((0 2))
pseudoremainder-terms: O1=1
pseudoremainder-terms: O2=0
pseudoremainder-terms: c=2
pseudoremainder-terms: the integerizing factor=(0 4)
pseudoremainder-terms: P after multiplication=((1 -4) (0 4))
div-terms: L1=((1 -4) (0 4)), L2=((0 2))
div-terms: L1=((0 4)), L2=((0 2))
div-terms: L1=(), L2=((0 2))
gcd-terms: a=((0 2)), b=()
div-terms: L1=((3 16) (0 16)), L2=((0 2))
div-terms: L1=((0 16)), L2=((0 2))
div-terms: L1=(), L2=((0 2))
div-terms: L1=((2 16) (0 16)), L2=((0 2))
div-terms: L1=((0 16)), L2=((0 2))
div-terms: L1=(), L2=((0 2))
maprest: operation=#<procedure first-term>term-list=((3 8) (0 8))
maprest: operation=#<procedure first-term>term-list=((0 8))
maprest: operation=#<procedure first-term>term-list=()
maprest: operation=#<procedure first-term>term-list=((2 8) (0 8))
maprest: operation=#<procedure first-term>term-list=((0 8))
maprest: operation=#<procedure first-term>term-list=()
full-list=(8 8 8 8)
Test 26: make-rational-polynomial: (rational (polynomial x (3 1) (0 1)) polynomial x (2 1) (0 1))
Test 27: add-rational
make-rat: n=(polynomial x (5 2) (3 2) (2 2) (0 2)), d=(polynomial x (4 1) (2 2) (0 1))
reduce-poly: p1=(x (5 2) (3 2) (2 2) (0 2)), p2=(x (4 1) (2 2) (0 1))
reduce-terms: termlist-1=((5 2) (3 2) (2 2) (0 2)), termlist-2=((4 1) (2 2) (0 1))
gcd-terms: a=((5 2) (3 2) (2 2) (0 2)), b=((4 1) (2 2) (0 1))
pseudoremainder-terms: P=((5 2) (3 2) (2 2) (0 2))
pseudoremainder-terms: Q=((4 1) (2 2) (0 1))
pseudoremainder-terms: O1=5
pseudoremainder-terms: O2=4
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((5 2) (3 2) (2 2) (0 2))
div-terms: L1=((5 2) (3 2) (2 2) (0 2)), L2=((4 1) (2 2) (0 1))
div-terms: L1=((3 -2) (2 2) (1 -2) (0 2)), L2=((4 1) (2 2) (0 1))
gcd-terms: a=((4 1) (2 2) (0 1)), b=((3 -2) (2 2) (1 -2) (0 2))
pseudoremainder-terms: P=((4 1) (2 2) (0 1))
pseudoremainder-terms: Q=((3 -2) (2 2) (1 -2) (0 2))
pseudoremainder-terms: O1=4
pseudoremainder-terms: O2=3
pseudoremainder-terms: c=-2
pseudoremainder-terms: the integerizing factor=(0 4)
pseudoremainder-terms: P after multiplication=((4 4) (2 8) (0 4))
div-terms: L1=((4 4) (2 8) (0 4)), L2=((3 -2) (2 2) (1 -2) (0 2))
div-terms: L1=((3 4) (2 4) (1 4) (0 4)), L2=((3 -2) (2 2) (1 -2) (0 2))
div-terms: L1=((2 8) (0 8)), L2=((3 -2) (2 2) (1 -2) (0 2))
gcd-terms: a=((3 -2) (2 2) (1 -2) (0 2)), b=((2 8) (0 8))
pseudoremainder-terms: P=((3 -2) (2 2) (1 -2) (0 2))
pseudoremainder-terms: Q=((2 8) (0 8))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=8
pseudoremainder-terms: the integerizing factor=(0 64)
pseudoremainder-terms: P after multiplication=((3 -128) (2 128) (1 -128) (0 128))
div-terms: L1=((3 -128) (2 128) (1 -128) (0 128)), L2=((2 8) (0 8))
div-terms: L1=((2 128) (0 128)), L2=((2 8) (0 8))
div-terms: L1=(), L2=((2 8) (0 8))
gcd-terms: a=((2 8) (0 8)), b=()
div-terms: L1=((5 8192) (3 8192) (2 8192) (0 8192)), L2=((2 8) (0 8))
div-terms: L1=((2 8192) (0 8192)), L2=((2 8) (0 8))
div-terms: L1=(), L2=((2 8) (0 8))
div-terms: L1=((4 4096) (2 8192) (0 4096)), L2=((2 8) (0 8))
div-terms: L1=((2 4096) (0 4096)), L2=((2 8) (0 8))
div-terms: L1=(), L2=((2 8) (0 8))
maprest: operation=#<procedure first-term>term-list=((3 1024) (0 1024))
maprest: operation=#<procedure first-term>term-list=((0 1024))
maprest: operation=#<procedure first-term>term-list=()
maprest: operation=#<procedure first-term>term-list=((2 512) (0 512))
maprest: operation=#<procedure first-term>term-list=((0 512))
maprest: operation=#<procedure first-term>term-list=()
full-list=(1024 1024 512 512)
rational not droppable: #f
Test 27: (rational (polynomial x (3 2) (0 2)) polynomial x (2 1) (0 1))
Test 28: polynomial-gcd: start
gcd-poly:p1=(x (4 1) (3 -1) (2 -2) (1 2)), p2=(x (3 1) (1 -1))
gcd-terms: a=((4 1) (3 -1) (2 -2) (1 2)), b=((3 1) (1 -1))
pseudoremainder-terms: P=((4 1) (3 -1) (2 -2) (1 2))
pseudoremainder-terms: Q=((3 1) (1 -1))
pseudoremainder-terms: O1=4
pseudoremainder-terms: O2=3
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((4 1) (3 -1) (2 -2) (1 2))
div-terms: L1=((4 1) (3 -1) (2 -2) (1 2)), L2=((3 1) (1 -1))
div-terms: L1=((3 -1) (2 -1) (1 2)), L2=((3 1) (1 -1))
div-terms: L1=((2 -1) (1 1)), L2=((3 1) (1 -1))
gcd-terms: a=((3 1) (1 -1)), b=((2 -1) (1 1))
pseudoremainder-terms: P=((3 1) (1 -1))
pseudoremainder-terms: Q=((2 -1) (1 1))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=-1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((3 1) (1 -1))
div-terms: L1=((3 1) (1 -1)), L2=((2 -1) (1 1))
div-terms: L1=((2 1) (1 -1)), L2=((2 -1) (1 1))
div-terms: L1=(), L2=((2 -1) (1 1))
gcd-terms: a=((2 -1) (1 1)), b=()
maprest: operation=#<procedure first-term>term-list=((2 -1) (1 1))
maprest: operation=#<procedure first-term>term-list=((1 1))
maprest: operation=#<procedure first-term>term-list=()
gcd-poly: unoptimized-termlist=((2 -1) (1 1))
gcd-poly: first-terms=((2 -1) (1 1))
gcd-poly: coefficients=(-1 1)
gcd-poly: coeff-gcd=1
Test 28: polynomial-gcd: (polynomial x (2 -1) (1 1))
Test 29: gcd-integer-problem: start
Test 29: p1=(polynomial x (2 1) (1 -2) (0 1))
Test 29: p2=(polynomial x (2 11) (0 7))
Test 29: p3=(polynomial x (1 13) (0 5))
Test 29: q1=(polynomial x (4 11) (3 -22) (2 18) (1 -14) (0 7))
Test 29: q2=(polynomial x (3 13) (2 -21) (1 3) (0 5))
gcd-poly:p1=(x (4 11) (3 -22) (2 18) (1 -14) (0 7)), p2=(x (3 13) (2 -21) (1 3) (0 5))
gcd-terms: a=((4 11) (3 -22) (2 18) (1 -14) (0 7)), b=((3 13) (2 -21) (1 3) (0 5))
pseudoremainder-terms: P=((4 11) (3 -22) (2 18) (1 -14) (0 7))
pseudoremainder-terms: Q=((3 13) (2 -21) (1 3) (0 5))
pseudoremainder-terms: O1=4
pseudoremainder-terms: O2=3
pseudoremainder-terms: c=13
pseudoremainder-terms: the integerizing factor=(0 169)
pseudoremainder-terms: P after multiplication=((4 1859) (3 -3718) (2 3042) (1 -2366) (0 1183))
div-terms: L1=((4 1859) (3 -3718) (2 3042) (1 -2366) (0 1183)), L2=((3 13) (2 -21) (1 3) (0 5))
div-terms: L1=((3 -715) (2 2613) (1 -3081) (0 1183)), L2=((3 13) (2 -21) (1 3) (0 5))
div-terms: L1=((2 1458) (1 -2916) (0 1458)), L2=((3 13) (2 -21) (1 3) (0 5))
gcd-terms: a=((3 13) (2 -21) (1 3) (0 5)), b=((2 1458) (1 -2916) (0 1458))
pseudoremainder-terms: P=((3 13) (2 -21) (1 3) (0 5))
pseudoremainder-terms: Q=((2 1458) (1 -2916) (0 1458))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=1458
pseudoremainder-terms: the integerizing factor=(0 2125764)
pseudoremainder-terms: P after multiplication=((3 27634932) (2 -44641044) (1 6377292) (0 10628820))
div-terms: L1=((3 27634932) (2 -44641044) (1 6377292) (0 10628820)), L2=((2 1458) (1 -2916) (0 1458))
div-terms: L1=((2 10628820) (1 -21257640) (0 10628820)), L2=((2 1458) (1 -2916) (0 1458))
div-terms: L1=(), L2=((2 1458) (1 -2916) (0 1458))
gcd-terms: a=((2 1458) (1 -2916) (0 1458)), b=()
maprest: operation=#<procedure first-term>term-list=((2 1458) (1 -2916) (0 1458))
maprest: operation=#<procedure first-term>term-list=((1 -2916) (0 1458))
maprest: operation=#<procedure first-term>term-list=((0 1458))
maprest: operation=#<procedure first-term>term-list=()
gcd-poly: unoptimized-termlist=((2 1458) (1 -2916) (0 1458))
gcd-poly: first-terms=((2 1458) (1 -2916) (0 1458))
gcd-poly: coefficients=(1458 -2916 1458)
gcd-poly: coeff-gcd=1458
Test 29: gcd : (polynomial x (2 0.9999999999999999) (1 -1.9999999999999998) (0 0.9999999999999999))
Test 30: start
make-rat: n=(polynomial x (1 1) (0 1)), d=(polynomial x (3 1) (0 -1))
reduce-poly: p1=(x (1 1) (0 1)), p2=(x (3 1) (0 -1))
reduce-terms: termlist-1=((1 1) (0 1)), termlist-2=((3 1) (0 -1))
gcd-terms: a=((1 1) (0 1)), b=((3 1) (0 -1))
pseudoremainder-terms: P=((1 1) (0 1))
pseudoremainder-terms: Q=((3 1) (0 -1))
pseudoremainder-terms: O1=1
pseudoremainder-terms: O2=3
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((1 1) (0 1))
div-terms: L1=((1 1) (0 1)), L2=((3 1) (0 -1))
gcd-terms: a=((3 1) (0 -1)), b=((1 1) (0 1))
pseudoremainder-terms: P=((3 1) (0 -1))
pseudoremainder-terms: Q=((1 1) (0 1))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=1
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((3 1) (0 -1))
div-terms: L1=((3 1) (0 -1)), L2=((1 1) (0 1))
div-terms: L1=((2 -1) (0 -1)), L2=((1 1) (0 1))
div-terms: L1=((1 1) (0 -1)), L2=((1 1) (0 1))
div-terms: L1=((0 -2)), L2=((1 1) (0 1))
gcd-terms: a=((1 1) (0 1)), b=((0 -2))
pseudoremainder-terms: P=((1 1) (0 1))
pseudoremainder-terms: Q=((0 -2))
pseudoremainder-terms: O1=1
pseudoremainder-terms: O2=0
pseudoremainder-terms: c=-2
pseudoremainder-terms: the integerizing factor=(0 4)
pseudoremainder-terms: P after multiplication=((1 4) (0 4))
div-terms: L1=((1 4) (0 4)), L2=((0 -2))
div-terms: L1=((0 4)), L2=((0 -2))
div-terms: L1=(), L2=((0 -2))
gcd-terms: a=((0 -2)), b=()
div-terms: L1=((1 16) (0 16)), L2=((0 -2))
div-terms: L1=((0 16)), L2=((0 -2))
div-terms: L1=(), L2=((0 -2))
div-terms: L1=((3 16) (0 -16)), L2=((0 -2))
div-terms: L1=((0 -16)), L2=((0 -2))
div-terms: L1=(), L2=((0 -2))
maprest: operation=#<procedure first-term>term-list=((1 -8) (0 -8))
maprest: operation=#<procedure first-term>term-list=((0 -8))
maprest: operation=#<procedure first-term>term-list=()
maprest: operation=#<procedure first-term>term-list=((3 -8) (0 8))
maprest: operation=#<procedure first-term>term-list=((0 8))
maprest: operation=#<procedure first-term>term-list=()
full-list=(-8 -8 -8 8)
make-rat: n=(polynomial x (1 1)), d=(polynomial x (2 1) (0 -1))
reduce-poly: p1=(x (1 1)), p2=(x (2 1) (0 -1))
reduce-terms: termlist-1=((1 1)), termlist-2=((2 1) (0 -1))
gcd-terms: a=((1 1)), b=((2 1) (0 -1))
pseudoremainder-terms: P=((1 1))
pseudoremainder-terms: Q=((2 1) (0 -1))
pseudoremainder-terms: O1=1
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((1 1))
div-terms: L1=((1 1)), L2=((2 1) (0 -1))
gcd-terms: a=((2 1) (0 -1)), b=((1 1))
pseudoremainder-terms: P=((2 1) (0 -1))
pseudoremainder-terms: Q=((1 1))
pseudoremainder-terms: O1=2
pseudoremainder-terms: O2=1
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((2 1) (0 -1))
div-terms: L1=((2 1) (0 -1)), L2=((1 1))
div-terms: L1=((0 -1)), L2=((1 1))
gcd-terms: a=((1 1)), b=((0 -1))
pseudoremainder-terms: P=((1 1))
pseudoremainder-terms: Q=((0 -1))
pseudoremainder-terms: O1=1
pseudoremainder-terms: O2=0
pseudoremainder-terms: c=-1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((1 1))
div-terms: L1=((1 1)), L2=((0 -1))
div-terms: L1=(), L2=((0 -1))
gcd-terms: a=((0 -1)), b=()
div-terms: L1=((1 -1)), L2=((0 -1))
div-terms: L1=(), L2=((0 -1))
div-terms: L1=((2 -1) (0 1)), L2=((0 -1))
div-terms: L1=((0 1)), L2=((0 -1))
div-terms: L1=(), L2=((0 -1))
maprest: operation=#<procedure first-term>term-list=((1 1))
maprest: operation=#<procedure first-term>term-list=()
maprest: operation=#<procedure first-term>term-list=((2 1) (0 -1))
maprest: operation=#<procedure first-term>term-list=((0 -1))
maprest: operation=#<procedure first-term>term-list=()
full-list=(1 1 -1)
make-rat: n=(polynomial x (4 -1) (3 -1) (2 -1) (1 2) (0 1)), d=(polynomial x (5 -1) (3 1) (2 1) (0 -1))
reduce-poly: p1=(x (4 -1) (3 -1) (2 -1) (1 2) (0 1)), p2=(x (5 -1) (3 1) (2 1) (0 -1))
reduce-terms: termlist-1=((4 -1) (3 -1) (2 -1) (1 2) (0 1)), termlist-2=((5 -1) (3 1) (2 1) (0 -1))
gcd-terms: a=((4 -1) (3 -1) (2 -1) (1 2) (0 1)), b=((5 -1) (3 1) (2 1) (0 -1))
pseudoremainder-terms: P=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
pseudoremainder-terms: Q=((5 -1) (3 1) (2 1) (0 -1))
pseudoremainder-terms: O1=4
pseudoremainder-terms: O2=5
pseudoremainder-terms: c=-1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
div-terms: L1=((4 -1) (3 -1) (2 -1) (1 2) (0 1)), L2=((5 -1) (3 1) (2 1) (0 -1))
gcd-terms: a=((5 -1) (3 1) (2 1) (0 -1)), b=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
pseudoremainder-terms: P=((5 -1) (3 1) (2 1) (0 -1))
pseudoremainder-terms: Q=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
pseudoremainder-terms: O1=5
pseudoremainder-terms: O2=4
pseudoremainder-terms: c=-1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((5 -1) (3 1) (2 1) (0 -1))
div-terms: L1=((5 -1) (3 1) (2 1) (0 -1)), L2=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
div-terms: L1=((4 1) (3 2) (2 -1) (1 -1) (0 -1)), L2=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
div-terms: L1=((3 1) (2 -2) (1 1)), L2=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
gcd-terms: a=((4 -1) (3 -1) (2 -1) (1 2) (0 1)), b=((3 1) (2 -2) (1 1))
pseudoremainder-terms: P=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
pseudoremainder-terms: Q=((3 1) (2 -2) (1 1))
pseudoremainder-terms: O1=4
pseudoremainder-terms: O2=3
pseudoremainder-terms: c=1
pseudoremainder-terms: the integerizing factor=(0 1)
pseudoremainder-terms: P after multiplication=((4 -1) (3 -1) (2 -1) (1 2) (0 1))
div-terms: L1=((4 -1) (3 -1) (2 -1) (1 2) (0 1)), L2=((3 1) (2 -2) (1 1))
div-terms: L1=((3 -3) (1 2) (0 1)), L2=((3 1) (2 -2) (1 1))
div-terms: L1=((2 -6) (1 5) (0 1)), L2=((3 1) (2 -2) (1 1))
gcd-terms: a=((3 1) (2 -2) (1 1)), b=((2 -6) (1 5) (0 1))
pseudoremainder-terms: P=((3 1) (2 -2) (1 1))
pseudoremainder-terms: Q=((2 -6) (1 5) (0 1))
pseudoremainder-terms: O1=3
pseudoremainder-terms: O2=2
pseudoremainder-terms: c=-6
pseudoremainder-terms: the integerizing factor=(0 36)
pseudoremainder-terms: P after multiplication=((3 36) (2 -72) (1 36))
div-terms: L1=((3 36) (2 -72) (1 36)), L2=((2 -6) (1 5) (0 1))
div-terms: L1=((2 -42) (1 42)), L2=((2 -6) (1 5) (0 1))
div-terms: L1=((1 7) (0 -7)), L2=((2 -6) (1 5) (0 1))
gcd-terms: a=((2 -6) (1 5) (0 1)), b=((1 7) (0 -7))
pseudoremainder-terms: P=((2 -6) (1 5) (0 1))
pseudoremainder-terms: Q=((1 7) (0 -7))
pseudoremainder-terms: O1=2
pseudoremainder-terms: O2=1
pseudoremainder-terms: c=7
pseudoremainder-terms: the integerizing factor=(0 49)
pseudoremainder-terms: P after multiplication=((2 -294) (1 245) (0 49))
div-terms: L1=((2 -294) (1 245) (0 49)), L2=((1 7) (0 -7))
div-terms: L1=((1 -49) (0 49)), L2=((1 7) (0 -7))
div-terms: L1=(), L2=((1 7) (0 -7))
gcd-terms: a=((1 7) (0 -7)), b=()
div-terms: L1=((4 -16807) (3 -16807) (2 -16807) (1 33614) (0 16807)), L2=((1 7) (0 -7))
div-terms: L1=((3 -33614) (2 -16807) (1 33614) (0 16807)), L2=((1 7) (0 -7))
div-terms: L1=((2 -50421) (1 33614) (0 16807)), L2=((1 7) (0 -7))
div-terms: L1=((1 -16807) (0 16807)), L2=((1 7) (0 -7))
div-terms: L1=(), L2=((1 7) (0 -7))
div-terms: L1=((5 -16807) (3 16807) (2 16807) (0 -16807)), L2=((1 7) (0 -7))
div-terms: L1=((4 -16807) (3 16807) (2 16807) (0 -16807)), L2=((1 7) (0 -7))
div-terms: L1=((2 16807) (0 -16807)), L2=((1 7) (0 -7))
div-terms: L1=((1 16807) (0 -16807)), L2=((1 7) (0 -7))
div-terms: L1=(), L2=((1 7) (0 -7))
maprest: operation=#<procedure first-term>term-list=((3 -2401) (2 -4802) (1 -7203) (0 -2401))
maprest: operation=#<procedure first-term>term-list=((2 -4802) (1 -7203) (0 -2401))
maprest: operation=#<procedure first-term>term-list=((1 -7203) (0 -2401))
maprest: operation=#<procedure first-term>term-list=((0 -2401))
maprest: operation=#<procedure first-term>term-list=()
maprest: operation=#<procedure first-term>term-list=((4 -2401) (3 -2401) (1 2401) (0 2401))
maprest: operation=#<procedure first-term>term-list=((3 -2401) (1 2401) (0 2401))
maprest: operation=#<procedure first-term>term-list=((1 2401) (0 2401))
maprest: operation=#<procedure first-term>term-list=((0 2401))
maprest: operation=#<procedure first-term>term-list=()
full-list=(-2401 -4802 -7203 -2401 -2401 -2401 2401 2401)
rational not droppable: #f
Test 33: (rational (polynomial x (3 -1) (2 -2) (1 -3) (0 -1)) polynomial x (4 -1) (3 -1) (1 1) (0 1))
#+end_example
This exercise ends the Chapter 2 of the Structure and Interpretation of
Computer programs.
The main pedagogical conclusion one may infer from this exercise is that it
is a good idea to read a book on algebra and integer algorithms.
** TODO Chapter 3: Modularity, Objects and State [75/91]
*** DONE Exercise 3.1 accumulators
CLOSED: [2019-10-29 Tue 10:24]
#+begin_src scheme :exports both :results output
(define (make-accumulator initial-amount)
(lambda (increment) (set! initial-amount (+ initial-amount increment)) initial-amount))
(define A (make-accumulator 5))
(check (A 10) => 15)
(check (A 20) => 35)
(define B (make-accumulator 100))
(check (B 200) => 300)
(check (B 1) => 301)
#+end_src
#+RESULTS:
:
: (A 10) => 15 ; correct
:
: (A 20) => 35 ; correct
:
: (B 200) => 300 ; correct
:
: (B 1) => 301 ; correct
*** DONE Exercise 3.2 make-monitored
CLOSED: [2019-10-29 Tue 11:03]
This problem is ill-defined. In particular, it doesn't specify whether we
should be counting calls to ~f~ only, or to ~mf~ in total, including the
calls to ~'how-many-calls?~.
#+begin_src scheme :exports both :results output
(define (make-monitored f)
(let ((call-counter 0))
(lambda (arg)
(cond ((eq? arg 'reset-count) (set! call-counter 0))
((eq? arg 'how-many-calls?) call-counter)
(else (begin (set! call-counter (+ 1 call-counter)) (f arg)))))))
(define s (make-monitored sqrt))
(check (s 100) => 10)
(check (s 'how-many-calls?) => 1)
#+end_src
#+RESULTS:
:
: (s 100) => 10 ; correct
:
: (s (quote how-many-calls?)) => 1 ; correct
*** DONE Exercise 3.3 password protection
CLOSED: [2019-10-29 Tue 11:17]
This exercise is slightly tricky in that it uses the less commonly used form
of ~lambda~, which can take any number of arguments.
#+begin_src scheme :exports both :results output
(define (make-account balance password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch pass m)
(if (eq? pass password)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT"
m)))
(lambda rest "Incorrect password")))
dispatch)
(define acc (make-account 100 'secret-password))
(check ((acc 'secret-password 'withdraw) 40) => 60)
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
#+end_src
#+RESULTS:
:
: ((acc (quote secret-password) (quote withdraw)) 40) => 60 ; correct
:
: ((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
*** DONE Exercise 3.4 call-the-cops
CLOSED: [2019-10-29 Tue 11:32]
#+begin_src scheme :exports both :results output
(define (make-account balance password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(let ((cops-counter 7))
(define (call-the-cops) "Call the cops")
(define (dispatch pass m)
(if (eq? pass password)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT"
m)))
(lambda rest
(if (< 0 cops-counter)
(begin (set! cops-counter (- cops-counter 1)) "Incorrect password")
(call-the-cops)))))
dispatch))
(define acc (make-account 100 'secret-password))
(check ((acc 'secret-password 'withdraw) 40) => 60)
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(check ((acc 'some-other-password 'deposit) 50) => "Call the cops")
#+end_src
#+RESULTS:
#+begin_example
((acc (quote secret-password) (quote withdraw)) 40) => 60 ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
((acc (quote some-other-password) (quote deposit)) 50) => "Call the cops" ; correct
#+end_example
*** DONE Exercise 3.5 Monte-Carlo
CLOSED: [2019-10-30 Wed 00:12]
I am using the random function first defined in Exercise 1.24, not the
rand-update, because I am not very sure in my prng development skills.
#+begin_src scheme :exports both :results output
<<random>>
(define (random-in-range low high)
(let ((range (- high low)))
(+ low (random range))))
(show #t "Test 01: " (random-in-range 1 2000) "\n")
(define (monte-carlo trials experiment)
(define (iter trials-remaining trials-passed)
(cond ((= trials-remaining 0)
(/ trials-passed trials))
((experiment)
(iter (- trials-remaining 1) (+ trials-passed 1)))
(else
(iter (- trials-remaining 1) trials-passed))))
(iter trials 0))
(define (is-inside-circle? x y radius)
#;(show #t "x=" x ", y=" y "\n")
(if (< (+ (expt (- x 1000) 2) (expt (- y 1000) 2)) (expt radius 2))
#t
#f))
(define (estimate-integral P x1 x2 y1 y2 trials)
#;(show #t "estimate-integral: x1=" x1 ", x2=" x2 ", y1=" y1 ", y2=" y2 ", trials=" trials "\n")
(monte-carlo trials
(lambda ()
(P (random-in-range x1 x2) (random-in-range y1 y2)))))
(define (estimate-pi trials)
(inexact (* 4 (estimate-integral
(lambda (x y) (is-inside-circle? x y 1000)) 1 2000 1 2000 trials))))
(show #t "Test 02:" (estimate-pi 100100) "\n")
#+end_src
#+RESULTS:
: Test 01: 907
: Test 02:3.148211788211788
It took me more time to understand what exactly is wanted than to write the
actual code.
*** DONE Exercise 3.6 reset a prng
CLOSED: [2019-10-30 Wed 11:42]
All three components in the random formula are primes. Is this good?
#+begin_src scheme :exports both :results output
(define rand
(let ((seed 1))
(define (rand-update x)
(remainder (+ (* x 111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111389)
211111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111801)
2111111111111111111111111111111111111111227))
(lambda (operation)
(case operation
('generate (begin (show #t "Seed=" seed "\n") (set! seed (rand-update seed)) seed))
('reset (lambda (number)
(set! seed number)))
(else (error "rand: wrong operation" operation))))))
(show #t "Test 01: First random call: " (rand 'generate) "\n")
((rand 'reset) 100)
(show #t "Test 02: Second random call: " (rand 'generate) "\n")
#+end_src
#+RESULTS:
: Seed=1
: Test 01: First random call: 473684210526315790444679008925823330256457
: Seed=100
: Test 02: Second random call: 701754385964912314820502646968297937855541
*** DONE Exercise 3.7 Joint accounts
CLOSED: [2019-10-30 Wed 13:07]
This exercise illustrates a fairly common thing in programming called
"wrapping" or "interfacing".
#+begin_src scheme :exports both :results output
(define (make-account balance password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch pass m)
(if (eq? pass password)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT"
m)))
(lambda rest "Incorrect password")))
dispatch)
(define acc (make-account 100 'secret-password))
(check ((acc 'secret-password 'withdraw) 40) => 60)
(check ((acc 'some-other-password 'deposit) 50) => "Incorrect password")
(define (make-joint account main-password sub-password)
(define (dispatch pass m)
(if (eq? pass sub-password)
(account main-password m)
(lambda rest "Incorrect password")))
dispatch)
(define peter-acc (make-account 100 'open-sesame))
(define paul-acc
(make-joint peter-acc 'open-sesame 'rosebud))
(check ((peter-acc 'open-sesame 'withdraw) 40) => 60)
(check ((paul-acc 'rosebud 'deposit) 50) => 110)
#+end_src
#+RESULTS:
:
: ((acc (quote secret-password) (quote withdraw)) 40) => 60 ; correct
:
: ((acc (quote some-other-password) (quote deposit)) 50) => "Incorrect password" ; correct
:
: ((peter-acc (quote open-sesame) (quote withdraw)) 40) => 60 ; correct
:
: ((paul-acc (quote rosebud) (quote deposit)) 50) => 110 ; correct
*** DONE Exercise 3.8 Right-to-left vs Left-to-right
CLOSED: [2019-10-30 Wed 13:45]
#+begin_src scheme :exports both :results output
(define (make-lock a)
(lambda (arg)
(if (= arg 0)
(set! a 0))
a))
(define f (make-lock 100))
(show #t "Test 01:" (+ (f 0) (f 1)) "\n")
(define-syntax plus-oneway
(syntax-rules ()
((plus-oneway a b) (let* ((first a)
(second b))
(+ first second)))))
(define-syntax plus-otherway
(syntax-rules ()
((plus-otherway a b) (let* ((first b)
(second a))
(+ first second)))))
(define g (make-lock 101))
(define h (make-lock 201))
(show #t "Test 02:" (plus-oneway (g 0) (g 1)) "\n")
(show #t "Test 03:" (plus-otherway (h 0) (h 1)) "\n")
#+end_src
#+RESULTS:
: Test 01:100
: Test 02:0
: Test 03:201
This is a fun exercise, which is nicely illustrated using
macros. Unlike ~+~, ~let*~ is guaranteed to evaluate its parameters
top to bottom, so we can specify the order of evaluation. The order of
evaluation in the next ~+~ does not matter, because its arguments are
already values and so evaluate to themselves.
*** TODO COMMENT Figure 3.5 :tikz:
#+name: remark-environments-tikz
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 800
#+header: :fit yes :headers '("\\usepackage{tikz}")
#+header: :buffer on
#+begin_src latex :results raw file :exports code :file figure-3-5.png
\begin{tikzpicture}
[color=white,
scheme/.style={filldraw,
rectangle,
draw=white,
fill=black!50,
rounded corners,
minimum size=2cm,
align=left}
]
\node (0,0) {};
\node (0,6.5) {};
\node (13.0,0) {};
\node (13.0,6.5) {};
%\filldraw[scheme,label=center:{x:2}] (2.0, 4.5) rectangle (13.0,6.5) ;
\path (7.5,5.5) node[scheme,minimum width=11.5cm,minimum height=2cm] { test }
%\filldraw[scheme] (2.0, 2.0) rectangle (4.0 ,4.0) ;
\path (3.0,3.0) node[scheme] {E2};
\filldraw[scheme] (5.0, 2.0) rectangle (7.0 ,4.0) ;
\filldraw[scheme] (8.0, 2.0) rectangle (10.0,4.0) ;
\filldraw[scheme] (11.0, 2.0) rectangle (13.0,4.0) ;
\draw[fill=yellow,font=\verylarge,align=left] (1.0,5.5) node {global\\ env};
\end{tikzpicture}
#+end_src
#+RESULTS: remark-environments-tikz
[[file:figure-3-9.png]]
*** DONE Exercise 3.9 Environment structures
CLOSED: [2019-11-20 Wed 14:28]
Okay, this is not a very good solution. I only display the
environments, and the code is only displayed to clarify the
environments. The ~if~ special forms are expanded.
Let us draw the environment number 1.
#+name: exercise-3-9-part-1
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-9-part-1.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm]
%
\node (W1) {factorial:};
\node (fake1) [right=190mm of W1] {};
%
\node (g env) [box, fit=(W1) (fake1),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
%
\path ([yshift=-20mm]W1.east)pic{two dots=w1fun}
(w1fun) edge [<-, to path={|- (\tikztotarget)}] (W1.east);
%
\node [below=of w1fun-left, align=left] {parameters: n \\ body: \dots}
edge [<-] (w1fun-left.center);
\path (w1fun-right.center) edge[->,to path={-| (\tikztotarget)}]
(node cs:name=g env,angle=183);
\path (g env.south west) -- (g env.south east)
\foreach \idx in {1,...,5}
{
node [pos=1/7.5+\idx/7.5] (fake2-\idx) {}
node (E\idx-env) [below=5mm of fake2-\idx,box,
pin={[pin distance=5mm]left:E\idx}] {n:\idx}
edge [->] (fake2-\idx)
node (E\idx-code) [below=5mm of E\idx-env, align=center]{
(* \the\numexpr7-\idx \hskip5pt (factorial \the\numexpr6-\idx))
}
}
node [pos=1/7.5+6/7.5] (fake2-6) {}
node (E6-env) [below=5mm of fake2-6,box,
pin={[pin distance=5mm]left:E6}] {n:1}
edge [->] (fake2-6)
node (E6-code) [below=5mm of E6-env, align=center]{
1
};
%\draw (g env.south east) node [draw=red,rectangle] {debug};
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-9-part-1
[[file:exercise-3-9-part-1.png]]
Let us draw the environment number 2.
#+name: exercise-3-9-part-2
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-9-part-2.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm]
\node (W1) {factorial:};
\node (fake1) [right=340mm of W1] {};
\node (fact-iter) [above=1mm of W1] {fact-iter:};
%
\node (g env) [box, fit=(W1) (fake1) (fact-iter),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
% factorial
\path ([yshift=-20mm]W1.east)pic{two dots=w1fun}
(w1fun) edge [<-, to path={|- (\tikztotarget)}] (W1.east);
\node [below=of w1fun-left, align=left] {\ttfamily \noindent parameters:\vphantom{d}n \\ body: \dots}
edge [<-] (w1fun-left.center);
\draw[->] (w1fun-right.center) -| ([xshift=3mm] w1fun-right.east |- g env.south);
% fact-iter
\path coordinate[base right=22mm of w1fun.east] (aux)
(aux) pic{two dots=fact-iter-fun}
(fact-iter-fun) edge [<-, to path={|- (\tikztotarget)}] (fact-iter.east);
\node [below=of fact-iter-fun-left, align=left,node font=\ttfamily] {
parameters:product,\\
\phantom{parameters:}counter,\\
\phantom{parameters:}max-count \\ body: \dots}
edge [<-] (fact-iter-fun-left.center);
\draw[->] (fact-iter-fun-right.center) -| ([xshift=3mm] fact-iter-fun-right.east |- g env.south);
\path (g env.south west) -- (g env.south east)
\foreach \idx in {1,...,6}
{
node [pos=2.6/7.5+\idx/11] (fake2-\idx) {}
node (E\idx-env) [below=5mm of fake2-\idx,box,
pin={[pin distance=5mm]left:E\idx}, align=left] {
counter:\idx\\
product:\pgfmathparse{int(factorial(\idx-1))}\pgfmathresult \\
max-count:6}
edge [->] (fake2-\idx)
node (E\idx-code) [below=5mm of E\idx-env, align=left]{
(fact-iter\\
(* counter product) \\
(+ counter 1) \\
max-count)
}
}
node [pos=2.6/7.5+7/11] (fake2-7) {}
node (E7-env) [below=5mm of fake2-7,box,
pin={[pin distance=5mm]left:E7},align=left]
{counter:7\\
product:\pgfmathparse{int(factorial(7-1))}\pgfmathresult \\
max-count:6
}
edge [->] (fake2-7)
node (E7-code) [below=5mm of E7-env, align=center]{
720
}
node [pos=2.0/7.5] (fake2-0) {}
node (E0-env) [below=5mm of fake2-0, box,
pin={[pin distance=5mm]left:E0},align=left]
{n:6}
edge [->] (fake2-0)
node (E0-code) [below=5mm of E0-env, align=left]{
(fact-iter 1 1 n)}
;
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-9-part-2
[[file:exercise-3-9-part-2.png]]
These pictures would have never happened unless generous people from
TeX StackExchange had helped.
- https://tex.stackexchange.com/questions/515909/how-to-make-this-tikz-picture-more-idiomatic-environment-diagram/515913
- https://tex.stackexchange.com/questions/516560/how-to-place-evenly-spaced-nodes-in-tikz-from-node1-to-node2
- https://tex.stackexchange.com/questions/517061/how-to-debug-token-positions-in-petri-nets-in-tikz
- https://tex.stackexchange.com/questions/517217/how-is-text-indented-and-glued-within-tikz-node-contents
I feel that these diagrams are already quite cluttered, so I am
implicitly expanding ~if~ forms in the "code" blocks. I am also
ignoring top level commands and I am not drawing arrows when function
calls occur.[fn:2]
*** TODO Figure 3.9 Environments after the call to W1
#+name: remark-environments-3-9
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 800
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file figure-3-9.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50]
\begin{scope} [node distance=4mm]
\node (make withdraw) {make-withdraw: ...};
\node (fake1) [right=of make withdraw,xshift=40mm] {};
\node (W1) [below=of make withdraw.west,anchor=west] {W1:};
\end{scope}
\node (g env) [draw,rectangle,inner sep=2mm, fit=(make withdraw) (W1) (fake1)]
{ };
\node (g env name) [left={of g env},text width=1cm]
{global env} edge[->,very thick] (g env);
\begin{scope}[node distance=0mm]
\node [draw,minimum size=5mm,circle,tokens=1,below=of W1.east, yshift=-20mm] (w1fun-left) {};
\node [draw,minimum size=5mm,circle,tokens=1,right=of w1fun-left, xshift=0mm]
(w1fun-right) {};
\node [rectangle, fit=(w1fun-left) (w1fun-right)] (w1fun)
{} edge [<-, to path={|- (\tikztotarget)}] (W1.east);
\end{scope}
\node [below=of w1fun-left, align=left] {parameters: amount \\ body:...}
edge [<-] (w1fun-left.center);
\node (E1-env) [below=of g env,yshift=5mm,draw,inner sep=2mm] {balance: amount}
edge [->] (g env);
\node [left=of E1-env,xshift=5mm] {E1} edge [->] (E1-env);
\path (w1fun-right.center) edge[->,to path={-| (\tikztotarget)}] (E1-env.south);
\end{tikzpicture}
#+end_src
#+RESULTS: remark-environments-3-9
[[file:figure-3-9.png]]
*** DONE Exercise 3.10 Using ~let~ to create state variables
CLOSED: [2019-11-25 Mon 12:52]
We need to compare two versions of ~make-withdraw~, the one using a
parameter variable as a state variable, the one created automatically,
and the one which creates a state variable explicitly using ~let~.
The first one:
#+begin_src scheme :exports both :results output
(define (make-withdraw balance)
(lambda (amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds")))
#+end_src
#+name: exercise-3-10-part-1
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-10-part-1.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm]
\node (W1) {make-withdraw:};
\node (fake1) [right=100mm of W1] {};
\node (fact-iter) [above=3mm of W1.west,anchor=west] {W1:};
%
\node (g env) [box, fit=(W1) (fake1) (fact-iter),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
\path ([yshift=-20mm]W1.east)pic{two dots=w1fun}
(w1fun) edge [<-, to path={|- (\tikztotarget)}] (W1.east);
\node [below=of w1fun-left, align=left,font=\ttfamily]
{\noindent parameters:\vphantom{d}balance \\
body:\\
(lambda (amount)\\
(if (>= balance amount)\\
(begin (set! balance\\ (- balance amount))\\
balance)\\
"Insufficient funds"))
}
edge [<-] (w1fun-left.center);
\draw[->] (w1fun-right.center) -| ([xshift=3mm] w1fun-right.east |- g env.south);
\path (g env.south west) -- (g env.south east)
node [pos=7/8] (fake2-7) {}
node (E7-env) [below=5mm of fake2-7,box,
pin={[pin distance=5mm]left:E1},align=left]
{balance:100}
edge [->] (fake2-7) ;
\path coordinate[below right=5mm and 40mm of w1fun] (aux)
(aux) pic{two dots=fact-iter-fun}
(fact-iter-fun) edge [<-, to path={|- (\tikztotarget)}] (fact-iter.east);
\node [below=of fact-iter-fun-left, align=left,node font=\ttfamily] {
parameters:amount \\
body: (if (>= balance amount)\\
(begin (set! balance\\ (- balance amount))\\
balance)}
edge [<-] (fact-iter-fun-left.center);
\draw[->] (fact-iter-fun-right.center) -| (E7-env.south);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-10-part-1
[[file:exercise-3-10-part-1.png]]
The second one:
#+begin_src scheme :exports both :results output
(define (make-withdraw initial-amount)
(let ((balance initial-amount))
(lambda (amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))))
#+end_src
#+name: exercise-3-10-part-2
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-10-part-2.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm]
\node (W1) {make-withdraw:};
\node (fake1) [right=100mm of W1] {};
\node (fact-iter) [above=3mm of W1.west,anchor=west] {W1:};
%
\node (g env) [box, fit=(W1) (fake1) (fact-iter),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
\path ([yshift=-20mm]W1.east)pic{two dots=w1fun}
(w1fun) edge [<-, to path={|- (\tikztotarget)}] (W1.east);
\node [below=of w1fun-left, align=left,font=\ttfamily]
{\noindent parameters:initial-amount \\
body:\\
(let ((balance initial-amount))\\
(lambda (amount)\\
(if (>= balance amount)\\
(begin (set! balance\\ (- balance amount))\\
balance)\\
"Insufficient funds"))
}
edge [<-] (w1fun-left.center);
\draw[->] (w1fun-right.center) -| ([xshift=3mm] w1fun-right.east |- g env.south);
\path (g env.south west) -- (g env.south east)
node [pos=7/8] (fake2-7) {}
node (E7-env) [below=5mm of fake2-7,box,
pin={[pin distance=5mm]left:E1},align=left]
{initial-amount:100}
edge [->] (fake2-7)
node (E2) [below=5mm of E7-env,box,
pin={[pin distance=5mm]left:E2},align=left]
{balance:100}
edge [->] (E7-env)
;
\path coordinate[below right=15mm and 40mm of w1fun] (aux)
(aux) pic{two dots=fact-iter-fun}
(fact-iter-fun) edge [<-, to path={|- (\tikztotarget)}] (fact-iter.east);
\node [below=of fact-iter-fun-left, align=left,node font=\ttfamily] {
parameters:amount \\
body: (if (>= balance amount)\\
(begin (set! balance\\ (- balance amount))\\
balance)}
edge [<-] (fact-iter-fun-left.center);
\draw[->] (fact-iter-fun-right.center) -| (E2);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-10-part-2
[[file:exercise-3-10-part-2.png]]
I think these two diagrams explain things quite well. An additional
~let~ creates an additional frame, which is visible on the figure
[[exercise-3-10-part-2]].
*** DONE Exercise 3.11 Internal definitions
CLOSED: [2019-11-26 Tue 12:44]
This is a huge task. Let us first draw ~make-account~, and then
improve on it.
#+name: exercise-3-11-part-1
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-11-part-1.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
node distance=4mm]
\node (W1) {make-account:};
\node (fake1) [right=100mm of W1] {};
\node (fact-iter) [above=3mm of W1.west,anchor=west] {acc:};
%
\node (g env) [box, fit=(W1) (fake1) (fact-iter),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
\path ([yshift=-20mm]W1.east)pic{two dots=w1fun}
(w1fun) edge [<-, to path={|- (\tikztotarget)}] (W1.east);
\node [below=5mm of w1fun-left, align=left,font=\ttfamily]
{\noindent parameters:\vphantom{d}balance \\
body:\\
(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))))\\
dispatch
}
edge [<-] (w1fun-left.center);
\draw[->] (w1fun-right.center) -| ([xshift=3mm] w1fun-right.east |- g env.south);
\path (g env.south west) -- (g env.south east)
node [pos=7/8] (fake2-7) {}
node (balance-var) [below=6mm of fake2-7] {\vphantom{l}balance:30}
node (withdraw-var) [below=of balance-var.west,anchor=west] {\vphantom{l}withdraw:}
node (deposit-var) [below=of withdraw-var.west,anchor=west] {\vphantom{l}deposit:}
node (E7-env) [box,
pin={[pin distance=5mm]left:E1},align=left,
fit=(balance-var) (deposit-var) (withdraw-var)]
{}
edge [->] (fake2-7) ;
\path coordinate[below right=5mm and 40mm of w1fun] (aux)
(aux) pic{two dots=fact-iter-fun}
(fact-iter-fun) edge [<-, to path={|- (\tikztotarget)}] (fact-iter.east);
\node [below=5mm of fact-iter-fun-left, align=left,node font=\ttfamily] {
parameters:m \\
body: (cond ((eq? m 'withdraw) withdraw)\\
((eq? m 'deposit) deposit)\\
(else\\
(error "Unknown request: MAKE-ACCOUNT"\\
m)))
}
edge [<-] (fact-iter-fun-left.center);
\draw[->] (fact-iter-fun-right.center) -| ($ (E7-env.south) - (5mm,0mm) $);
\path coordinate[below right=10mm and 13mm of E7-env.south] (aux)
(aux) pic{two dots=deposit}
(deposit) edge [<-, to path={|- (\tikztotarget)}] (deposit-var.east);
\node [below=5mm of deposit-left, align=left,node font=\ttfamily] {
parameters:amount \\
body: (set! balance\\ (+ balance amount))\\
balance
}
edge [<-] (deposit-left.center);
\draw[->] (deposit-right.center) |- (fact-iter-fun -| E7-env.south) -| ($ (E7-env.south) - (0mm,0mm) $);
\path coordinate[below right=10mm and 50mm of E7-env.south] (aux)
(aux) pic{two dots=withdraw}
(withdraw) edge [<-, to path={|- (\tikztotarget)}] (withdraw-var.east);
\node [below=5mm of withdraw-left, align=left,node font=\ttfamily] {
parameters:amount \\
body: (set! balance\\ (- balance amount))\\
balance
}
edge [<-] (withdraw-left.center);
\draw[->] (withdraw-right.center) |- ($ (E7-env.east) + (0mm,5mm) $);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-11-part-1
[[file:exercise-3-11-part-1.png]]
I am not plotting the intermediate environments, that is too much
work, but the important thing is that when ~acc~ is evaluated, the
evaluation frame is appended to the environment E1, and the lookup is
performed in the enclosing environment, including the bindings for
~dispatch~ and ~withdraw~.
The state for ~acc~ is kept in the environment E1.
If we to define ~acc2~, the frame in which we define it would mean a
lot. Let us assume that we define ~acc2~ at the top level. This would
mean that now we would have two environments, E1 and E2 pointing, both
the children of the global environment. Only the global definitions
(that is ~make-account~, ~acc1~ and ~acc2~) would be shared.
*** DONE Exercise 3.12 Drawing ~append!~
CLOSED: [2019-11-29 Fri 11:55]
Now we need to draw box-and-pointer diagrams for the two variants of ~append~.
The first ~append~ can be drawn like this:
#+name: exercise-3-12-part1
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-12-part1.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1-car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1-cdr) at(0,0) {};
\node[name=#1-box,fit=(#1-car) (#1-cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1-box.south -| origin) -- (#1-box.north -| origin);
\if#2t
% \path node[shape=circle,fill,draw,radius=2mm] at (#1-car.center) {};
\filldraw (#1-car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1-car.south west) to (#1-car.north east);
\fi
\if#3t
\filldraw (#1-cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1-cdr.south west) to (#1-cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\node (x) {x};
\node[right=200mm of x] {};
\pic[right=of x] {cons cell={cell-a}{t}{t}};
\draw[->] (x) to (cell-a-box);
\pic[below=of cell-a-car] {cons element={a}{a}};
\pic[right=of cell-a-cdr] {cons cell={cell-b}{t}{f}};
\pic[below=of cell-b-car] {cons element={b}{b}};
\draw[->] (cell-a-cdr.center) to (cell-b-box);
\draw[->] (cell-a-car.center) to (a);
\draw[->] (cell-b-car.center) to (b);
\node[right=of cell-b-box] (y) {y};
\pic[right=of y] {cons cell={cell-c}{t}{t}};
\draw[->] (y) to (cell-c-box);
\pic[below=of cell-c-car] {cons element={c}{c}};
\pic[right=of cell-c-cdr] {cons cell={cell-d}{t}{f}};
\pic[below=of cell-d-car] {cons element={d}{d}};
\draw[->] (cell-c-cdr.center) to (cell-d-box);
\draw[->] (cell-c-car.center) to (c);
\draw[->] (cell-d-car.center) to (d);
\node[below=50mm of x] (z) {z};
\pic[right=of z] {cons cell={cell-a-2}{t}{t}};
\draw[->] (z) to (cell-a-2-box);
\pic[below=of cell-a-2-car] {cons element={a2}{a}};
\pic[right=of cell-a-2-cdr] {cons cell={cell-b-2}{t}{t}};
\pic[below=of cell-b-2-car] {cons element={b2}{b}};
\pic[right=of cell-b-2-cdr] {cons cell={cell-c-2}{t}{t}};
\pic[below=of cell-c-2-car] {cons element={c2}{c}};
\pic[right=of cell-c-2-cdr] {cons cell={cell-d-2}{t}{f}};
\pic[below=of cell-d-2-car] {cons element={d2}{d}};
\draw[->] (cell-a-2-cdr.center) to (cell-b-2-box);
\draw[->] (cell-a-2-car.center) to (a2);
\draw[->] (cell-b-2-car.center) to (b2);
\draw[->] (cell-b-2-cdr.center) to (cell-c-2-box);
\draw[->] (cell-c-2-car.center) to (c2);
\draw[->] (cell-c-2-cdr.center) to (cell-d-2-box);
\draw[->] (cell-d-2-car.center) to (d2);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-12-part1
[[file:exercise-3-12-part1.png]]
#+begin_src scheme :exports both :results value
?
(define x (list 'a 'b))
(define y (list 'c 'd))
(define z (append x y))
z
(cdr x)
#+end_src
#+RESULTS:
| b |
The second append, done with ~append!~ , modifies ~x~.
#+name: exercise-3-12-part2
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-12-part2.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1-car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1-cdr) at(0,0) {};
\node[name=#1-box,fit=(#1-car) (#1-cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1-box.south -| origin) -- (#1-box.north -| origin);
\if#2t
% \path node[shape=circle,fill,draw,radius=2mm] at (#1-car.center) {};
\filldraw (#1-car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1-car.south west) to (#1-car.north east);
\fi
\if#3t
\filldraw (#1-cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1-cdr.south west) to (#1-cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\node (x) {x};
\node[right=200mm of x] {};
\pic[right=of x] {cons cell={cell-a}{t}{t}};
\draw[->] (x) to (cell-a-box);
\pic[below=of cell-a-car] {cons element={a}{a}};
\pic[right=of cell-a-cdr] {cons cell={cell-b}{t}{t}};
\pic[below=of cell-b-car] {cons element={b}{b}};
\draw[->] (cell-a-cdr.center) to (cell-b-box);
\draw[->] (cell-a-car.center) to (a);
\draw[->] (cell-b-car.center) to (b);
\node[right=of cell-b-box] (y) {y};
\pic[right=of y] {cons cell={cell-c}{t}{t}};
\draw[->] (y) to (cell-c-box);
\pic[below=of cell-c-car] {cons element={c}{c}};
\pic[right=of cell-c-cdr] {cons cell={cell-d}{t}{f}};
\pic[below=of cell-d-car] {cons element={d}{d}};
\draw[->] (cell-c-cdr.center) to (cell-d-box);
\draw[->] (cell-c-car.center) to (c);
\draw[->] (cell-d-car.center) to (d);
%\draw (cell-b-cdr.center) -- controls (5cm,1cm) and (6cm,1cm) -- (cell-c-box.center);
\draw[->] (cell-b-cdr.center) .. controls ($ (y.north) + (0,5mm) $) .. (cell-c-box);
\node[above=of cell-a-car] (w) {w};
\draw[->] (w) to (cell-a-car);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-12-part2
[[file:exercise-3-12-part2.png]]
Therefore, the answer is the following:
#+begin_src scheme :exports both :results value
<<last-pair>>
(define (append! x y)
(set-cdr! (last-pair x) y)
x)
(define x (list 'a 'b))
(define y (list 'c 'd))
(define w (append! x y))
w
(cdr x)
#+end_src
#+RESULTS:
| b | c | d |
*** DONE Exercise 3.13 ~make-cycle~
CLOSED: [2019-11-29 Fri 12:09]
This thing is called a "circular list".
#+begin_src scheme :exports both :results value
<<last-pair>>
(define (make-cycle x)
(set-cdr! (last-pair x) x)
x)
(define z (make-cycle (list 'a 'b 'c)))
z
#+end_src
#+RESULTS:
: (a b c...
#+name: exercise-3-13
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-12.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1-car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1-cdr) at(0,0) {};
\node[name=#1-box,fit=(#1-car) (#1-cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1-box.south -| origin) -- (#1-box.north -| origin);
\if#2t
% \path node[shape=circle,fill,draw,radius=2mm] at (#1-car.center) {};
\filldraw (#1-car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1-car.south west) to (#1-car.north east);
\fi
\if#3t
\filldraw (#1-cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1-cdr.south west) to (#1-cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\node (z) {z};
\node[right=200mm of z] {};
\pic[right=of z] {cons cell={cell-a}{t}{t}};
\draw[->] (z) to (cell-a-box);
\pic[below=of cell-a-car] {cons element={a}{a}};
\pic[right=of cell-a-cdr] {cons cell={cell-b}{t}{t}};
\pic[below=of cell-b-car] {cons element={b}{b}};
\draw[->] (cell-a-cdr.center) to (cell-b-box);
\draw[->] (cell-a-car.center) to (a);
\draw[->] (cell-b-car.center) to (b);
\pic[right=of cell-b-box] {cons cell={cell-c}{t}{t}};
\pic[below=of cell-c-car] {cons element={c}{c}};
\draw[->] (cell-c-car.center) to (c);
\draw[->] (cell-b-cdr.center) to (cell-c-box);
\draw[->] (cell-c-cdr.center) .. controls ($ (cell-c-cdr.center) + (0,30mm) $)
and ($ (cell-a-car.center) + (0,30mm) $) .. (cell-a-car);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-13
[[file:exercise-3-12.png]]
*** DONE Exercise 3.14 ~mystery~
CLOSED: [2019-11-29 Fri 21:23]
#+begin_src scheme :exports both :results output
(define (mystery x)
(define (loop x y)
(if (null? x)
y
(let ((temp (cdr x)))
(set-cdr! x y)
(loop temp x))))
(loop x '()))
(define v (list 'a 'b 'c 'd))
(show #t "initial v: " v "\n")
(define w (mystery v))
(show #t "w: " w "\n")
(show #t "what remains of v: " v "\n")
#+end_src
#+RESULTS:
: Initial v: (a b c d)
: w: (d c b a)
: what remains of v: (a)
The ~mystery~ procedure is roughly equivalent to ~(reverse x)~, except
that it works in constant space, whereas an ordinary ~reverse~
additionally uses as much space as ~x~ occupies.
Let us plot ~v~ before the operation.
#+name: exercise-3-14-part1
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-14-part1.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1-car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1-cdr) at(0,0) {};
\node[name=#1-box,fit=(#1-car) (#1-cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1-box.south -| origin) -- (#1-box.north -| origin);
\if#2t
\filldraw (#1-car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1-car.south west) to (#1-car.north east);
\fi
\if#3t
\filldraw (#1-cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1-cdr.south west) to (#1-cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\node (v) {v};
\pic[right=of v] {cons cell={cell-a-2}{t}{t}};
\draw[->] (v) to (cell-a-2-box);
\pic[below=of cell-a-2-car] {cons element={a2}{a}};
\pic[right=of cell-a-2-cdr] {cons cell={cell-b-2}{t}{t}};
\pic[below=of cell-b-2-car] {cons element={b2}{b}};
\pic[right=of cell-b-2-cdr] {cons cell={cell-c-2}{t}{t}};
\pic[below=of cell-c-2-car] {cons element={c2}{c}};
\pic[right=of cell-c-2-cdr] {cons cell={cell-d-2}{t}{f}};
\pic[below=of cell-d-2-car] {cons element={d2}{d}};
\draw[->] (cell-a-2-cdr.center) to (cell-b-2-box);
\draw[->] (cell-a-2-car.center) to (a2);
\draw[->] (cell-b-2-car.center) to (b2);
\draw[->] (cell-b-2-cdr.center) to (cell-c-2-box);
\draw[->] (cell-c-2-car.center) to (c2);
\draw[->] (cell-c-2-cdr.center) to (cell-d-2-box);
\draw[->] (cell-d-2-car.center) to (d2);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-14-part1
[[file:exercise-3-14.png]]
~mystery~ reverses the list, so the diagram would be:
#+name: exercise-3-14-part2
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-14-part2.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1-car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1-cdr) at(0,0) {};
\node[name=#1-box,fit=(#1-car) (#1-cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1-box.south -| origin) -- (#1-box.north -| origin);
\if#2t
\filldraw (#1-car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1-car.south west) to (#1-car.north east);
\fi
\if#3t
\filldraw (#1-cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1-cdr.south west) to (#1-cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\node (w) {w};
\pic[right=of w] {cons cell={cell-a-2}{t}{t}};
\draw[->] (w) to (cell-a-2-box);
\pic[below=of cell-a-2-car] {cons element={a2}{d}};
\pic[right=of cell-a-2-cdr] {cons cell={cell-b-2}{t}{t}};
\pic[below=of cell-b-2-car] {cons element={b2}{c}};
\pic[right=of cell-b-2-cdr] {cons cell={cell-c-2}{t}{t}};
\pic[below=of cell-c-2-car] {cons element={c2}{b}};
\pic[right=of cell-c-2-cdr] {cons cell={cell-d-2}{t}{f}};
\pic[below=of cell-d-2-car] {cons element={d2}{a}};
\draw[->] (cell-a-2-cdr.center) to (cell-b-2-box);
\draw[->] (cell-a-2-car.center) to (a2);
\draw[->] (cell-b-2-car.center) to (b2);
\draw[->] (cell-b-2-cdr.center) to (cell-c-2-box);
\draw[->] (cell-c-2-car.center) to (c2);
\draw[->] (cell-c-2-cdr.center) to (cell-d-2-box);
\draw[->] (cell-d-2-car.center) to (d2);
\node[above=of cell-d-2-car] (v) {v};
\draw[->] (v) to (cell-d-2-car);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-14-part2
[[file:exercise-3-14-part2.png]]
~v~ still points to the cell containing ~'x~, but now the ~car~ of
this cell is an empty list.
*** DONE Exercise 3.15 ~set-to-wow!~
CLOSED: [2019-12-01 Sun 19:59]
#+begin_src scheme :exports both :results output
(define (set-to-wow! x)
(set-car! (car x) 'wow)
x)
(define x (list 'a 'b))
(define z1 (cons x x))
(define z2 (cons (list 'a 'b) (list 'a 'b)))
(show #t "The structures are: \n" z1 "\n" z2 "\n")
(set-to-wow! z1)
(show #t "Modified z1: " z1 "\n")
(set-to-wow! z2)
(show #t "Modifier z2: " z2 "\n")
#+end_src
#+RESULTS:
: The structures are:
: ((a b) a b)
: ((a b) a b)
: Modified z1: ((wow b) wow b)
: Modifier z2: ((wow b) a b)
First let us draw ~z1~ after ~set-to-wow!~.
#+name: exercise-3-15-part1
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc,graphs}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-15-part1.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1!car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1!cdr) at(0,0) {};
\node[name=#1!box,fit=(#1!car) (#1!cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1!box.south -| origin) -- (#1!box.north -| origin);
\if#2t
\filldraw (#1!car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1!car.south west) to (#1!car.north east);
\fi
\if#3t
\filldraw (#1!cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1!cdr.south west) to (#1!cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\matrix[row sep=10mm,column sep=20mm] {
\node (z1!var) {z1}; & \pic{cons cell={z1}{t}{t}}; & \\
\node (x) {x}; & \pic{cons cell={list1}{t}{t}}; & \pic{cons cell={list2}{t}{f}}; \\
& \pic[below=5mm of list1!car]{cons element={a}{wow}}; & \pic[below=5mm of list2!car]{cons element={b}{b}};\\
};
\node[right=200mm of z1!var] {};
\graph[use existing nodes]
{
z1!var -> z1!box ;
z1!car.center -> list1!car;
z1!cdr.center -> list1!cdr;
list1!cdr.center -> list2!box;
list1!car.center -> a;
list2!car.center -> b;
x -> list1!box;
};
%\draw[->] (z1-var) -- (x);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-15-part1
[[file:exercise-3-15-part1.png]]
Next we shall plot ~z2~ after ~set-to-wow!~.
#+name: exercise-3-15-part2
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc,graphs}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-15-part2.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1!car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1!cdr) at(0,0) {};
\node[name=#1!box,fit=(#1!car) (#1!cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1!box.south -| origin) -- (#1!box.north -| origin);
\if#2t
\filldraw (#1!car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1!car.south west) to (#1!car.north east);
\fi
\if#3t
\filldraw (#1!cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1!cdr.south west) to (#1!cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\matrix[row sep=20mm,column sep=20mm] {
& \pic[xshift=-5mm]{cons element={wow}{wow}}; & \\
\node (z2!var) {z2}; & \pic{cons cell={z21}{t}{t}}; & \pic{cons cell={z22}{t}{f}}; \\
& \pic[xshift=-5mm]{cons element={a}{a}}; & \pic[xshift=-5mm]{cons element={b}{b}}; \\
& \pic{cons cell={z23}{t}{t}}; & \pic{cons cell={z24}{t}{f}};\\
};
\node[right=200mm of z2!var] {};
\graph[use existing nodes]
{
z2!var -> z21!box ;
z21!car.center -> wow;
z21!cdr.center -> z22!box;
z22!car.center -> b;
z23!car.center -> a;
z23!cdr.center -> z24!box;
z24!car.center -> b;
};
%\draw[->] (z1-var) -- (x);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-15-part2
[[file:exercise-3-15-part2.png]]
The picture should explain the result of ~set-to-wow!~ fairly well.
*** DONE Exercise 3.16 ~count-pairs~
CLOSED: [2019-12-02 Mon 00:05]
#+begin_src scheme :exports both :results output
(define (count-pairs x)
(if (not (pair? x))
0
(+ (count-pairs (car x))
(count-pairs (cdr x))
1)))
(show #t "Return three: " (count-pairs (list 'a 'b 'c)) "\n")
(show #t "Return four: " (count-pairs (let ((x (list 'a 'b 'c)))
(set-car! (cdr x) (cddr x)) x)) "\n")
(show #t "Return seven: " (count-pairs (let ((x (list 'a 'b 'c)))
(set-car! x (cdr x))
(set-car! (cdr x) (cddr x))
x)) "\n")
(show #t "Never return: "
(let ((x (list 'a 'b 'c)))
(set-cdr! (cddr x) x)
x) "\n")
#+end_src
#+RESULTS:
: Return three: 3
: Return four: 4
: Return seven: 7
: Never return: #0=(a b c . #0#)
#+name: exercise-3-16
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc,graphs}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-16.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,
node distance=20mm,
pics/cons cell/.style n args={3}{code={
\coordinate (origin);
\node[anchor=east,minimum size=10mm,inner sep=0] (#1!car) at(0,0) {};
\node[anchor=west,minimum size=10mm,inner sep=0] (#1!cdr) at(0,0) {};
\node[name=#1!box,fit=(#1!car) (#1!cdr),draw,shape=rectangle,rounded
corners=0.5mm] {};
\draw[shorten <=1pt, shorten >=1pt] (#1!box.south -| origin) -- (#1!box.north -| origin);
\if#2t
% \path node[shape=circle,fill,draw,radius=2mm] at (#1-car.center) {};
\filldraw (#1!car.center) circle[radius=0.66mm] ;
\else
\draw[shorten <=1pt] (#1!car.south west) to (#1!car.north east);
\fi
\if#3t
\filldraw (#1!cdr.center) circle[radius=0.66mm] ;
\else
\draw[shorten >=1pt] (#1!cdr.south west) to (#1!cdr.north east);
\fi
}},
pics/cons element/.style n args={2}{code={
\node [xshift=-5mm,minimum size=10mm,inner sep=0,rounded corners=1mm, draw, shape=rectangle] (#1) {#2};
}},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
]
\matrix[row sep=10mm,column sep=20mm] {
\pic{cons cell={cell1}{t}{t}}; & \pic{cons cell={cell2}{t}{t}}; & \pic{cons cell={cell3}{t}{f}}; \\
\pic{cons element={a}{a}}; & \pic{cons element={b}{b}}; & \pic{cons element={c}{d}}; \\
\pic{cons cell={cell4}{t}{t}}; & \pic{cons cell={cell5}{t}{t}}; & \pic{cons cell={cell6}{t}{f}}; \\
\pic{cons element={a2}{a}}; & & \pic{cons element={c2}{c}}; \\
\pic{cons cell={cell7}{t}{t}}; & \pic{cons cell={cell8}{t}{t}}; & \pic{cons cell={cell9}{t}{f}}; \\
& & \pic{cons element={c3}{c}}; \\
\pic{cons cell={cell10}{t}{t}}; & \pic{cons cell={cell11}{t}{t}}; & \pic{cons cell={cell12}{t}{t}}; \\
\pic{cons element={a4}{a}}; & \pic{cons element={b4}{b}}; & \pic{cons element={c4}{d}}; \\
};
\node[right=200mm of cell1!box] {};
\graph[use existing nodes,
skip loop/.style={to path={-- ++(0,#1) -| (\tikztotarget)}}]
{
cell1!cdr.center -> cell2!box;
cell1!car.center -> a;
cell2!car.center -> b;
cell2!cdr.center -> cell3!box;
cell3!car.center -> c;
cell4!cdr.center -> cell5!box;
cell4!car.center -> a2;
cell5!car.center ->[skip loop=10mm] cell6!car;
cell5!cdr.center -> cell6!box;
cell6!car.center -> c2;
cell7!cdr.center -> cell8!box;
cell7!car.center ->[skip loop=-10mm] cell8!car;
cell8!cdr.center -> cell9!box;
cell8!car.center ->[skip loop=10mm] cell9!car;
cell9!car.center -> c3;
cell10!car.center -> a4;
cell10!cdr.center -> cell11!box;
cell11!car.center -> b4;
cell11!cdr.center -> cell12!box;
cell12!car.center -> c4;
cell12!cdr.center ->[skip loop=10mm] cell10!car;
};
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-16
[[file:exercise-3-16.png]]
*** DONE Exercise 3.17 Real ~count-pairs~
CLOSED: [2019-12-02 Mon 00:47]
This is an inefficient solution, because it uses an O(n) lookup.
#+begin_src scheme :exports both :results output
(define (count-pairs s)
(define my-set (list))
(define (count-pairs-loop x)
(cond ((not (pair? x)) 0)
((memq x my-set) 0)
(else (begin
(set! my-set (append my-set (list x)))
(+ (count-pairs-loop (car x))
(count-pairs-loop (cdr x))
1)))))
(set! my-set (list))
(count-pairs-loop s))
(show #t "Returned three: " (count-pairs (list 'a 'b 'c)) "\n")
(show #t "Returned four: " (count-pairs (let ((x (list 'a 'b 'c)))
(set-car! (cdr x) (cddr x)) x)) "\n")
(show #t "Returned seven: " (count-pairs (let ((x (list 'a 'b 'c)))
(set-car! x (cdr x))
(set-car! (cdr x) (cddr x))
x)) "\n")
(show #t "Never returned: "
(count-pairs (let ((x (list 'a 'b 'c)))
(set-cdr! (cddr x) x)
x)) "\n")
#+end_src
#+RESULTS:
: Returned three: 3
: Returned four: 3
: Returned seven: 3
: Never returned: 3
*** DONE Exercise 3.18 Finding cycles
CLOSED: [2019-12-02 Mon 01:04]
Still not a very efficient solution, but it works.
#+begin_src scheme :exports both :results output
(define (is-cyclic? y)
(define seen-elements (list))
(define (is-s-l x)
(cond ((not (pair? x)) #f)
((null? x) #f)
((memq x seen-elements) #t)
(else (begin
(set! seen-elements (append seen-elements (list x)))
(is-s-l (cdr x))))))
(set! seen-elements (list))
(is-s-l y))
(show #t "Returned three: " (is-cyclic? (list 'a 'b 'c)) "\n")
(show #t "Returned four: " (is-cyclic? (let ((x (list 'a 'b 'c)))
(set-car! (cdr x) (cddr x)) x)) "\n")
(show #t "Returned seven: " (is-cyclic? (let ((x (list 'a 'b 'c)))
(set-car! x (cdr x))
(set-car! (cdr x) (cddr x))
x)) "\n")
(show #t "Never returned: "
(is-cyclic? (let ((x (list 'a 'b 'c)))
(set-cdr! (cddr x) x)
x)) "\n")
#+end_src
#+RESULTS:
: Returned three: #f
: Returned four: #f
: Returned seven: #f
: Never returned: #t
*** DONE Exercise 3.19 Efficient finding cycles
CLOSED: [2019-12-02 Mon 23:29]
The idea that we are going to explore in this exercise is slightly
similar to the dynamic programming. This will not be efficient at all,
but will eventually find not just whether the list has a cycle, but
also the length of the cycle.
#+begin_src scheme :exports both :results output
(define (is-cyclic? l)
(let loop ((starting-elem 0)
(cycle-len 1))
(cond ((or (not (pair? (drop l starting-elem)))
(not (pair? (drop l (+ starting-elem cycle-len)))))
#f)
((eq? (drop l starting-elem)
(drop l (+ starting-elem cycle-len))) #t)
((> starting-elem 0) (loop (- starting-elem 1) (+ cycle-len 1)))
(else (loop cycle-len 1)))))
(show #t "Returned three: " (is-cyclic? (list 'a 'b 'c)) "\n")
(show #t "Returned four: " (is-cyclic? (let ((x (list 'a 'b 'c)))
(set-car! (cdr x) (cddr x)) x)) "\n")
(show #t "Returned seven: " (is-cyclic? (let ((x (list 'a 'b 'c)))
(set-car! x (cdr x))
(set-car! (cdr x) (cddr x))
x)) "\n")
(show #t "Never returned: "
(is-cyclic? (let ((x (list 'a 'b 'c)))
(set-cdr! (cddr x) x)
x)) "\n")
#+end_src
#+RESULTS:
: Returned three: #f
: Returned four: #f
: Returned seven: #f
: Never returned: #t
The not very clever idea used here is that we can check if an element
~x~ is a start of a loop of length ~n~. Therefore we can iterate over
all possible values of ~x~ and ~n~. This exercise uses the ~(scheme
list)~ standard library from R7RS.
This algorithm clearly only uses O(1) memory, since we only remember
the number of the starting element and the cycle length.
*** DONE Exercise 3.20 Procedural ~set-car!~
CLOSED: [2019-12-03 Tue 14:40]
I am excluding the definitions from the diagram, they are cumbersome.
#+name: exercise-3-20
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-20.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
node distance=4mm]
\node (x-global) {x:};
\node (fake1) [right=100mm of x-global] {};
\node (z-global) [above=3mm of x-global.west,anchor=west] {z:};
%
\node (g env) [box, fit=(z-global) (fake1) (x-global),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
\path (g env.south west) -- (g env.south east)
node [pos=2/8] (fake2-7) {}
node (x-var) [below=6mm of fake2-7] {\vphantom{l}x:17}
node (y-var) [below=of x-var.west,anchor=west] {\vphantom{l}y:2}
node (setx1) [below=of y-var.west,anchor=west] {\vphantom{l}set-x!: ...}
node (sety1) [below=of setx1.west,anchor=west] {\vphantom{l}set-y!: ...}
node (E1-env) [box,
pin={[pin distance=5mm]left:E1},align=left,
fit=(x-var) (y-var) (setx1) (sety1)]
{}
edge [->] (g env.south -| E1-env.north) ;
\path (g env.south west) -- (g env.south east)
node[pos=1/16] (anchor1)
coordinate[below=50 mm of anchor1] (aux)
(aux) pic{two dots=x-dispatch}
(x-dispatch) edge [<-, to path={|- (\tikztotarget)}] (x-global.east);
\draw[->] (x-dispatch-right.center) -| (E1-env.south);
\node [below=5mm of x-dispatch-left, align=left,font=\ttfamily]
{\noindent parameters:\vphantom{l}m \\
body:\\
(cond \\ ((eq? m 'car) x) \\
((eq? m 'cdr) y) \\
((eq? m 'set-car!) set-x!) \\
((eq? m 'set-cdr!) set-y!) \\
(else \\
(error "Undefined operation: CONS" m))) \\
}
edge [<-] (x-dispatch-left.center);
\path (g env.south west) -- (g env.south east)
node [pos=9/16] (fake-8) {}
node (x-var) [below=6mm of fake-8] {\vphantom{l}x:}
node (y-var) [below=of x-var.west,anchor=west] {\vphantom{l}y:}
node (setx1) [below=of y-var.west,anchor=west] {\vphantom{l}set-x!: ...}
node (sety1) [below=of setx1.west,anchor=west] {\vphantom{l}set-y!: ...}
node (E2-env) [box,
pin={[pin distance=5mm]left:E2},align=left,
fit=(x-var) (y-var) (setx1) (sety1)]
{}
edge [->] (g env.south -| E2-env.north) ;
\draw[->] (x-var.east) ++(1mm,0) -- ++(0,5mm) -| ($ (x-dispatch.north) + (1mm,0) $);
\draw[->] (y-var.east) -- ++(0,6mm) -| ($ (x-dispatch.north) + (2mm,0) $);
\path (g env.south west) -- (g env.south east)
node[pos=12/16] (anchor)
coordinate[below=50 mm of anchor] (aux)
(aux) pic{two dots=z-dispatch}
(z-dispatch) edge [<-, to path={|- (\tikztotarget)}] (z-global.east);
\draw[->] (z-dispatch-right.center) -- ++(0,7mm) -| (E2-env.south);
\node [below=5mm of z-dispatch-left, align=left,font=\ttfamily]
{\noindent parameters:\vphantom{l}m \\
body:\\
(cond \\ ((eq? m 'car) x) \\
((eq? m 'cdr) y) \\
((eq? m 'set-car!) set-x!) \\
((eq? m 'set-cdr!) set-y!) \\
(else \\
(error "Undefined operation: CONS" m))) \\
}
edge [<-] (z-dispatch-left.center);
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-20
[[file:exercise-3-20.png]]
I am only drawing the final environment, but the idea should be quite obvious.
*** DONE Exercise 3.21 queues
CLOSED: [2019-12-03 Tue 15:10]
#+begin_src scheme :exports both :results output :noweb-ref queue
(define (front-ptr queue) (car queue))
(define (rear-ptr queue)
(cdr queue))
(define (set-front-ptr! queue item)
(set-car! queue item))
(define (set-rear-ptr! queue item)
(set-cdr! queue item))
(define (empty-queue? queue)
(null? (front-ptr queue)))
(define (make-queue) (cons '() '()))
(define (front-queue queue)
(if (empty-queue? queue)
(error "FRONT called with an empty queue" queue)
(car (front-ptr queue))))
(define (insert-queue! queue item)
(let ((new-pair (cons item '())))
(cond ((empty-queue? queue)
(set-front-ptr! queue new-pair)
(set-rear-ptr! queue new-pair)
queue)
(else
(set-cdr! (rear-ptr queue) new-pair)
(set-rear-ptr! queue new-pair)
queue))))
(define (delete-queue! queue)
(cond ((empty-queue? queue)
(error "DELETE! called with an empty queue" queue))
(else (set-front-ptr! queue (cdr (front-ptr queue)))
queue)))
#+end_src
#+begin_src scheme :exports both :results output
<<queue>>
(define q1 (make-queue))
(show #t "(insert-queue! q1 'a) = " (insert-queue! q1 'a) "\n")
(show #t "(insert-queue! q1 'b) = " (insert-queue! q1 'b) "\n")
(show #t "(delete-queue! q1) = " (delete-queue! q1) "\n")
(show #t "insert " (insert-queue! q1 'c) "\n")
(show #t "(delete-queue! q1) = " (delete-queue! q1) "\n")
#+end_src
#+RESULTS:
: (insert-queue! q1 'a) = ((a) a)
: (insert-queue! q1 'b) = ((a b) b)
: (delete-queue! q1) = ((b) b)
: insert ((b c) c)
: (delete-queue! q1) = ((c) c)
I dare to say that this printed representation is correct, because it
not just displays the queue, but also shows what the end pointer marks.
Indeed, the queue is just a pair of a list and the final
pair. Moreover, even if the queue is empty, the last pair is not
destroyed, and therefore is displayed.
#+begin_src scheme :exports both :results output :noweb-ref print-queue
<<queue>>
(define (print-queue queue)
(display (car queue)))
#+end_src
#+begin_src scheme :exports both :results output
<<queue>>
<<print-queue>>
(define q1 (make-queue))
(print-queue (insert-queue! q1 'a))
(newline)
(print-queue (insert-queue! q1 'b))
(newline)
(print-queue (delete-queue! q1))
(newline)
(print-queue (delete-queue! q1))
#+end_src
#+RESULTS:
: (a)
: (a b)
: (b)
: ()
Everything is fine.
*** DONE Exercise 3.22 procedural queue
CLOSED: [2019-12-03 Tue 22:13]
#+begin_src scheme :exports both :results output :noweb-ref procedural-queue
(define (make-queue)
(let ((front-ptr (list))
(rear-ptr #f))
(define (front)
(if (null? front-ptr)
(error "FRONT called with an empty queue" queue)
(car front-ptr)))
(define (insert! x)
(let ((new-pair (cons x (list))))
(cond ((null? front-ptr)
(set! front-ptr new-pair)
(set! rear-ptr new-pair))
(else
(set-cdr! rear-ptr new-pair)
(set! rear-ptr new-pair)))))
(define (delete!)
(if (not (null? front-ptr))
(set! front-ptr (cdr front-ptr))
(error "Queue already empty" front-ptr)))
(define (dispatch m)
(cond ((eq? m 'empty-queue) (null? front-ptr))
((eq? m 'front) (front))
((eq? m 'insert!) insert!)
((eq? m 'delete!) delete!)
((eq? m 'print) (display front-ptr))
(else
(error "Undefined operation: queue" m))) )
dispatch))
(define (front-queue z)
(z 'front))
(define (empty-queue? z)
(z 'empty-queue))
(define (insert-queue! q z)
((q 'insert!) z)
q)
(define (delete-queue! q)
((q 'delete!))
q)
(define (print-queue q)
(q 'print)
(newline))
(define q1 (make-queue))
(empty-queue? q1)
(insert-queue! q1 'a)
(print-queue q1)
(insert-queue! q1 'b)
(print-queue q1)
(delete-queue! q1)
(print-queue q1)
(delete-queue! q1)
(print-queue q1)
#+end_src
#+RESULTS:
: (a)
: (a b)
: (b)
: ()
Well, makes sense. Not a very hard exercise.
*** DONE Exercise 3.23 dequeue
CLOSED: [2019-12-03 Tue 23:24]
#+begin_src scheme :exports both :results result :noweb-ref dequeue
(define (front-ptr deque) (car deque))
(define (rear-ptr deque)
(cdr deque))
(define (set-front-ptr! deque item)
(set-car! deque item))
(define (set-rear-ptr! deque item)
(set-cdr! deque item))
(define (empty-deque? deque)
(null? (front-ptr deque)))
(define (make-deque) (cons '() '()))
(define (get-item list-elem)
(cdr list-elem))
(define (get-backlink list-elem)
(car list-elem))
(define (front-deque deque)
(if (empty-deque? deque)
(error "FRONT called with an empty deque" deque)
(get-item (car (front-ptr deque)))))
(define (rear-deque deque)
(if (empty-deque? deque)
(error "REAR called with an empty deque" deque)
(get-item (car (rear-ptr deque)))))
(define (rear-insert-deque! deque item)
(let ((new-pair (cons (cons #f item) '())))
(cond ((empty-deque? deque)
(set-front-ptr! deque new-pair)
(set-rear-ptr! deque new-pair)
deque)
(else
(set-cdr! (rear-ptr deque) new-pair)
(set-car! new-pair (rear-ptr deque))
(set-rear-ptr! deque new-pair)
deque))))
(define (front-delete-deque! deque)
(cond ((empty-deque? deque)
(error "FRONT-DELETE! called with an empty deque" deque))
(else (set-front-ptr! deque (cdr (front-ptr deque)))
(set-car! (car (front-ptr deque)) '())
deque)))
(define (front-insert-deque! deque item)
(let ((new-pair (cons (cons '() item) '())))
(cond ((empty-deque? deque)
(set-front-ptr! deque new-pair)
(set-rear-ptr! deque new-pair)
deque)
(else
(set-cdr! new-pair (front-ptr deque))
(set-car! (car (front-ptr deque)) new-pair)
(set-front-ptr! deque new-pair)
deque))))
(define (rear-delete-deque! deque)
(cond ((empty-deque? deque)
(error "REAR-DELETE! called with an empty deque" deque))
(else (set-rear-ptr! deque (caar (rear-ptr deque)))
(if (not (null? (rear-ptr deque)))
(set-cdr! (rear-ptr deque) (list))
(set-front-ptr! deque '()))
deque)))
(define (print-deque q)
(display q))
(define dq1 (make-deque))
(front-insert-deque! dq1 'a)
(rear-insert-deque! dq1 'b)
(front-delete-deque! dq1)
(rear-delete-deque! dq1)
(empty-deque? dq1)
#+end_src
#+RESULTS:
: #t
*** Remark Table operations
Actually, these table operations are first required in the chapter 2,
Exercise-2.73. In order to avoid look-aheads, I am introducing this
pseudo-chapter so that the appropriate code could be tangled in.
#+begin_src scheme :exports both :results value :noweb-ref put-and-get
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(define coercion-table (make-table))
(define get-coercion (coercion-table 'lookup-proc))
(define put-coercion (coercion-table 'insert-proc!))
#+end_src
#+RESULTS:
: ok
*** DONE Exercise 3.24 tolerant tables
CLOSED: [2019-12-04 Wed 18:07]
#+begin_src scheme :exports both :results output
(define false #f)
(define (make-table . o)
(let ((same-key? (if (null? o) equal? (car o))))
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable
(assoc key-1 (cdr local-table) same-key?)))
(if subtable
(let ((record
(assoc key-2 (cdr subtable) same-key?)))
(if record (cdr record) false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable
(assoc key-1 (cdr local-table) same-key?)))
(if subtable
(let ((record
(assoc key-2 (cdr subtable) same-key?)))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1 (cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation: TABLE" m))))
dispatch)))
(define (parity-checker a b)
(if (= (remainder a 2) (remainder b 2))
#t
#f)) #;("not a very useful table")
(define operation-table (make-table parity-checker))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(put 1 2 (lambda () (display "test1") (newline)))
((get 3 4))
#+end_src
#+RESULTS:
: test1
This exercise would have been much-much harder with schemes lower than
version 7, as the ~assoc~ procedure doesn't take a comparator procedure.
*** DONE Exercise 3.25 multilevel tables
CLOSED: [2019-12-06 Fri 20:35]
This exercise illustrates that it is never pays off to save on data
structures. The two-level structure is not flexible, so we are just using
nested tables.
#+begin_src scheme :exports both :results output
(display "Starting\n")
(define (make-table)
(let ((local-table (list)))
(define (lookup key-list)
(let ((subtable (assoc (car key-list) local-table)))
(if subtable
(if (null? (cdr key-list))
(cdr subtable)
(((cdr subtable) 'lookup-proc) (cdr key-list)))
#f)))
(define (insert! key-list value)
(let* ((key (car key-list))
(subtable (assoc key local-table)))
(if subtable
(if (null? (cdr key-list))
(set-cdr! subtable value)
(if (procedure? (cdr subtable))
(((cdr subtable) 'insert-proc!) (cdr key-list) value)
(let ((subsubtable (make-table)))
((subsubtable 'insert-proc!) (cdr key-list) value)
(set-cdr! subtable subsubtable))))
(set! local-table
(cons
(cons key
(if (null? (cdr key-list))
value
(let ((subsubtable (make-table)))
((subsubtable 'insert-proc!)
(cdr key-list) value) subsubtable)))
local-table)))))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(display (put (list 'key1 'key2 'key3) 'test-value))
(newline)
(display (get (list 'key1 'key2 'key3)))
#+end_src
#+RESULTS:
: Starting
: #<undef>
: test-value
*** DONE Exercise 3.26 binary tree table
CLOSED: [2019-12-06 Fri 20:53]
It is easy to implement a table lookup system based on an ordered set of
keys. A binary search tree is an easy example. In such a tree, every node
represents a key (with some payload value). The left child always has its key
ordered less than the right one, in every node. Searching is thus easy, you
start from the top of the tree, and follow right or left, depending whether
the key you are searching for is greater or less than the one you are looking
for.
This should clearly require \(O(\log n)\) steps if the tree is well
balanced. Insertion, if implemented naively, may work according to the same
scheme. However, if we try to insert a long list of successive numbers, we
will get a very deep and very thin tree, which will reduce the problem to the
implementation based on lists.
The problem happens if the tree is _not_ well balanced. Several re-balancing
algorithms exist, that for example AVL-trees and RB-trees. Those are usually
applied on ~insert!~, when the tree's "badness" metric exceeds some value.
*** DONE Exercise 3.27 memoization
CLOSED: [2019-12-07 Sat 16:08]
It is very straightforward why plain ~(memoize fib)~ would not work. Because
every call to the same function should be snapped with a call to the
memoizer. That is the memoization only rememebers a call with which it is
associated. Since ~fib~ calls ~fib~ again, not ~memo-fib~, only the final
result would be remembered.
We want to make a diagram for ~(memo-fib 3)~.
#+name: exercise-3-27
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-27.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
node distance=4mm]
\node (memoize-global) {memoize: <...>};
\node (fake1) [right=100mm of fib-global] {};
\node (memo-fib-global) [below=4mm of memoize-global.west,anchor=west] {memo-fib:};
\node (g env) [box, fit=(memoize-global) (fake1) (memo-fib-global),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
\path
node[below=2cm of memo-fib-global.west, anchor=west,align=left] (var-f) {f: lambda (n) <...>\\
(fib implementation,\\ uses memo-fib)}
node[box,draw, minimum size=1cm, fit=(var-f),pin=left:E1] (E1-env) {}
($ (E1-env.north west)!0.9!(E1-env.north east) $) coordinate (aux3);
\draw[->] (aux3) -- (aux3 |- g env.south);
\node[below=2cm of var-f.west, anchor=west] (table-var) {table: \#<procedure dispatch>}
node[right=7cm of table-var] (fake2) {};
\node[box,draw, fit=(table-var) (fake2),pin=left:E2] (E2-env) {};
\path ($ (E2-env.north west)!0.1!(E2-env.north east) $) coordinate (aux2);
\draw[->] (aux2) -- (aux2 |- E1-env.south);
\path coordinate[below=1.5cm of table-var.west] (aux)
(aux) pic{two dots=memo-fib};
\draw[->] (memo-fib-right.center) to (E2-env.south -| memo-fib-right.center);
\node[below=10mm of memo-fib-left,align=left,anchor=north]
{parameters: x\\
body: <table lookup,\\ or uses f>}
edge[<-] (memo-fib-left.center);
\draw[<-,to path={-- ++(-2cm,0) |- ($ (\tikztotarget) - (0,1cm) $)}
-- (\tikztotarget)]
(memo-fib.west) to (memo-fib-global.east);
\path ($ (E2-env.south west)!0.2!(E2-env.south east) $) node(fake) {}
node [box,below=1cm of fake] (fake2) {n: 3} edge[->] (fake)
node [below=5mm of fake2] {<memo-fib...>};
\path ($ (E2-env.south west)!0.4!(E2-env.south east) $) node(fake) {}
node [box,below=1cm of fake] (fake2) {n: 2} edge[->] (fake)
node [below=5mm of fake2] {<memo-fib...>};
\path ($ (E2-env.south west)!0.6!(E2-env.south east) $) node(fake) {}
node [box,below=1cm of fake] (fake2) {n: 1} edge[->] (fake)
node [below=5mm of fake2] {<memo-fib...>};
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-27
[[file:exercise-3-27.png]]
I am not sure this is very explanatory, but seems to do the job...
*** Circuit simulation code
I am separating the circuit simulation code into a separate section, because
it is all very messy and scattered, and would be interfering with just
solving exercises.
#+begin_src scheme :exports both :results value :noweb-ref circuit-simulator-1
(define delay #f)
(define (get-signal wire) (wire 'get-signal))
(define (set-signal! wire new-value)
((wire 'set-signal!) new-value))
(define (add-action! wire action-procedure)
((wire 'add-action!) action-procedure))
(define (call-each procedures)
(if (null? procedures)
'done
(begin ((car procedures))
(call-each (cdr procedures)))))
(define (make-wire)
(let ((signal-value 0) (action-procedures '()))
(define (set-my-signal! new-value)
(if (not (= signal-value new-value))
(begin (set! signal-value new-value)
(call-each action-procedures))
'done))
(define (accept-action-procedure! proc)
(set! action-procedures
(cons proc action-procedures))
(proc))
(define (dispatch m)
(cond ((eq? m 'get-signal) signal-value)
((eq? m 'set-signal!) set-my-signal!)
((eq? m 'add-action!) accept-action-procedure!)
(else (error "Unknown operation: WIRE" m))))
dispatch))
(define a (make-wire))
(define b (make-wire))
(define c (make-wire))
(define d (make-wire))
(define e (make-wire))
(define s (make-wire))
(define (half-adder a b s c)
(let ((d (make-wire)) (e (make-wire)))
(or-gate a b d)
(and-gate a b c)
(inverter c e)
(and-gate d e s)
'ok))
(define (full-adder a b c-in sum c-out)
(let ((s (make-wire)) (c1 (make-wire)) (c2 (make-wire)))
(half-adder b c-in s c1)
(half-adder a s sum c2)
(or-gate c1 c2 c-out)
'ok))
(define (inverter input output)
(define (invert-input)
(let ((new-value (logical-not (get-signal input))))
#;(show #t "Inverter-delay=" inverter-delay "\n")
(after-delay inverter-delay
(lambda () (set-signal! output new-value)))))
(add-action! input invert-input) 'ok)
(define (logical-not s)
(cond ((= s 0) 1)
((= s 1) 0)
(else (error "Invalid signal" s))))
(define (after-delay delayd action)
(add-to-agenda! (+ delayd (current-time the-agenda))
action
the-agenda))
(define (propagate)
#;(show #t "propagate: agenda=" (displayed the-agenda) "\n")
(if (empty-agenda? the-agenda)
'done
(let ((first-item (first-agenda-item the-agenda)))
(first-item)
(remove-first-agenda-item! the-agenda)
(propagate))))
(define (probe name wire)
(add-action! wire
(lambda ()
(newline)
(display name) (display " ")
(display "time= ")
(display (current-time the-agenda))
(display " New-value = ")
(display (get-signal wire)))))
<<queue>>
(define (make-time-segment time queue)
(cons time queue))
(define (segment-time s) (car s))
(define (segment-queue s) (cdr s))
(define (make-agenda) (list 0))
(define (current-time agenda) (car agenda))
(define (set-current-time! agenda time)
(set-car! agenda time))
(define (segments agenda) (cdr agenda))
(define (set-segments! agenda segments)
(set-cdr! agenda segments))
(define (first-segment agenda) (car (segments agenda)))
(define (rest-segments agenda) (cdr (segments agenda)))
(define (empty-agenda? agenda)
(null? (segments agenda)))
(define (add-to-agenda! time action agenda)
(define (belongs-before? segments)
(or (null? segments)
(< time (segment-time (car segments)))))
(define (make-new-time-segment time action)
(let ((q (make-queue)))
(insert-queue! q action)
(make-time-segment time q)))
(define (add-to-segments! segments)
(if (= (segment-time (car segments)) time)
(insert-queue! (segment-queue (car segments))
action)
(let ((rest (cdr segments)))
(if (belongs-before? rest)
(set-cdr!
segments
(cons (make-new-time-segment time action)
(cdr segments)))
(add-to-segments! rest)))))
(let ((segments (segments agenda)))
(if (belongs-before? segments)
(set-segments!
agenda
(cons (make-new-time-segment time action)
segments))
(add-to-segments! segments))))
(define (remove-first-agenda-item! agenda)
(let ((q (segment-queue (first-segment agenda))))
(delete-queue! q)
(if (empty-queue? q)
(set-segments! agenda (rest-segments agenda)))))
(define (first-agenda-item agenda)
(if (empty-agenda? agenda)
(error "Agenda is empty: FIRST-AGENDA-ITEM")
(let ((first-seg (first-segment agenda)))
#;(show #t "f-a-i:current-time=" (car agenda) "\n")
(set-current-time! agenda
(segment-time first-seg))
(front-queue (segment-queue first-seg)))))
(define (logical-and s1 s2)
(cond ((and (= 1 s1) (= s2 1)) 1)
(else 0)))
(define (and-gate a1 a2 output)
(define (and-action-procedure)
(let ((new-value
(logical-and (get-signal a1) (get-signal a2))))
#;(show #t "And-gate-delay=" and-gate-delay "\n")
(after-delay
and-gate-delay
(lambda () (set-signal! output new-value)))))
(add-action! a1 and-action-procedure)
(add-action! a2 and-action-procedure)
'ok)
<<or-gate-primitive>>
#;(display "Done defining the circuit simulator.\n")
'done-defining-circuit-simulator
#+end_src
#+RESULTS:
: done-defining-circuit-simulator
For example, the procedure ~logical-and~ is not implemented
anywhere, so we will need to write it ourselves.
#+begin_src scheme :exports both :results output
<<circuit-simulator-1>>
(define the-agenda (make-agenda))
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
(define input-1 (make-wire))
(define input-2 (make-wire))
(define sum (make-wire))
(define carry (make-wire))
(show #t "(probe 'sum sum):\n")
(probe 'sum sum)
(show #t "\n(probe 'carry carry):\n")
(probe 'carry carry)
(show #t "\n(half-adder input-1 input-2 sum carry):\n")
(half-adder input-1 input-2 sum carry)
(show #t "\n(set-signal! input-1 1):\n")
(set-signal! input-1 1)
(show #t "\n(propagate):\n")
(propagate)
(show #t "\n(set-signal! input-2 1):\n")
(set-signal! input-2 1)
(show #t "\n(propagate):\n")
(propagate)
#+end_src
#+RESULTS:
#+begin_example
(probe 'sum sum):
(probe 'carry carry):
(half-adder input-1 input-2 sum carry):
(set-signal! input-1 1):
(propagate):
(set-signal! input-2 1):
(propagate):
carry time= 11 New-value = 1
#+end_example
*** DONE Exercise 3.28 primitive or-gate
CLOSED: [2019-12-08 Sun 23:43]
In this exercise, there is one caveat that makes life of programmers
miserable. That is, 0 does not represent a false value in scheme. So
writing a readable code was a bit difficult, and the code below is
probably not correct.
#+begin_src scheme :exports both :results output :noweb-ref or-gate-primitive
(define (logical-or s1 s2)
(cond ((or (= s1 1) (= s2 1)) 1)
(else 0)))
(define (or-gate a1 a2 output)
(define (or-action-procedure)
(let ((new-value
(logical-or (get-signal a1) (get-signal a2))))
#;(show #t "or-gate-delay=" or-gate-delay "\n")
(after-delay
or-gate-delay
(lambda () (set-signal! output new-value)))))
(add-action! a1 or-action-procedure)
(add-action! a2 or-action-procedure)
'ok)
#+end_src
This code is used in the previous section. [[Circuit simulation code
]]
*** DONE Exercise 3.29 Compound or-gate
CLOSED: [2019-12-08 Sun 23:45]
\( \vee (a,b) = \wedge(\neg a, \neg b)\)
#+begin_src scheme :exports both :results output :noweb-ref or-gate-procedural
(define (or-gate a b c)
(let ((d (make-wire)) (e (make-wire)))
(inverter a d)
(inverter b e)
(and-gate d e c)
'ok))
#+end_src
I have no idea how slow this works, and we don't have a simulation routine
to check. But the delay should be the sum of the and-gate delay and just one
of the inverter delays (because the two inverters work in parallel).
*** DONE Exercise 3.30 ripple-carry adder
CLOSED: [2019-12-08 Sun 23:58]
#+begin_src scheme :exports both :results output
<<circuit-simulator-1>>
<<or-gate-primitive>>
(define the-agenda (make-agenda))
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
(define (make-wire-list n my-list)
(if (= n 0)
my-list
(make-wire-list (- n 1) (cons (make-wire) my-list))))
(define test-length 2)
(define A (make-wire-list test-length '()))
(define B (make-wire-list test-length '()))
(define S (make-wire-list test-length '()))
(define C (make-wire))
(define (ripple-carry-adder a b s c)
(let ((A_n (car a))
(B_n (car b))
(S_n (car s))
(C_n-1 (make-wire)))
(full-adder A_n B_n c S_n C_n-1)
(if (null? (cdr a))
C_n-1
(ripple-carry-adder (cdr a) (cdr b) (cdr s) C_n-1))))
(define C_out (ripple-carry-adder A B S C))
(probe 'C_out C_out)
(set-signal! (list-ref A 1) 1)
(set-signal! (list-ref A 0) 1)
(set-signal! (list-ref B 1) 1)
(propagate)
#+end_src
#+RESULTS:
:
: C_out time= 0 New-value = 0
: C_out time= 16 New-value = 1
This ripple-carry-adder is not very efficient. Also, bits are represented in
the little-ending format. Also, we can still not test it, since the
simulation function is not given.
*** DONE Exercise 3.31 Initial propagation
CLOSED: [2019-12-09 Mon 00:16]
Initial propagation is needed for in initial intermediate values of
the wires to be consistent.
In particular, look at the inverter gate. If we don't run
initialisation, then at time 0, the gate would have it's input as 0
(which is a normal state for a newly-created wire), and it's output as
0 too. But this condition for an inverter is wrong.
*** DONE Exercise 3.32 Order matters
CLOSED: [2019-12-09 Mon 00:26]
The problem with adding operations in a standard list is that the
intermediate results are getting in the execution after the final
ones.
In this particular example, changing (0,1) to (1,0), we have to go
through (1,1). And it doesn't matter than we are going to (1,0) after,
because the simulation for (1,1) will be in the queue later.
*** Constraint propagation system
In this section I will place common code for the constraint
propagation system, because it is quite big.
#+begin_src scheme :exports both :results value :noweb-ref constraints-system
(define false #f)
(define true #t)
(define (adder a1 a2 sum)
(define (process-new-value)
(cond ((and (has-value? a1) (has-value? a2))
(set-value! sum
(+ (get-value a1) (get-value a2))
me))
((and (has-value? a1) (has-value? sum))
(set-value! a2
(- (get-value sum) (get-value a1))
me))
((and (has-value? a2) (has-value? sum))
(set-value! a1
(- (get-value sum) (get-value a2))
me))))
(define (process-forget-value)
(forget-value! sum me)
(forget-value! a1 me)
(forget-value! a2 me)
(process-new-value))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value) (process-forget-value))
(else (error "Unknown request: ADDER" request))))
(connect a1 me)
(connect a2 me)
(connect sum me)
me)
(define (inform-about-value constraint)
(constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
(constraint 'I-lost-my-value))
(define (multiplier m1 m2 product)
(define (process-new-value)
(cond ((or (and (has-value? m1) (= (get-value m1) 0))
(and (has-value? m2) (= (get-value m2) 0)))
(set-value! product 0 me))
((and (has-value? m1) (has-value? m2))
(set-value! product
(* (get-value m1) (get-value m2))
me))
((and (has-value? product) (has-value? m1))
(set-value! m2
(/ (get-value product)
(get-value m1))
me))
((and (has-value? product) (has-value? m2))
(set-value! m1
(/ (get-value product)
(get-value m2))
me))))
(define (process-forget-value)
(forget-value! product me)
(forget-value! m1 me)
(forget-value! m2 me)
(process-new-value))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value) (process-forget-value))
(else (error "Unknown request: MULTIPLIER"
request))))
(connect m1 me)
(connect m2 me)
(connect product me)
me)
(define (constant value connector)
(define (me request)
(error "Unknown request: CONSTANT" request))
(connect connector me)
(set-value! connector value me)
me)
(define (probe name connector)
(define (print-probe value)
(newline) (display "Probe: ") (display name)
(display " = ") (display value))
(define (process-new-value)
(print-probe (get-value connector)))
(define (process-forget-value) (print-probe "?"))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value) (process-forget-value))
(else (error "Unknown request: PROBE" request))))
(connect connector me)
me)
(define (make-connector)
(let ((value false) (informant false) (constraints '()))
(define (set-my-value newval setter)
(cond ((not (has-value? me))
(set! value newval)
(set! informant setter)
(for-each-except setter
inform-about-value
constraints))
((not (= value newval))
(error "Contradiction" (list value newval)))
(else 'ignored)))
(define (forget-my-value retractor)
(if (eq? retractor informant)
(begin (set! informant false)
(for-each-except retractor
inform-about-no-value
constraints))
'ignored))
(define (connect new-constraint)
(if (not (memq new-constraint constraints))
(set! constraints
(cons new-constraint constraints)))
(if (has-value? me)
(inform-about-value new-constraint))
'done)
(define (me request)
(cond ((eq? request 'has-value?)
(if informant true false))
((eq? request 'value) value)
((eq? request 'set-value!) set-my-value)
((eq? request 'forget) forget-my-value)
((eq? request 'connect) connect)
(else (error "Unknown operation: CONNECTOR"
request))))
me))
(define (for-each-except exception procedure list)
(define (loop items)
(cond ((null? items) 'done)
((eq? (car items) exception) (loop (cdr items)))
(else (procedure (car items))
(loop (cdr items)))))
(loop list))
(define (has-value? connector)
(connector 'has-value?))
(define (get-value connector)
(connector 'value))
(define (set-value! connector new-value informant)
((connector 'set-value!) new-value informant))
(define (forget-value! connector retractor)
((connector 'forget) retractor))
(define (connect connector new-constraint)
((connector 'connect) new-constraint))
#+end_src
#+RESULTS:
: #<undef>
#+begin_src scheme :exports both :results output
<<constraints-system>>
(define (celsius-fahrenheit-converter c f)
(let ((u (make-connector))
(v (make-connector))
(w (make-connector))
(x (make-connector))
(y (make-connector)))
(multiplier c w u)
(multiplier v x u)
(adder v y f)
(constant 9 w)
(constant 5 x)
(constant 32 y)
'ok))
(define C (make-connector))
(define F (make-connector))
(celsius-fahrenheit-converter C F)
(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)
(set-value! C 25 'user)
#;(set-value! F 212 'user) #;("errors")
(forget-value! C 'user)
(set-value! F 212 'user)
#+end_src
#+RESULTS:
:
: Probe: Celsius temp = 25
: Probe: Fahrenheit temp = 77
: Probe: Celsius temp = ?
: Probe: Fahrenheit temp = ?
: Probe: Fahrenheit temp = 212
: Probe: Celsius temp = 100
*** DONE Exercise 3.33 averager constraint
CLOSED: [2019-12-18 Wed 11:29]
#+begin_src scheme :exports both :results output :noweb-ref constraints-averager
(define (averager a b c)
(define (process-new-value)
(cond
((and (has-value? a) (has-value? b))
(set-value! c
(/ (+ (get-value a) (get-value b)) 2)
me))
((and (has-value? c) (has-value? a))
(set-value! b
(- (* 2 (get-value product))
(get-value a))
me))
((and (has-value? c) (has-value? b))
(set-value! a
(- (* 2 (get-value c))
(get-value b))
me))))
(define (process-forget-value)
(forget-value! c me)
(forget-value! a me)
(forget-value! b me)
(process-new-value))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value) (process-forget-value))
(else (error "Unknown request: AVERAGER"
request))))
(connect a me)
(connect b me)
(connect c me)
me)
#+end_src
#+begin_src scheme :exports both :results output
<<constraints-system>>
<<constraints-averager>>
(define localA (make-connector))
(define localB (make-connector))
(define localC (make-connector))
(averager localA localB localC)
(probe "localA: " localA)
(probe "localB: " localB)
(probe "localC: " localC)
(set-value! localA 25 'user)
(set-value! localB 27 'user)
(guard (err
(else (show #t "\nExpected failure: " (displayed err) "\n")))
(set-value! localC 22 'user))
(forget-value! localA 'user)
(set-value! localC 22 'user)
#+end_src
#+RESULTS:
#+begin_example
Probe: localA: = 25
Probe: localB: = 27
Probe: localC: = 26
Expected failure: {Exception #19 user "Contradiction" ((26 22)) #f #f}
Probe: localA: = ?
Probe: localC: = ?
Probe: localC: = 22
Probe: localA: = 17
#+end_example
*** DONE Exercise 3.34 Wrong squarer
CLOSED: [2019-12-18 Wed 12:30]
The problem with this system is that the inversion procedure wouldn't
work. That is, the multiplier has three connections, and every two
define the third one. This is not the case with the squarer, as in the
formula \( a \cdot a = b \), if we are given \(b\), we immediately get
the value on both of the connectors leading to \(a\).
*** DONE Exercise 3.35 Correct squarer
CLOSED: [2019-12-18 Wed 12:47]
#+begin_src scheme :exports both :results output :noweb-ref constraints-squarer
(define (squarer a b)
(define (process-new-value)
(if (has-value? b)
(if (< (get-value b) 0)
(error "square less than 0 -- SQUARER" (get-value b))
(set-value! a
(sqrt (get-value b))
me))
(if (has-value? a)
(set-value! b
(* (get-value a) (get-value a))
me))))
(define (process-forget-value)
(forget-value! b me)
(forget-value! a me))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value)
(process-forget-value))
(else (error "Unknown request: SQUARER" request))))
(connect a me)
(connect b me)
me)
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<constraints-squarer>>
<<constraints-system>>
(define localA (make-connector))
(define localB (make-connector))
(squarer localA localB)
(probe "localA: " localA)
(probe "localB: " localB)
(set-value! localA 25 'user)
(guard (err
(else (show #t "\nExpected failure: " (displayed err))))
(set-value! localB 22 'user))
(forget-value! localA 'user)
(set-value! localB 22 'user)
#+end_src
#+RESULTS:
:
: Probe: localA: = 25
: Probe: localB: = 625
: Expected failure: {Exception #19 user "Contradiction" ((625 22)) #f #f}
: Probe: localA: = ?
: Probe: localB: = ?
: Probe: localB: = 22
: Probe: localA: = 4.69041575982343
*** DONE Exercise 3.36 Connector environment diagram :tikz:
CLOSED: [2019-12-21 Sat 20:27]
We are studying the following code:
#+begin_src scheme :exports both :results output
(define a (make-connector))
(define b (make-connector))
(set-value! a 10 'user)
#+end_src
#+name: exercise-3-36
#+header: :imagemagick yes :iminoptions -density 300 :imoutoptions -geometry 1000
#+header: :fit yes :headers '("\\usepackage{tikz} \\usetikzlibrary{positioning,fit,petri,arrows,calc,matrix,quotes}")
#+header: :buffer on
#+begin_src latex :results raw file :exports both :file exercise-3-36.png
\begin{tikzpicture}[inner sep=0mm,>=stealth',very thick,color=black!50,
every node/.style={font=\sffamily,align=left},
font=\sffamily,pics/two dots/.style={code={
\node [draw,minimum size=5mm,circle,colored tokens={black!50}]
(#1-left) {};
\node [draw,minimum size=5mm,circle,colored tokens={black!50},
right=0pt of #1-left]
(#1-right) {};
\node [rectangle, fit=(#1-left) (#1-right)] (#1){};
}},
every pin edge/.style={<-,very thick},
box/.style={draw,rectangle,inner sep=#1},box/.default=2mm,
envi/.style={matrix of nodes, align=left,
every node/.style={anchor=west},
inner sep={0.7mm},
execute at end cell={\vphantom{()}},
draw},
node distance=4mm]
\node (a-global) {a:};
\node (fake1) [right=150mm of a] {};
\node (b-global) [below=4mm of a-global.west,anchor=west] {b:};
\node (iov-global) [below=4mm of b-global.west,anchor=west] {inform-about-value:};
\node (sv-global) [below=4mm of iov-global.west,anchor=west] {set-value!:};
\node (g-env) [box, fit=(a-global) (fake1) (b-global) (iov-global) (sv-global),
pin={[text width=1cm,pin distance=10mm]left:global env}]
{ };
\path ($ (g-env.south west)!0.3!(g-env.south east) $) coordinate (fake1)
coordinate[below=1cm of fake1] (fake) (fake) pic{two dots=set-to-value}
(set-to-value) edge[<-,to path={|- (\tikztotarget)}] (sv-global.east)
(set-to-value-right.center) edge[->] (fake1 -| set-to-value-right.center);
\path ($ (g-env.south west)!0.5!(g-env.south east) $) coordinate (fake1)
coordinate[below=1cm of fake1] (fake) (fake) pic{two dots=i-a-v}
(i-a-v) edge[<-,to path={|- (\tikztotarget)}] (iov-global.east)
(i-a-v-right.center) edge[->] (fake1 -| i-a-v-right.center);
\path ($ (g-env.south west)!0.1!(g-env.south east) $) node(fake) {};
\matrix (a) [envi,
below=of fake]
{
value: 10\\
informant: 'user\\
constraints: '() \\
|(a-set-my-value)| set-my-value: \\
|(a-forget-my-value)| forget-my-value: \\
|(a-connect)| connect: \\
|(a-me)| me:\\
} edge[->] (fake);
\path coordinate[right=2.5cm of a-me] (aux)
(aux) pic{two dots=amev}
(amev) edge [<-] (a-me) (amev-right.center)
edge [->,to path={|- (\tikztotarget)}] ($ (a.east)$)
node[below=0.5cm of amev-left] {parameters: newvalue\\
\phantom{parameters: }setter\\
body: ... }
edge[<-] (amev-left.center);
\draw[->] (a-global.east) to[to path={ -| (\tikztotarget)}] (amev);
\path ($ (g-env.south west)!0.9!(g-env.south east) $) node(fake) {};
\matrix (b) [ below=of fake,envi]
{
value: \#f\\
informant: \#f\\
constraints: '() \\
|(b-set-my-value)| set-my-value: <...>\\
|(b-forget-my-value)| forget-my-value: <...> \\
|(b-connect)| connect: <...> \\
|(b-me)| me:\\
} edge[->] (fake);
\path coordinate[right=40mm of b-me] (aux)
(aux) pic{two dots=bmev}
(bmev) edge [<-] (b-me)
(bmev-right.center)
edge [->,to path={|- (\tikztotarget)}]
($ (b.east) + (0,0mm)$)
node[below=0.5cm of bmev-left] {parameters: newvalue\\
\phantom{parameters: }setter\\
body: ... }
edge[<-] (bmev-left.center);
\draw[->] (b-global.east) to[to path={-| (\tikztotarget)}] (bmev);
\matrix (smv) [below=2cm of a, envi]
{
newval: 10\\
setter: 'user\\
} edge[->] (a)
($ (a.south)!0.5!(smv.north) $) node[anchor=east]
{(set-my-value 10 'user)};
\matrix (fee) [below=2cm of smv,envi]
{
exception: 'user\\
|(pp)| procedure:\\
constraints: '()\\
loop: <...> \\
} edge[->] (smv)
(pp.east) edge[->, to path={-| (\tikztotarget)}] (i-a-v)
($ (smv.south)!0.5!(fee.north)$) node[anchor=east]
{(for-each-except\\
'user \\
inform-about-value \\
'())};
\matrix (loop) [below=1cm of fee, envi]
{
items: '()\\
} edge[->] (fee)
($ (fee.south)!0.5!(loop.north) $) node[anchor=east]
{(loop '())}
node[below=of loop,anchor=north]
{(cond\\
((null? items)\\
'done)\\
((eq? (car items) exception)\\
(loop (cdr items)))\\
(else\\
(procedure (car items))\\
(loop (cdr items))))};
\end{tikzpicture}
#+end_src
#+RESULTS: exercise-3-36
[[file:exercise-3-36.png]]
Not as much of a difficult drawing exercise, still took me about 5
hours. Drawing is hard.
*** DONE Exercise 3.37 Expression-based constraints
CLOSED: [2019-12-21 Sat 21:20]
#+begin_src scheme :exports both :results output :noweb-ref constraints-expressions
(define (c+ x y)
(let ((z (make-connector)))
(adder x y z)
z))
(define (c* x y)
(let ((z (make-connector)))
(multiplier x y z)
z))
(define (cv value)
(let ((z (make-connector)))
(constant value z)
z))
(define (c/ x y)
(let ((z (make-connector)))
(multiplier y z x)
z))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<constraints-system>>
<<constraints-expressions>>
(define (celsius-fahrenheit-converter x)
(c+
(c*
(c/ (cv 9) (cv 5))
x)
(cv 32)))
(define C (make-connector))
(define F (celsius-fahrenheit-converter C))
(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)
(set-value! F 212 'user)
#+end_src
#+RESULTS:
:
: Probe: Fahrenheit temp = 212
: Probe: Celsius temp = 100
This turned out to be a very easy task. The only trick here really is
to use the multiplies as a divider.
*** TODO Check that every exercise with pictures has tags
*** TODO Figure 3.29 Sequence diagram :plantuml:
*** TODO Figure 3.30 :tikz:
*** DONE Exercise 3.38 Timing
CLOSED: [2019-12-21 Sat 22:48]
The three users to the following:
Peter: (set! balance (+ balance 10))
Paul: (set! balance (- balance 20))
Mary: (set! balance (- balance (/ balance 2)))
**** a
The three possible code orderings are the following:
#+begin_src scheme :exports both :results value
(define balance 100)
(set! balance (+ balance 10))
(set! balance (- balance 20))
(set! balance (- balance (/ balance 2)))
balance
#+end_src
#+RESULTS:
: 45
#+begin_src scheme :exports both :results value
(define balance 100)
(set! balance (- balance 20))
(set! balance (- balance (/ balance 2)))
(set! balance (+ balance 10))
balance
#+end_src
#+RESULTS:
: 50
#+begin_src scheme :exports both :results value
(define balance 100)
(set! balance (- balance (/ balance 2)))
(set! balance (- balance 20))
(set! balance (+ balance 10))
balance
#+end_src
#+RESULTS:
: 40
**** b
#+begin_src plantuml :exports both :file exercise-3-38.png
@startuml
skinparam monochrome true
actor " Peter " as Peter
actor " Paul " as Paul
actor " Mary " as Mary
entity " Bank " as Bank
rnote over Bank: $100
Mary -> Bank: Access\n balance
Bank -> Mary: $100
note over Mary: $100
Paul -> Bank: Access\n balance
Bank -> Paul: $100
note over Paul: $100
Peter -> Bank: Access\n balance
Bank -> Paul: $100
note over Mary: $100/2=$50
Mary -> Bank: set-balance! $50
rnote over Bank: $50
note over Paul: $100-$20=$80
Paul -> Bank: set-balance! $80
rnote over Bank: $80
note over Peter: $100+$10=$110
Peter -> Bank: set-balance! $110
rnote over Bank: $110
@enduml
#+end_src
#+RESULTS:
[[file:exercise-3-38.png]]
Obviously, the values of 50, 80 and 110 are wrong. Any of those can
end up as the final value, depending on the timing of ~set-balance!~.
*** Implementing ~(parallel-execute)~ and serializers
#+begin_src scheme :exports both :results output :noweb-ref parallel-execute
(define (parallel-execute . forms)
(let ((myo (open-output-string)))
(define (create-threads . forms)
(if (null? forms)
(list)
(let ((ctxi (thread-start!
(make-thread
(lambda () (parameterize ((current-output-port myo))
((car forms))))))))
(cons ctxi (apply create-threads (cdr forms))))))
(define (wait-threads thread-list)
(if (null? thread-list)
#t
(begin (thread-join! (car thread-list))
(wait-threads (cdr thread-list)))))
(wait-threads (apply create-threads forms))
(display (get-output-string myo))))
#+end_src
#+begin_src scheme :exports both :results output
<<parallel-execute>>
(parallel-execute
(lambda () (thread-sleep! 3) (display "hello1") (newline))
(lambda () (display "hello2") (newline)))
(display "hello3\n")
#+end_src
#+RESULTS:
: hello2
: hello1
: hello3
#+begin_src scheme :exports both :results value
<<parallel-execute>>
(define x 10)
(parallel-execute
(lambda () (thread-sleep! 1) (set! x (* x x)))
(lambda () (set! x (+ x 1))))
x
#+end_src
#+RESULTS:
: 121
#+begin_src scheme :exports both :results output :noweb-ref make-serializer
(define false #f)
(define true #t)
(define central-old-mutex (make-mutex 'global-srfi-18-mutex))
(set! make-mutex #f)
(define (test-and-set! cell)
(mutex-lock! central-old-mutex)
(let ((output (if (car cell) true (begin (set-car! cell true) false))))
(mutex-unlock! central-old-mutex)
output))
(define (make-mutex)
(let ((cell (list false)))
(define (the-mutex m)
(cond ((eq? m 'acquire)
(if (test-and-set! cell)
(the-mutex 'acquire)))
((eq? m 'release) (clear! cell))))
the-mutex))
(define (clear! cell) (set-car! cell false))
(define (make-serializer)
(let ((mutex (make-mutex)))
(lambda (p)
(define (serialized-p . args)
(mutex 'acquire)
(let ((val (apply p args)))
(mutex 'release)
val))
serialized-p)))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output :noweb-ref make-parallel-account
(define (make-account balance)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(let ((protected (make-serializer)))
(define (dispatch m)
(cond ((eq? m 'withdraw) (protected withdraw))
((eq? m 'deposit) (protected deposit))
((eq? m 'balance) balance)
(else (error "Unknown request: MAKE-ACCOUNT"
m))))
dispatch))
#+end_src
*** DONE Exercise 3.39 Serializer
CLOSED: [2019-12-23 Mon 05:11]
The original code is the following:
#+begin_src scheme :exports both :results output
(define x 10)
(parallel-execute
(lambda () (set! x (* x x)))
(lambda () (set! x (+ x 1))))
#+end_src
The original five outcomes were the following:
- 101: P1 sets x to 100 and then P2 increments x to 101.
- 121: P2 increments x to 11 and then P1 sets x to x * x .
- 110: P2 changes x from 10 to 11 between the two times that
P1 accesses the value of x during the evaluation of (* x x) .
- 11: P2 accesses x , then P1 sets x to 100, then P2 sets x .
- 100: P1 accesses x (twice), then P2 sets x to 11, then P1 sets x .
We are serializing one of the branches:
#+begin_src scheme :exports both :results output
(define x 10)
(define s (make-serializer))
(parallel-execute
(lambda () (set! x ((s (lambda () (* x x))))))
(s (lambda () (set! x (+ x 1)))))
#+end_src
In this case, the additive branch is fully serialized, and the
multiplicative had assignment and multiplication detached. The options
121 and 101 still remain, as they don't depend on the internal
serialization. The branch resulting in 110 is disabled, because the
read access to ~x~ is guaranteed to be sequential. The branch
resulting in 11 is also disabled, since accessing and setting is
guaranteed too happen together in the second branch. The branch
resulting in 100 remains a possible option, since the computation of
~(* x x)~ and the assignment are not guaranteed to happen in order.
So in the end, the three remaining options are:
- 101: P1 sets x to 100 and then P2 increments x to 101.
- 121: P2 increments x to 11 and then P1 sets x to x * x .
- 100: P1 accesses x (twice), then P2 sets x to 11, then P1 sets x .
*** DONE Exercise 3.40 Three parallel multiplications
CLOSED: [2019-12-29 Sun 04:32]
**** Part 1
#+begin_src scheme :exports both :results output
(define x 10)
(parallel-execute (lambda () (set! x (* x x)))
(lambda () (set! x (* x x x))))
#+end_src
Here there are two read operations and one write operation in the
first thread, and three read operations and one write operation in the
second branch.
So we need to find the number of unique interleavings of two
sequences: (1 2 3 4) and (a b c). The total number of interleavings is
\(C_{x+y}^{x}\), which is 35, although it doesn't mean that all
interleavings produce different outcomes.
Those sequences can be generated algorithmically:
https://math.stackexchange.com/questions/628120/number-of-possible-interleavings-of-two-strings-of-lengths-m-and-n
https://stackoverflow.com/questions/36260956/all-possible-ways-to-interleave-two-strings
It should be also possible to write a scheme macro to serialize
~parallel-execute~. And it should also be possible to do it
efficiently.
However, at the moment it seems rather feasible to write out
all possible serializations (interleavings) by hand.
In total this makes the following sequences:
| #op | 1 | 2 | 3 | 4 | 5 | 6 | 7 | Result |
|-----+--------+--------+---------+---------+---------+---------+---------+------------|
| 1 | 1 read | 1 read | 1 write | 2 read | 2 read | 2 read | 2 write | 1 00 00 00 |
| 2 | 1 read | 1 read | 2 read | 1 write | 2 read | 2 read | 2 write | 1 00 00 0 |
| 3 | 1 read | 1 read | 2 read | 2 read | 1 write | 2 read | 2 write | 1 00 00 |
| 4 | 1 read | 1 read | 2 read | 2 read | 2 read | 1 write | 2 write | 1 00 0 |
| 5 | 1 read | 1 read | 2 read | 2 read | 2 read | 2 write | 1 write | 1 00 |
| 6 | 1 read | 2 read | 1 read | 1 write | 2 read | 2 read | 2 write | 1 00 00 0 |
| 7 | 1 read | 2 read | 1 read | 2 read | 1 write | 2 read | 2 write | 1 00 00 |
| 8 | 1 read | 2 read | 1 read | 2 read | 2 read | 1 write | 2 write | 1 00 0 |
| 9 | 1 read | 2 read | 1 read | 2 read | 2 read | 2 write | 1 write | 1 00 |
| 10 | 1 read | 2 read | 2 read | 1 read | 1 write | 2 read | 2 write | 1 00 00 |
| 11 | 1 read | 2 read | 2 read | 1 read | 2 read | 1 write | 2 write | 1 00 0 |
| 12 | 1 read | 2 read | 2 read | 1 read | 2 read | 2 write | 1 write | 1 00 |
| 13 | 1 read | 2 read | 2 read | 2 read | 1 read | 1 write | 2 write | 1 00 0 |
| 14 | 1 read | 2 read | 2 read | 2 read | 1 read | 2 write | 1 write | 1 00 |
| 15 | 1 read | 2 read | 2 read | 2 read | 2 write | 1 read | 1 write | 1 00 00 |
| 16 | 2 read | 1 read | 1 read | 1 write | 2 read | 2 read | 2 write | 1 00 00 0 |
| 17 | 2 read | 1 read | 1 read | 2 read | 1 write | 2 read | 2 write | 1 00 00 |
| 18 | 2 read | 1 read | 1 read | 2 read | 2 read | 1 write | 2 write | 1 00 0 |
| 19 | 2 read | 1 read | 1 read | 2 read | 2 read | 2 write | 1 write | 1 00 |
| 20 | 2 read | 1 read | 2 read | 1 read | 1 write | 2 read | 2 write | 1 00 00 |
| 21 | 2 read | 1 read | 2 read | 1 read | 2 read | 1 write | 2 write | 1 00 0 |
| 22 | 2 read | 1 read | 2 read | 1 read | 2 read | 2 write | 1 write | 1 00 |
| 23 | 2 read | 1 read | 2 read | 2 read | 1 read | 1 write | 2 write | 1 00 0 |
| 24 | 2 read | 1 read | 2 read | 2 read | 1 read | 2 write | 1 write | 1 00 |
| 25 | 2 read | 1 read | 2 read | 2 read | 2 write | 1 read | 1 write | 1 00 00 |
| 26 | 2 read | 2 read | 1 read | 1 read | 1 write | 2 read | 2 write | 1 00 00 |
| 27 | 2 read | 2 read | 1 read | 1 read | 2 read | 1 write | 2 write | 1 00 0 |
| 28 | 2 read | 2 read | 1 read | 1 read | 2 read | 2 write | 1 write | 1 00 |
| 29 | 2 read | 2 read | 1 read | 2 read | 1 read | 1 write | 2 write | 1 00 0 |
| 30 | 2 read | 2 read | 1 read | 2 read | 1 read | 2 write | 1 write | 1 00 |
| 31 | 2 read | 2 read | 1 read | 2 read | 2 write | 1 read | 1 write | 1 00 00 |
| 32 | 2 read | 2 read | 2 read | 1 read | 1 read | 1 write | 2 write | 1 00 0 |
| 33 | 2 read | 2 read | 2 read | 1 read | 1 read | 2 write | 1 write | 1 00 |
| 34 | 2 read | 2 read | 2 read | 1 read | 2 write | 1 read | 1 write | 1 00 00 |
| 35 | 2 read | 2 read | 2 read | 2 write | 1 read | 1 read | 1 write | 1 00 00 00 |
So the total set of ~x~ values is ~(100, 1000, 10000, 100000,
1000000)~.
It would not have been to hard to generate all those read/write
sequences, but I wonder, how would I generate all possible codes to
check the outcomes?
**** Part 2
When the two serialized procedures are used:
#+begin_src scheme :exports both :results output
(define x 10)
(define s (make-serializer))
(parallel-execute (s (lambda () (set! x (* x x))))
(s (lambda () (set! x (* x x x)))))
#+end_src
Only two outcomes are left: when the first function runs, and when the
second function runs, which is either \(100^3\), or \(1000^2\), which is
both 1000000.
*** DONE Exercise 3.41 Better protected account
CLOSED: [2020-01-02 Thu 10:02]
I don't think that Ben's concern is valid. It may indeed happen that
the value of ~balance~ changes between the time when the value is
queried and the time it is returned, however wrapping a value in a
protective serialized lambda does not solve this issue. Rather the
whole call to the ~balance~ getter would need to be serialized.
*** DONE Exercise 3.42 Saving on serializers
CLOSED: [2020-01-02 Thu 10:35]
This exercise seems to be dealing with a thing called reentrancy,
which seems to be quite implementation-dependent. The version I wrote
would be asking to acquire the mutex any way, so I don't see how a
race condition can appear here.
#+begin_src scheme :exports both :results value
<<parallel-execute>>
<<make-serializer>>
<<make-parallel-account>>
(let ((acc (make-account 100)))
(parallel-execute
(lambda () (thread-sleep! 0.1) ((acc 'withdraw) 10))
(lambda () ((acc 'withdraw) 20)))
(acc 'balance))
#+end_src
#+RESULTS:
: 70
*** DONE Exercise 3.43 Multiple serializations
CLOSED: [2020-01-02 Thu 11:33]
#+begin_src scheme :exports both :results output :noweb-ref unsafe-exchange
(define (exchange account1 account2)
(let ((difference (- (account1 'balance)
(account2 'balance))))
((account1 'withdraw) difference)
((account2 'deposit) difference)))
#+end_src
It seems to be quite obvious that this code works correctly in a
single-threaded case. Any inconsistency would arise from an incorrect
order of mutations, but with one thread, this never happens.
For the parallel case, the following erroneous behaviour may happen:
#+begin_src plantuml :exports both :file exercise-3-43-1.png
@startuml
skinparam monochrome true
actor " Peter " as Peter
entity " Account 1 " as acc1
entity " Account 2 " as acc2
entity " Account 3 " as acc3
actor " Paul " as Paul
rnote over acc1: $10
rnote over acc2: $20
rnote over acc3: $30
rnote over Peter: Exchange\n 1 and 2
rnote over Paul: Exchange\n 2 and 3
Peter -> acc1: balance
acc1 -> Peter: 10
Peter -> acc2: balance
acc2 -> Peter: 20
rnote over Peter: difference=-10
Paul -> acc2: balance
acc2 -> Paul: 20
Paul -> acc3: balance
acc3 -> Paul: 30
rnote over Paul: difference=-10
Peter -> acc1: withdraw -10
rnote over acc1: $20
Paul -> acc2: withdraw -10
rnote over acc2: $30
Paul -> acc3: deposit -10
rnote over acc3: $20
Peter -> acc2: deposit -10
rnote over acc2: $20
@enduml
#+end_src
#+RESULTS:
[[file:exercise-3-43.png]]
Even though every balance query is immediately followed by a response,
still, incorrect ordering of mutations leads to the final accounts'
states as $20, $20, $20.
A fully non-synchronized version would be more disastrous:
#+begin_src plantuml :exports both :file exercise-3-43-2.png
@startuml
skinparam monochrome true
actor " Peter " as Peter
entity " Account 1 " as acc1
entity " Account 2 " as acc2
entity " Account 3 " as acc3
actor " Paul " as Paul
rnote over acc1: $10
rnote over acc2: $20
rnote over acc3: $30
rnote over Peter: Exchange\n 1 and 2
rnote over Paul: Exchange\n 2 and 3
Peter -> acc1: balance
acc1 -> Peter: 10
Peter -> acc2: balance
Paul -> acc2: balance
acc2 -> Paul: 20
Paul -> acc3: balance
acc3 -> Paul: 30
rnote over Paul: difference=-10
acc2 -> Peter: 20
rnote over Peter: difference=-10
Peter -> acc1: withdraw -10
rnote over acc1: $20
Peter -> acc2: deposit -10
Paul -> acc2: withdraw -10
rnote over acc2: $30
rnote over acc2: $10
Paul -> acc3: deposit -10
rnote over acc3: $20
@enduml
#+end_src
#+RESULTS:
[[file:exercise-3-43-2.png]]
Depending on the order of writing the balance variable in the account
2, the value may be wrong in different ways.
*** DONE Exercise 3.44 Transfer money
CLOSED: [2020-01-02 Thu 11:40]
I think that Louis is wrong here. The problem with exchanging amounts
is that the next value of account A depends on the previous value of
an account B. However, in this case the dependency is not so
strict. The next value of an account A only depends on the amount
~amount~. The dependency would be back though, if there may be not
enough money on the account B. Then the operation could fail,
depending on the order of execution.
*** DONE Exercise 3.45 new plus old serializers
CLOSED: [2020-01-02 Thu 11:46]
The problem with Louis' suggestion is that the same mutex would be
acquired twice. That is, we would attempt to serialize an already
serialized procedure, and would get in a deadlock.
That is, we would have something like ~(balance-serializer
(balance-serializer withdraw))~, which would attempt to obtain the
same lock twice, and thus will wait forever.
*** DONE Exercise 3.46 broken test-and-set!
CLOSED: [2020-01-02 Thu 11:56]
#+begin_src plantuml :exports both :file exercise-3-46.png
@startuml
skinparam monochrome true
control " Process 1 " as p1
entity " Mutex " as m
control " Process 2 " as p2
rnote over m: false
p1 -> m: test-and-set!
p2 -> m: test-and-set!
rnote over m: set-car! cell true
rnote over m: set-car! cell true
rnote over m: true
m -> p1: false
m -> p2: false
rnote over p1: acquired
rnote over p2: acquired
@enduml
#+end_src
#+RESULTS:
[[file:exercise-3-46.png]]
*** DONE Exercise 3.47 semaphores
CLOSED: [2020-01-03 Fri 12:59]
**** DONE a: In terms of mutexes
CLOSED: [2020-01-03 Fri 12:38]
#+begin_src scheme :exports both :results output
<<parallel-execute>>
<<make-serializer>>
(define (make-semaphore max-count)
(let ((count 0)
(mutex (make-mutex)))
(define (the-semaphore op)
(cond ((eq? op 'acquire)
(begin
(mutex 'acquire)
(if (= count max-count)
(begin
(mutex 'release)
(the-semaphore 'acquire))
(begin
(set! count (+ 1 count))
(mutex 'release)))))
((eq? op 'release)
(begin
(mutex 'acquire)
(set! count (max 0 (- count 1)))
(mutex 'release)
'released)))) the-semaphore))
(define test-semaphore (make-semaphore 2))
(parallel-execute
(lambda () (test-semaphore 'acquire)
(thread-sleep! 3)
(show #t "Hello1: " (current-second) "\n")
(test-semaphore 'release))
(lambda () (test-semaphore 'acquire)
(thread-sleep! 3)
(show #t "Hello2: " (current-second) "\n")
(test-semaphore 'release))
(lambda () (test-semaphore 'acquire)
(thread-sleep! 3)
(show #t "Hello3: " (current-second) "\n")
(test-semaphore 'release)))
#+end_src
#+RESULTS:
: Hello2: Hello1: 1578026228.6750461578026228.675087
:
: Hello3: 1578026231.676726
On my machine, the output from threads 1 and 2 is interleaved, while
the output from thread 3 is separate. I consider this to be a proof of
the fact that my code works as expected.
**** DONE b: In terms of test-and-set! operations
CLOSED: [2020-01-03 Fri 12:59]
#+begin_src scheme :exports both :results output
<<parallel-execute>>
<<make-serializer>>
(define (make-semaphore max-count)
(let ((count 0)
(cell (list false)))
(define (the-semaphore op)
(cond ((eq? op 'acquire)
(begin
(if (test-and-set! cell)
(the-semaphore 'acquire))
(if (= count max-count)
(begin
(clear! cell)
(the-semaphore 'acquire))
(begin
(set! count (+ 1 count))
(clear! cell)))))
((eq? op 'release)
(begin
(if (test-and-set! cell)
(the-semaphore 'release))
(set! count (max 0 (- count 1)))
(clear! cell)
'released)))) the-semaphore))
(define test-semaphore (make-semaphore 2))
(parallel-execute
(lambda () (test-semaphore 'acquire)
(thread-sleep! 1)
(show #t "Hello1: " (current-second) "\n")
(test-semaphore 'release))
(lambda () (test-semaphore 'acquire)
(thread-sleep! 1)
(show #t "Hello2: " (current-second) "\n")
(test-semaphore 'release))
(lambda () (test-semaphore 'acquire)
(thread-sleep! 1)
(show #t "Hello3: " (current-second) "\n")
(test-semaphore 'release)))
#+end_src
#+RESULTS:
: Hello1: Hello2: 1578027561.9465251578027561.946571
:
: Hello3: 1578027562.950841
Also seems to be working fine.
*** DONE Exercise 3.48 serialized-exchange deadlock
CLOSED: [2020-01-03 Fri 13:30]
#+begin_src scheme :exports both :results output
(define (make-account-and-serializer balance)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(let ((balance-serializer (make-serializer)))
(define (dispatch m)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
((eq? m 'balance) balance)
((eq? m 'serializer) balance-serializer)
(else (error "Unknown request: MAKE-ACCOUNT" m))))
dispatch))
(define (deposit account amount)
(let ((s (account 'serializer))
(d (account 'deposit)))
((s d) amount)))
(define (exchange account1 account2)
(let ((difference (- (account1 'balance)
(account2 'balance))))
((account1 'withdraw) difference)
((account2 'deposit) difference)))
(define (serialized-exchange account1 account2)
(let ((serializer1 (account1 'serializer))
(serializer2 (account2 'serializer)))
((serializer1 (serializer2 exchange))
account1
account2)))
#+end_src
The following code will thus get stuck in a deadlock:
#+begin_src scheme :exports both :results output
(define a1 (make-account-and-serializer 20))
(define a2 (make-account-and-serializer 30))
(parallel-execute
(lambda () (serialized-exchange a1 a2))
(lambda () (serialized-exchange a2 a1)))
#+end_src
We add serial numbers to resources:
#+begin_src scheme :exports both :results output
<<make-serializer>>
<<parallel-execute>>
(define (make-account-and-serializer balance serial)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(let ((balance-serializer (make-serializer)))
(define (dispatch m)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
((eq? m 'balance) balance)
((eq? m 'serializer) balance-serializer)
((eq? m 'order) serial)
(else (error "Unknown request: MAKE-ACCOUNT" m))))
dispatch))
(define (deposit account amount)
(let ((s (account 'serializer))
(d (account 'deposit)))
((s d) amount)))
(define (exchange account1 account2)
(let ((difference (- (account1 'balance)
(account2 'balance))))
((account1 'withdraw) difference)
((account2 'deposit) difference)))
(define (serialized-exchange account1 account2)
(let ((serializer1 (account1 'serializer))
(serializer2 (account2 'serializer)))
(if (< (account1 'order) (account2 'order))
((serializer1 (serializer2 exchange))
account1
account2)
((serializer2 (serializer1 exchange))
account2
account1))))
(define a1 (make-account-and-serializer 20 1))
(define a2 (make-account-and-serializer 30 2))
(show #t "Balance start: " (a1 'balance) " " (a2 'balance) "\n")
(parallel-execute
(lambda () (serialized-exchange a1 a2))
(lambda () (serialized-exchange a2 a1)))
(show #t "Balance end: " (a1 'balance) " " (a2 'balance) "\n")
#+end_src
#+RESULTS:
: Balance start: 20 30
: Balance end: 20 30
Exchange seems to go fine.
This works, because if mutexes are ordered, both all parallel
processes will try to access the same mutex first.
*** DONE Exercise 3.49 When numbering accounts doesn't work
CLOSED: [2020-01-03 Fri 13:41]
The case suggested by the hint of the exercise is the following:
Suppose we need to transfer the money from account a1 to some other
account, that is recorded as a list inside account a1, and then remove
this "pending transfer" from the list of transfers of account a1. To
do this, we would need to first lock the account a1 to get the pointer
to account a2, and _then_ lock a2. However, it may very well be that
the account a2 has a smaller serial number than a1.
We could, however, unlock a1, lock a2, then lock a1 again, and check
that the pending transaction from a1 to a2 is still needed.
*** Streams common
#+begin_src scheme :exports both :results output :noweb-ref streams-common
(define-syntax cons-stream
(syntax-rules ()
((cons-stream a b) (cons a (delay b)))))
(define (stream-car stream) (car stream))
(define (stream-cdr stream) (force (cdr stream)))
(define (stream-ref s n)
(if (= n 0)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
(define (stream-map proc s)
(if (stream-null? s)
the-empty-stream
(cons-stream (proc (stream-car s))
(stream-map proc (stream-cdr s)))))
(define stream-null? null?)
(define the-empty-stream '())
(define (stream-for-each proc s)
(if (stream-null? s)
'done
(begin (proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
(define (stream-enumerate-interval low high)
(if (> low high)
the-empty-stream
(cons-stream
low
(stream-enumerate-interval (+ low 1) high))))
(define (stream-filter pred stream)
(cond ((stream-null? stream) the-empty-stream)
((pred (stream-car stream))
(cons-stream (stream-car stream)
(stream-filter pred
(stream-cdr stream))))
(else (stream-filter pred (stream-cdr stream)))))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
(display (cons-stream 2 3))
(newline)
(display (stream-car (cons-stream 2 3)))
(newline)
(display (stream-cdr (cons-stream 2 3)))
(newline)
(display-stream (cons-stream 2 (cons-stream 3 the-empty-stream)))
#+end_src
#+RESULTS:
: (2 (#f . #<procedure #f>) promise)
: 2
: 3
:
: 2
: 3
NOTE: As far as I understand, ~(delay)~ and ~(force)~ are using
memoization inside by default in R^7 RS, so we needn't care about it
ourselves.
*** DONE Exercise 3.50 stream-map multiple arguments
CLOSED: [2020-01-03 Fri 21:18]
#+begin_src scheme :exports both :results output :noweb-ref streams-multimap
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map
(cons proc (map stream-cdr argstreams))))))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
(display-stream (stream-map list (cons-stream 'one the-empty-stream)
(cons-stream 'two the-empty-stream)))
#+end_src
#+RESULTS:
:
: (one two)
Apparently, works.
*** DONE Exercise 3.51 stream-show
CLOSED: [2020-01-03 Fri 21:28]
#+begin_src scheme :exports both :results output
<<streams-common>>
(define (show x)
(display-line x)
x)
(define x (stream-map show (stream-enumerate-interval 0 10)))
(stream-ref x 5)
(newline) (display "next call to stream-ref:")
(stream-ref x 7)
(stream-ref x 7)
#+end_src
#+RESULTS:
#+begin_example
0
1
2
3
4
5
next call to stream-ref:
6
7
#+end_example
Why does it only print 6 and 7 on the second call? The answer is --
memoization. Since ~force~ already knows the result of calls to
~(stream-ref 5)~, it doesn't call ~show~ on them again.
*** DONE Exercise 3.52 streams with mind-boggling
CLOSED: [2020-01-03 Fri 22:17]
#+begin_src scheme :exports both :results output
<<streams-common>>
(define sum 0)
(show #t "debug1: " sum "\n")
(define (accum x)
(set! sum (+ x sum))
sum)
(show #t "debug2: " sum "\n")
(define seq (stream-map accum (stream-enumerate-interval 1 20)))
(show #t "debug3 (stream-map forces a stream once): " sum "\n")
(define y (stream-filter even? seq))
(show #t "debug4 1+2+3: " sum "\n")
(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
seq))
(show #t "debug5 adds 4, as all lower are already evaluated: " sum "\n")
(stream-ref y 7)
(show #t "debug6 adds sums that are even up to 20: " sum "\n")
(display-stream z)
(show #t "\ndebug7: " sum "\n")
#+end_src
#+RESULTS:
#+begin_example
debug1: 0
debug2: 0
debug3: 1
debug4: 6
debug5: 10
debug6: 136
10
15
45
55
105
120
190
210
debug7: 210
#+end_example
#+begin_src scheme :exports both :results output
(define delay #f)
(define force #f)
(define-syntax delay
(syntax-rules ()
((delay x) (lambda () x))))
(define (force delayed-object) (delayed-object))
<<streams-common>>
(define sum 0)
(show #t "debug1: " sum "\n")
(define (accum x)
(set! sum (+ x sum))
sum)
(show #t "debug2: " sum "\n")
(define seq (stream-map accum (stream-enumerate-interval 1 20)))
(show #t "debug3: " sum "\n")
(define y (stream-filter even? seq))
(show #t "debug4: " sum "\n")
(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
seq))
(show #t "debug5: " sum "\n")
(stream-ref y 7)
(show #t "debug6: " sum "\n")
(display-stream z)
(show #t "\ndebug7: " sum "\n")
#+end_src
#+RESULTS:
#+begin_example
debug1: 0
debug2: 0
debug3: 1
debug4: 6
debug5: 15
debug6: 162
15
180
230
305
debug7: 362
#+end_example
The difference here, again, lies in memoization. In the first example,
sum is only evaluated once for every number from 1 to 20, in the
second, every time ~force~ is called. Every call to ~force~ adds to
the ~sum~. I find it hard to find when exactly things are added to the
sum. This can be debugged by adding a print to the ~accum~ procedure,
but the general rule seems to be: don't use mutation together with
lazy lists.
*** Some more tools for streams
#+begin_src scheme :exports both :results output :noweb-ref streams-2
(define (add-streams s1 s2)
(stream-map + s1 s2))
(define ones (cons-stream 1 ones))
(define zeros (cons-stream 0 zeros))
(define integers (cons-stream 1 (add-streams ones integers)))
(define (scale-stream stream factor)
(stream-map (lambda (x) (* x factor)) stream))
#+end_src
*** DONE Exercise 3.53 stream power of two
CLOSED: [2020-01-03 Fri 22:40]
Before running the code, I make a hypothesis that the stream
represents powers of two, because each element is the previous one,
doubled.
#+begin_src scheme :exports both :results value
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
(define s (cons-stream 1 (add-streams s s)))
(stream-ref s 6)
#+end_src
#+RESULTS:
: 64
*** DONE Exercise 3.54 mul-streams
CLOSED: [2020-01-03 Fri 22:47]
#+begin_src scheme :exports both :results output :noweb-ref streams-mul
(define (mul-streams s1 s2)
(stream-map * s1 s2))
#+end_src
#+begin_src scheme :exports both :results value
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-mul>>
(define factorials
(cons-stream 1 (mul-streams factorials integers)))
(stream-ref factorials 5)
#+end_src
#+RESULTS:
: 120
*** DONE Exercise 3.55 streams partial-sums
CLOSED: [2020-01-03 Fri 23:05]
#+begin_src scheme :exports both :results output :noweb-ref streams-partial-sums
(define (partial-sums s)
(define ps (cons-stream (stream-car s) (add-streams ps (stream-cdr s))))
ps)
#+end_src
#+begin_src scheme :exports both :results output value
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
(define ps (partial-sums integers))
(list (stream-ref ps 0)
(stream-ref ps 1)
(stream-ref ps 2)
(stream-ref ps 3)
(stream-ref ps 4))
#+end_src
#+RESULTS:
| 1 | 3 | 6 | 10 | 15 |
*** DONE Exercise 3.56 Hamming's streams-merge
CLOSED: [2020-01-03 Fri 23:26]
#+begin_src scheme :exports both :results output :noweb-ref streams-merge
(define (merge s1 s2)
(cond ((stream-null? s1) s2)
((stream-null? s2) s1)
(else
(let ((s1car (stream-car s1))
(s2car (stream-car s2)))
(cond ((< s1car s2car)
(cons-stream s1car (merge (stream-cdr s1) s2)))
((> s1car s2car)
(cons-stream s2car (merge s1 (stream-cdr s2))))
(else
(cons-stream s1car
(merge (stream-cdr s1)
(stream-cdr s2)))))))))
#+end_src
#+begin_src scheme :exports both :results value
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-merge>>
(define S (cons-stream 1 (merge (scale-stream S 2)
(merge (scale-stream S 3)
(scale-stream S 5)))))
(stream-ref S 5)
#+end_src
#+RESULTS:
: 6
*** DONE Exercise 3.57 exponential additions fibs
CLOSED: [2020-01-03 Fri 23:36]
The definition of ~fibs~ is the following:
#+begin_src scheme :exports both :results output
(define fibs
(cons-stream 0
(cons-stream 1
(add-streams (stream-cdr fibs)
fibs))))
#+end_src
With memoization, every step just requires \(O(n)\) additions, because
every ~stream-cdr~ would only add two already computed values.
Without memoization, every step would require computing all previous
values of the Fibonacci sequence from scratch. It is not hard to
notice that the element number N would require computing numbers N-1
and N-2, so every step would roughly double the number
operations. Thus the total number would be \(O(2^n)\).
*** DONE Exercise 3.58 Cryptic stream
CLOSED: [2020-01-03 Fri 23:50]
This cryptic stream approximates a rational fraction by a decimal
(radix) one.
#+begin_src scheme :exports both :results output
<<streams-common>>
(define (expand num den radix)
(cons-stream
(quotient (* num radix) den)
(expand (remainder (* num radix) den) den radix)))
(do ((i 0 (+ i 1)))
((= i 5) #t)
(show #t (stream-ref (expand 1 7 10) i)))
(newline)
(show #t (/ 1.0 7.0) "\n")
(do ((i 0 (+ i 1)))
((= i 5) #t)
(show #t (stream-ref (expand 3 8 10) i)))
(newline)
(show #t (/ 3.0 8.0) "\n")
#+end_src
#+RESULTS:
: 14285
: 0.14285714285714285
: 37500
: 0.375
*** DONE Exercise 3.59 power series
CLOSED: [2020-01-04 Sat 09:58]
**** DONE integrate series
CLOSED: [2020-01-04 Sat 09:49]
#+begin_src scheme :exports both :results output :noweb-ref streams-integrate-series
(define (div-streams s1 s2)
(stream-map / s1 s2))
(define (integrate-series s)
(div-streams s integers))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-integrate-series>>
(define test (integrate-series ones))
(do ((i 0 (+ i 1)))
((= i 5) #t)
(show #t (stream-ref test i) " "))
#+end_src
#+RESULTS:
: 1 1/2 1/3 1/4 1/5
**** DONE exponential series
CLOSED: [2020-01-04 Sat 09:58]
#+begin_src scheme :exports both :results output :noweb-ref streams-sin-cos
(define exp-series
(cons-stream 1 (integrate-series exp-series)))
(define cosine-series
(cons-stream 1 (integrate-series (scale-stream sine-series -1))))
(define sine-series
(cons-stream 0 (integrate-series cosine-series)))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-integrate-series>>
<<streams-sin-cos>>
(do ((i 0 (+ i 1)))
((= i 5) #t)
(show #t (stream-ref cosine-series i) " "))
(newline)
(do ((i 0 (+ i 1)))
((= i 5) #t)
(show #t (stream-ref sine-series i) " "))
#+end_src
#+RESULTS:
: 1 0 -1/2 0 1/24
: 0 1 0 -1/6 0
*** DONE Exercise 3.60 mul-series
CLOSED: [2020-01-04 Sat 11:07]
Let's write out a formula first:
\(S = \sum_{i=0}^{\infty}a_i \cdot \sum_{j=0}^{\infty}b_j = a_0 \cdot b_0 + b_0 \cdot
\sum_{i=1}^{\infty}a_i + \sum_{i=0}^{\infty}a_i \cdot \sum_{j=1}^{\infty}b_j\)
#+begin_src scheme :exports both :results output :noweb-ref streams-mul-series
(define (mul-series s1 s2)
(cons-stream (* (stream-car s1) (stream-car s2))
(add-streams (scale-stream (stream-cdr s1) (stream-car s2))
(mul-series s1 (stream-cdr s2)))))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-integrate-series>>
<<streams-sin-cos>>
<<streams-mul-series>>
<<streams-partial-sums>>
(define sum-of-sine-and-cosine
(partial-sums (add-streams (mul-series sine-series sine-series)
(mul-series cosine-series cosine-series))))
(do ((i 0 (+ i 1)))
((= i 10) #t)
(show #t (inexact (stream-ref sum-of-sine-and-cosine i)) " "))
#+end_src
#+RESULTS:
: 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0
Converges to 1 quite fast.
*** DONE Exercise 3.61 power-series-inversion
CLOSED: [2020-01-04 Sat 13:13]
#+begin_src scheme :exports both :results output :noweb-ref streams-invert-unit-series
#;(define (invert-unit-series S)
(define x (cons-stream 1
(mul-series
(scale-stream (cons-stream 0 (stream-cdr S)) -1)
x)))
x)
(define (invert-unit-series S)
(if (not (= 1 (stream-car S)))
(error "First term must be 1 -- INVERT-UNIT-SERIES" (stream-car S))
(let ((Sr (stream-cdr S)))
(define X
(cons-stream
1
(mul-series
(scale-stream Sr -1)
X)))
X)))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-integrate-series>>
<<streams-sin-cos>>
<<streams-mul-series>>
<<streams-partial-sums>>
<<streams-invert-unit-series>>
(define test (partial-sums (mul-series ones (invert-unit-series ones))))
#;("Should give a series with partial sums converging to 1")
(do ((i 0 (+ i 1)))
((= i 10) #t)
(show #t (inexact (stream-ref test i)) " "))
#+end_src
#+RESULTS:
: 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0
Okay, this exercise gave me hell of a lot of pain. Why on it is so
dependent on the implementation of ~mul-series~?
So this exercise has been solved with the help of the GitHub user
ypeels:
https://github.com/ypeels/sicp/blob/master/exercises/3.61-invert-unit-series.scm
*** DONE Exercise 3.62 div-series
CLOSED: [2020-01-04 Sat 13:21]
#+begin_src scheme :exports both :results output :noweb-ref streams-div-series
(define (div-series s1 s2)
(let* ((scale-factor (stream-car s2))
(scaled-s2 (scale-stream s2 (/ 1 scale-factor)))
(scaled-s1 (scale-stream s1 scale-factor))
(inverted-s2 (invert-unit-series scaled-s2)))
(mul-series scaled-s1 inverted-s2)))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-integrate-series>>
<<streams-sin-cos>>
<<streams-mul-series>>
<<streams-partial-sums>>
<<streams-invert-unit-series>>
<<streams-div-series>>
(define test (div-series ones exp-series))
#;("Should give a series with partial sums converging to 1")
(do ((i 0 (+ i 1)))
((= i 10) #t)
(show #t (inexact (stream-ref test i)) " "))
#+end_src
#+RESULTS:
: 1.0 0.0 0.5 0.3333333333333333 0.375 0.36666666666666664 0.3680555555555556 0.3678571428571429 0.36788194444444444 0.36787918871252206
Well, not sure this is correct, but it runs.
*** DONE Exercise 3.63 sqrt-stream
CLOSED: [2020-01-04 Sat 20:32]
#+begin_src scheme :exports both :results output :noweb-ref streams-sqrt-stream
(define (average x y)
(/ (+ x y) 2))
(define (sqrt-improve guess x)
(average guess (/ x guess)))
(define (sqrt-stream x)
(cons-stream 1.0
(stream-map (lambda (guess)
(sqrt-improve guess x))
(sqrt-stream x))))
#+end_src
The problem with the second definition is that ~(sqrt-stream x)~, as
it is called each time, creates a new stream. Since this streams are
not ~eq?~, memoization doesn't work. In the first implementation, the
same ~guesses~ is used, and thus, calls to the lambda are cached
(memoized).
If ~delay~ didn't use memoization, performance would be same for both
implementations.
*** DONE Exercise 3.64 stream-limit
CLOSED: [2020-01-06 Mon 09:38]
#+begin_src scheme :exports both :results output :noweb-ref streams-stream-limit
(define (stream-limit stream tolerance)
(let ((a1 (stream-car stream))
(a2 (stream-car (stream-cdr stream))))
(if (< (abs (- a1 a2)) tolerance)
a2
(stream-limit (stream-cdr stream) tolerance))))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref streams-sqrt
(define (sqrt x tolerance)
(stream-limit (sqrt-stream x) tolerance))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-stream-limit>>
<<streams-sqrt-stream>>
<<streams-sqrt>>
(show #t "Test sqrt of 17: " (sqrt 17 0.001) "\n")
#+end_src
#+RESULTS:
: Test sqrt of 17: 4.123105625617805
Seems to be working. I copied some of the ~sqrt~-related code from the
earlier chapters instead of tangling, because it seems too slow.
*** DONE Exercise 3.65 approximating logarithm
CLOSED: [2020-01-06 Mon 10:34]
First let's make sure that the pi-stream is working.
#+begin_src scheme :exports both :results output :noweb-ref streams-print-n
(define (stream-print-n stream n)
(do ((i 0 (+ i 1)))
((= i n) #t)
(display (stream-ref stream i))
(display " ")))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref streams-pi-summands
(define (pi-summands n)
(cons-stream (/ 1.0 n)
(stream-map - (pi-summands (+ n 2)))))
(define pi-stream
(scale-stream (partial-sums (pi-summands 1)) 4))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-pi-summands>>
<<streams-print-n>>
(stream-print-n pi-stream 10)
#+end_src
#+RESULTS:
: 4.0 2.666666666666667 3.466666666666667 2.8952380952380956 3.3396825396825403 2.9760461760461765 3.2837384837384844 3.017071817071818 3.2523659347188767 3.0418396189294032
Now let us do the same for the logarithm of 2.
#+begin_src scheme :exports both :results output :noweb-ref streams-log-summands
(define (log-summands n)
(cons-stream (/ 1.0 n)
(stream-map - (log-summands (+ n 1)))))
(define log-stream
(partial-sums (log-summands 1)))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref streams-euler-tableau
(define (euler-transform s)
(let ((s0 (stream-ref s 0))
(s1 (stream-ref s 1))
(s2 (stream-ref s 2)))
(cons-stream (- s2 (/ (square (- s2 s1))
(+ s0 (* -2 s1) s2)))
(euler-transform (stream-cdr s)))))
(define (make-tableau transform s)
(cons-stream s
(make-tableau transform
(transform s))))
(define (accelerated-sequence transform s)
(stream-map stream-car
(make-tableau transform s)))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-log-summands>>
<<streams-euler-tableau>>
(do ((i 0 (+ i 1)))
((= i 10) #t)
(show #t (stream-ref (log-summands 1) i) " "))
(newline)
(stream-print-n log-stream 10)
(newline)
(stream-print-n (euler-transform log-stream) 10)
(newline)
(stream-print-n (accelerated-sequence euler-transform log-stream) 10)
#+end_src
#+RESULTS:
: 1.0 -0.5 0.3333333333333333 -0.25 0.2 -0.16666666666666666 0.14285714285714285 -0.125 0.1111111111111111 -0.1
: 1.0 0.5 0.8333333333333333 0.5833333333333333 0.7833333333333332 0.6166666666666666 0.7595238095238095 0.6345238095238095 0.7456349206349207 0.6456349206349207
: 0.7 0.6904761904761905 0.6944444444444444 0.6924242424242424 0.6935897435897436 0.6928571428571428 0.6933473389355742 0.6930033416875522 0.6932539682539683 0.6930657506744464
: 1.0 0.7 0.6932773109243697 0.6931488693329254 0.6931471960735491 0.6931471806635636 0.6931471805604039 0.6931471805599445 0.6931471805599427 0.6931471805599454
The first stream seems to be converging quite slowly, needing about 10
steps for 0.01 precision. The "accelerated" sequence converges in
three steps, which seems to be super fast. Proper convergence analysis
would require a bit more of a mathematical analysis.
*** DONE Exercise 3.66 lazy pairs
CLOSED: [2020-01-06 Mon 22:55]
#+begin_src scheme :exports both :results output :noweb-ref streams-interleave
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref streams-pairs
(define (pairs s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(pairs (stream-cdr s) (stream-cdr t)))))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-interleave>>
<<streams-pairs>>
(stream-print-n (pairs integers integers) 100)
#+end_src
#+RESULTS:
: (1 1) (1 2) (2 2) (1 3) (2 3) (1 4) (3 3) (1 5) (2 4) (1 6) (3 4) (1 7) (2 5) (1 8) (4 4) (1 9) (2 6) (1 10) (3 5) (1 11) (2 7) (1 12) (4 5) (1 13) (2 8) (1 14) (3 6) (1 15) (2 9) (1 16) (5 5) (1 17) (2 10) (1 18) (3 7) (1 19) (2 11) (1 20) (4 6) (1 21) (2 12) (1 22) (3 8) (1 23) (2 13) (1 24) (5 6) (1 25) (2 14) (1 26) (3 9) (1 27) (2 15) (1 28) (4 7) (1 29) (2 16) (1 30) (3 10) (1 31) (2 17) (1 32) (6 6) (1 33) (2 18) (1 34) (3 11) (1 35) (2 19) (1 36) (4 8) (1 37) (2 20) (1 38) (3 12) (1 39) (2 21) (1 40) (5 7) (1 41) (2 22) (1 42) (3 13) (1 43) (2 23) (1 44) (4 9) (1 45) (2 24) (1 46) (3 14) (1 47) (2 25) (1 48) (6 7) (1 49) (2 26) (1 50) (3 15) (1 51)
The logic behind the ordering can be seen from the kind of a
"probabilistic analysis". Let's imagine a table with columns indexed
by the elements of the first stream, and rows indexed by the second
stream. Every call to "interleave" takes a row of a table, and another
instance of the "pairs". This means that the frequency, with which
elements of every row appear in the output is \(2^{^}{-n}\), where n is
the number of the row. Therefore the number of a pair (a,b) should be
something like \(b \cdot a^{n} \).
*** DONE Exercise 3.67 all possible pairs
CLOSED: [2020-01-06 Mon 23:09]
Seems not too hard. Just add in one more interleave.
#+begin_src scheme :exports both :results output :noweb-ref streams-pairs-full
(define (pairs s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(interleave
(stream-map (lambda (x) (list x (stream-car t)))
(stream-cdr s))
(pairs (stream-cdr s) (stream-cdr t))))))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-interleave>>
<<streams-pairs-full>>
(stream-print-n (pairs integers integers) 100)
#+end_src
#+RESULTS:
: (1 1) (1 2) (2 1) (1 3) (2 2) (1 4) (3 1) (1 5) (2 3) (1 6) (4 1) (1 7) (3 2) (1 8) (5 1) (1 9) (2 4) (1 10) (6 1) (1 11) (3 3) (1 12) (7 1) (1 13) (2 5) (1 14) (8 1) (1 15) (4 2) (1 16) (9 1) (1 17) (2 6) (1 18) (10 1) (1 19) (3 4) (1 20) (11 1) (1 21) (2 7) (1 22) (12 1) (1 23) (5 2) (1 24) (13 1) (1 25) (2 8) (1 26) (14 1) (1 27) (4 3) (1 28) (15 1) (1 29) (2 9) (1 30) (16 1) (1 31) (6 2) (1 32) (17 1) (1 33) (2 10) (1 34) (18 1) (1 35) (3 5) (1 36) (19 1) (1 37) (2 11) (1 38) (20 1) (1 39) (7 2) (1 40) (21 1) (1 41) (2 12) (1 42) (22 1) (1 43) (4 4) (1 44) (23 1) (1 45) (2 13) (1 46) (24 1) (1 47) (8 2) (1 48) (25 1) (1 49) (2 14) (1 50) (26 1) (1 51)
*** DONE Exercise 3.68 pairs-louis
CLOSED: [2020-01-06 Mon 23:26]
#+begin_src scheme :exports both :results output :noweb-ref streams-pairs-louis
(define (pairs s t)
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
t)
(pairs (stream-cdr s) (stream-cdr t))))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-interleave>>
<<streams-pairs-louis>>
(stream-print-n (pairs integers integers) 30)
#+end_src
#+RESULTS:
: ERROR: out of stack space
: >
This is expected. Remember, the second argument to ~cons-stream~ is
not evaluated, it's delayed. If we don't separate the first pair from
the rest, ~interleave~ would run indefinitely.
*** DONE Exercise 3.69 triples
CLOSED: [2020-01-07 Tue 11:00]
#+begin_src scheme :exports both :results output :noweb-ref streams-triples
(define (triples s t u)
(cons-stream
(list (stream-car s) (stream-car t) (stream-car u))
(interleave
(stream-map (lambda (x) (cons (stream-car s) x))
(pairs (stream-cdr t) (stream-cdr u)))
(triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
#+end_src
#+RESULTS:
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-interleave>>
<<streams-pairs>>
<<streams-triples>>
(stream-print-n
(stream-filter
(lambda (triple)
(let ((i (car triple))
(j (cadr triple))
(k (caddr triple)))
(= (* k k) (+ (* i i) (* j j)))))
(triples integers integers integers))
7)
#+end_src
#+RESULTS:
: (3 4 5) (6 8 10) (5 12 13) (9 12 15) (8 15 17) (12 16 20)
Seems to be working fine.
*** DONE Exercise 3.70 merge-weighted
CLOSED: [2020-01-07 Tue 11:58]
#+begin_src scheme :exports both :results output :noweb-ref streams-merge-weighted
(define (merge-weighted s1 s2 weight)
(cond ((stream-null? s1) s2)
((stream-null? s2) s1)
(else
(let ((s1car (stream-car s1))
(s2car (stream-car s2)))
(cond ((< (weight s1car) (weight s2car))
(cons-stream s1car (merge-weighted (stream-cdr s1) s2 weight)))
((> (weight s1car) (weight s2car))
(cons-stream s2car (merge-weighted s1 (stream-cdr s2) weight)))
(else
(cons-stream s1car
(merge-weighted (stream-cdr s1)
s2
weight))))))))
#+end_src
#+begin_src scheme :exports both :results output :noweb-ref streams-pairs-weighted
(define (pairs-weighted s t weight)
(cons-stream
(list (stream-car s) (stream-car t))
(merge-weighted
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(pairs-weighted (stream-cdr s) (stream-cdr t) weight)
weight)))
#+end_src
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-interleave>>
<<streams-merge-weighted>>
<<streams-pairs-weighted>>
(stream-print-n
(pairs-weighted
integers
integers
(lambda (p) (+ (car p) (cadr p))))
100)
(newline)
(stream-print-n
(pairs-weighted
(stream-filter (lambda (x) (and (not (= 0 (remainder x 2)))
(not (= 0 (remainder x 3)))
(not (= 0 (remainder x 5))))) integers)
(stream-filter (lambda (x) (and (not (= 0 (remainder x 2)))
(not (= 0 (remainder x 3)))
(not (= 0 (remainder x 5))))) integers)
(lambda (p) (+ (* 2 (car p)) (* 3 (cadr p) (* 5 (car p) (cadr p))))))
100)
#+end_src
#+RESULTS:
: (1 1) (1 2) (1 3) (2 2) (1 4) (2 3) (1 5) (2 4) (3 3) (1 6) (2 5) (3 4) (1 7) (2 6) (3 5) (4 4) (1 8) (2 7) (3 6) (4 5) (1 9) (2 8) (3 7) (4 6) (5 5) (1 10) (2 9) (3 8) (4 7) (5 6) (1 11) (2 10) (3 9) (4 8) (5 7) (6 6) (1 12) (2 11) (3 10) (4 9) (5 8) (6 7) (1 13) (2 12) (3 11) (4 10) (5 9) (6 8) (7 7) (1 14) (2 13) (3 12) (4 11) (5 10) (6 9) (7 8) (1 15) (2 14) (3 13) (4 12) (5 11) (6 10) (7 9) (8 8) (1 16) (2 15) (3 14) (4 13) (5 12) (6 11) (7 10) (8 9) (1 17) (2 16) (3 15) (4 14) (5 13) (6 12) (7 11) (8 10) (9 9) (1 18) (2 17) (3 16) (4 15) (5 14) (6 13) (7 12) (8 11) (9 10) (1 19) (2 18) (3 17) (4 16) (5 15) (6 14) (7 13) (8 12) (9 11) (10 10)
: (1 1) (1 7) (1 11) (1 13) (1 17) (7 7) (1 19) (1 23) (1 29) (7 11) (1 31) (7 13) (11 11) (1 37) (1 41) (1 43) (11 13) (7 17) (13 13) (1 47) (1 49) (7 19) (1 53) (11 17) (1 59) (7 23) (1 61) (13 17) (11 19) (1 67) (13 19) (17 17) (1 71) (1 73) (11 23) (7 29) (1 77) (17 19) (1 79) (7 31) (19 19) (13 23) (1 83) (1 89) (1 91) (17 23) (11 29) (1 97) (7 37) (19 23) (1 101) (11 31) (1 103) (13 29) (1 107) (7 41) (1 109) (23 23) (13 31) (1 113) (7 43) (1 119) (17 29) (1 121) (11 37) (7 47) (19 29) (1 127) (17 31) (7 49) (1 131) (1 133) (13 37) (19 31) (11 41) (1 137) (1 139) (23 29) (7 53) (11 43) (1 143) (13 41) (23 31) (1 149) (1 151) (17 37) (13 43) (11 47) (7 59) (29 29) (1 157) (1 161) (19 37) (7 61) (11 49) (1 163) (29 31) (1 167) (1 169) (17 41)
Cannot say I understand what the second sequence signifies, but meh.
*** DONE Exercise 3.71 Ramanujan numbers
CLOSED: [2020-01-07 Tue 12:49]
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-interleave>>
<<streams-merge-weighted>>
<<streams-pairs-weighted>>
(define cubic-pairs
(pairs-weighted
integers
integers
(lambda (p) (+ (expt (car p) 3) (expt (cadr p) 3)))))
(define sums-of-cubes
(stream-map (lambda (x) (+ (expt (car x) 3)
(expt (cadr x) 3)))
cubic-pairs))
(stream-print-n sums-of-cubes 20)
(define (first-repetition s)
(if (= (stream-car s) (stream-car (stream-cdr s)))
s
(first-repetition (stream-cdr s))))
(define (filter-repetitions s)
(cons-stream (stream-car (first-repetition s))
(filter-repetitions
(stream-cdr (stream-cdr (first-repetition s))))))
(newline)
#;(display (stream-car (filter-repetitions s)))
(stream-print-n (filter-repetitions sums-of-cubes) 6)
#+end_src
#+RESULTS:
: 2 9 16 28 35 54 65 72 91 126 128 133 152 189 217 224 243 250 280 341
: 1729 4104 13832 20683 32832 39312
This solution is not very good, because it would fail to distinguish
the Ramanujan 2-numbers from the Ramanujan 4-numbers, but I am too
lazy to fix it.
*** TODO Exercise 3.72 Ramanujan 3-numbers
WARNING: The code below is quite slow. On my machine it takes more time than
geiser's default ~geiser-connection-timeout~ permits.
Refer to [[Setting chibi arguments. DANGEROUS]] for more information.
#+begin_src scheme :exports both :results output
<<streams-common>>
<<streams-multimap>>
<<streams-2>>
<<streams-partial-sums>>
<<streams-print-n>>
<<streams-interleave>>
<<streams-merge-weighted>>
<<streams-pairs-weighted>>
(define cubic-pairs
(pairs-weighted
integers
integers
(lambda (p) (+ (expt (car p) 3) (expt (cadr p) 3)))))
(define sumcubes
(lambda (x) (+ (expt (car x) 3)
(expt (cadr x) 3))))
#;(stream-print-n sums-of-cubes 20)
(define (first-repetition s)
(if (= (sumcubes (stream-car s))
(sumcubes (stream-car (stream-cdr s)))
(sumcubes (stream-car (stream-cdr (stream-cdr s)))))
s
(first-repetition (stream-cdr s))))
(define (filter-repetitions s)
(cons-stream (stream-car (first-repetition s))
(filter-repetitions
(stream-cdr (stream-cdr (stream-cdr (first-repetition s)))))))
(display " ")
(stream-print-n (filter-repetitions cubic-pairs) 1)
(newline)
#+end_src
#+RESULTS:
: (167 436)
*** TODO Figure 3.32
*** TODO Exercise 3.73
*** TODO Exercise 3.74
*** TODO Exercise 3.75
*** TODO Exercise 3.76
*** TODO Exercise 3.77
*** TODO Figure 3.35
*** TODO Exercise 3.78
*** TODO Exercise 3.79
*** TODO Exercise 3.80
*** TODO Exercise 3.81
*** TODO Exercise 3.82
** TODO Chapter 4: Metalinguistic Abstraction [0/79]
*** TODO Exercise 4.1
*** TODO Exercise 4.2
*** TODO Exercise 4.3
*** TODO Exercise 4.4
*** TODO Exercise 4.5
*** TODO Exercise 4.6
*** TODO Exercise 4.7
*** TODO Exercise 4.8
*** TODO Exercise 4.9
*** TODO Exercise 4.10
*** TODO Exercise 4.11
*** TODO Exercise 4.12
*** TODO Exercise 4.13
*** TODO Exercise 4.14
*** TODO Exercise 4.15
*** TODO Exercise 4.16
*** TODO Exercise 4.17
*** TODO Exercise 4.18
*** TODO Exercise 4.19
*** TODO Exercise 4.20
*** TODO Exercise 4.21
*** TODO Exercise 4.22
*** TODO Exercise 4.23
*** TODO Exercise 4.24
*** TODO Exercise 4.25
*** TODO Exercise 4.26
*** TODO Exercise 4.27
*** TODO Exercise 4.28
*** TODO Exercise 4.29
*** TODO Exercise 4.30
*** TODO Exercise 4.31
*** TODO Exercise 4.32
*** TODO Exercise 4.33
*** TODO Exercise 4.34
*** TODO Exercise 4.35
*** TODO Exercise 4.36
*** TODO Exercise 4.37
*** TODO Exercise 4.38
*** TODO Exercise 4.39
*** TODO Exercise 4.40
*** TODO Exercise 4.41
*** TODO Exercise 4.42
*** TODO Exercise 4.43
*** TODO Exercise 4.44
*** TODO Exercise 4.45
*** TODO Exercise 4.46
*** TODO Exercise 4.47
*** TODO Exercise 4.48
*** TODO Exercise 4.49
*** TODO Exercise 4.50
*** TODO Exercise 4.51
*** TODO Exercise 4.52
*** TODO Exercise 4.53
*** TODO Exercise 4.54
*** TODO Exercise 4.55
*** TODO Exercise 4.56
*** TODO Exercise 4.57
*** TODO Exercise 4.58
*** TODO Exercise 4.59
*** TODO Exercise 4.60
*** TODO Exercise 4.61
*** TODO Exercise 4.62
*** TODO Exercise 4.63
*** TODO Exercise 4.64
*** TODO Exercise 4.65
*** TODO Exercise 4.66
*** TODO Exercise 4.67
*** TODO Exercise 4.68
*** TODO Exercise 4.69
*** TODO Exercise 4.70
*** TODO Exercise 4.71
*** TODO Exercise 4.72
*** TODO Exercise 4.73
*** TODO Exercise 4.74
*** TODO Exercise 4.75
*** TODO Exercise 4.76
*** TODO Exercise 4.77
*** TODO Exercise 4.78
*** TODO Exercise 4.79
** TODO Chapter 5: Computing with Register Machines [0/52]
*** TODO Exercise 5.1
*** TODO Exercise 5.2
*** TODO Exercise 5.3
*** TODO Exercise 5.4
*** TODO Exercise 5.5
*** TODO Exercise 5.6
*** TODO Exercise 5.7
*** TODO Exercise 5.8
*** TODO Exercise 5.9
*** TODO Exercise 5.10
*** TODO Exercise 5.11
*** TODO Exercise 5.12
*** TODO Exercise 5.13
*** TODO Exercise 5.14
*** TODO Exercise 5.15
*** TODO Exercise 5.16
*** TODO Exercise 5.17
*** TODO Exercise 5.18
*** TODO Exercise 5.19
*** TODO Exercise 5.20
*** TODO Exercise 5.21
*** TODO Exercise 5.22
*** TODO Exercise 5.23
*** TODO Exercise 5.24
*** TODO Exercise 5.25
*** TODO Exercise 5.26
*** TODO Exercise 5.27
*** TODO Exercise 5.28
*** TODO Exercise 5.29
*** TODO Exercise 5.30
*** TODO Exercise 5.31
*** TODO Exercise 5.32
*** TODO Exercise 5.33
*** TODO Exercise 5.34
*** TODO Exercise 5.35
*** TODO Exercise 5.36
*** TODO Exercise 5.37
*** TODO Exercise 5.38
*** TODO Exercise 5.39
*** TODO Exercise 5.40
*** TODO Exercise 5.41
*** TODO Exercise 5.42
*** TODO Exercise 5.43
*** TODO Exercise 5.44
*** TODO Exercise 5.45
*** TODO Exercise 5.46
*** TODO Exercise 5.47
*** TODO Exercise 5.48
*** TODO Exercise 5.49
*** TODO Exercise 5.50
*** TODO Exercise 5.51
*** TODO Exercise 5.52
* Footnotes
[fn:1] This exercise took me 7 hours.
[fn:2] This exercise took me about 40 hours.
^ permalink raw reply [flat|nested] 6+ messages in thread