SICP Chapter #04 Examples in Oz
% 4.1.1 - The Metacircular Evaluator - The Core of the Evaluator
fun {Eval Exp Env}
case Exp
of tm_unit then val_unit
[] tm_bool(Exp) then val_bool(Exp)
[] tm_int(Exp) then val_int(Exp)
[] tm_real(Exp) then val_real(Exp)
[] tm_string(Exp) then val_string(Exp)
[] tm_quoted(Exp) then val_quoted(Exp)
[] tm_if(Exp E1 E2) then if {Eval Exp Env} == val_bool(true) then {Eval E1 Env} else {Eval E2 Env} end
[] tm_cond(Exp) then {Eval {Cond2If Exp} Env}
[] tm_begin(Exp) then {FoldL Exp fun {$ _ X} {Eval X Env} end val_unit}
[] tm_symbol(Exp) then {LookupVariableValue Exp Env}
[] tm_definition(E1 E2) then {DefineVariable E1 {Eval E2 Env} Env}
[] tm_assignment(E1 E2) then {SetVariableValue E1 {Eval E2 Env} Env}
[] tm_lambda(Parms Body) then val_closure(Parms Body Env)
[] tm_application(F Args) then {Apply {Eval F Env} {Map Args fun {$ X} {Eval X Env} end}}
end
end
fun {Apply F Args}
case F
of val_primitive(Sym F) then {F Args}
[] val_closure(Parameters Body Env) then
if {Length Parameters} \= {Length Args}
then
if {Length Parameters} < {Length Args}
then raise evaluator('Too many arguments supplied') end
else raise evaluator('Too few arguments supplied') end
end
else
local
% create the closure environment
NewEnv = {NewDictionary}|Env
% pair up the parameters and arguments into a list
Pairs = {ListPairZip Parameters Args}
in
% push the parameters/arguments into the closure environment
_ = {Map Pairs fun {$ X#Y} {DefineVariable X Y NewEnv} end}
% evaluate the body of the closure
{Eval Body NewEnv}
end
end
else raise evaluator('Unknown procedure type -- APPLY') end
end
end
% 4.1.3 - The Metacircular Evaluator - Evaluator Data Structures
fun {LookupVariableValue Var Env}
case Env
of Frame|EnclosingEnvironment then
if {Dictionary.member Frame Var}
then {Dictionary.get Frame Var}
else {LookupVariableValue Var EnclosingEnvironment}
end
[] nil then
{Browse var}
raise evaluator('Unbound variable '#Var) end
end
end
fun {SetVariableValue Var Val Env}
case Env
of Frame|EnclosingEnvironment then
if {Dictionary.member Frame Var}
then
{Dictionary.put Frame Var Val}
Val
else {SetVariableValue Var Val EnclosingEnvironment}
end
[] nil then
raise evaluator('Unbound variable -- SET! '#Var) end
end
end
fun {DefineVariable Var Val Env}
case Env
of Frame|_ then
{Dictionary.put Frame Var Val}
Val
[] nil then
raise evaluator('Empty Environment '#Var) end
end
end
fun {Cond2If L}
case L
of (Pred#Exp)|Xs then tm_if(Pred Exp {Cond2If Xs})
[] nil then tm_unit
end
end
fun {ListPairZip L1 L2}
case L1#L2
of (H1|T1)#(H2|T2) then (H1#H2)|{ListPairZip T1 T2}
[] nil#nil then nil
end
end
% primitive implementations for source language
SCHEME =
functor
export
valueToString : ValueToString
makeGlobalEnvironment : MakeGlobalEnvironment
define
fun {ValueToString X}
case X
of val_unit then {StringToAtom "unit"}
[] val_bool(V) then V %{AtomToString V}
[] val_int(V) then {StringToAtom {IntToString V}}
[] val_real(V) then {FloatToString V}
[] val_string(V) then "\"" # V # "\""
[] val_tuple(X Y) then "Pair(" # {ValueToString X} # ", " # {ValueToString Y} # ")"
[] val_quoted(V) then {StringToAtom "Quote"}
[] val_symbol(V) then {StringToAtom V}
[] val_primitive(V F) then ""
[] val_closure(P B E) then {StringToAtom ""}
end
end
fun {IsValTrue val_bool(X)} X end
fun {PrimitiveEq Args}
fun {CompEq X Y}
case X#Y
of val_bool(A) # val_bool(B) then A == B
[] val_int(A) # val_int(B) then A == B
[] val_int(A) # B then {CompEq val_real({IntToFloat A}) B}
[] val_real(A) # val_real(B) then A == B
[] val_string(A) # val_string(B) then A == B
[] val_unit # val_unit then true
[] val_unit # val_tuple(_) then false
[] val_tuple(_ _) # val_unit then false
[] val_tuple(A B) # val_tuple(C D) then {CompEq A C} andthen {CompEq B D}
else raise evaluator('Invalid Compare') end
end
end
in
case {Length Args}
of 0 then raise evaluator('Invalid Number of arguments for compare') end
[] 1 then raise evaluator('Invalid Number of arguments for compare') end
[] 2 then val_bool({CompEq Args.1 Args.2.1})
else val_bool({CompEq Args.1 Args.2.1} andthen {IsValTrue {PrimitiveEq Args.2}})
end
end
fun {PrimitiveNeq Args}
val_bool({Not {IsValTrue {PrimitiveEq Args}}})
end
fun {PrimitiveGt Args}
fun {CompGt X Y}
case X#Y
of val_int(A) # val_int(B) then A > B
[] val_int(A) # B then {CompGt val_real({IntToFloat A}) B}
[] val_real(A) # val_real(B) then A > B
else raise evaluator('Invalid Compare') end
end
end
in
case {Length Args}
of 0 then raise evaluator('Invalid Number of arguments for compare') end
[] 1 then raise evaluator('Invalid Number of arguments for compare') end
[] 2 then val_bool({CompGt Args.1 Args.2.1})
else val_bool({CompGt Args.1 Args.2.1} andthen {IsValTrue {PrimitiveGt Args.2}})
end
end
fun {PrimitiveLt Args}
val_bool({Not {IsValTrue {PrimitiveEq Args}}} andthen {Not {IsValTrue {PrimitiveGt Args}}})
end
fun {PrimitiveGte Args}
val_bool({IsValTrue {PrimitiveEq Args}} orelse {IsValTrue {PrimitiveGt Args}})
end
fun {PrimitiveLte Args}
val_bool({IsValTrue {PrimitiveEq Args}} orelse {Not {IsValTrue {PrimitiveGt Args}}})
end
fun {PrimitivePlus Args}
case Args
of nil then val_int(0)
[] val_int(X)|T then
case {PrimitivePlus T}
of val_int(Y) then val_int(X + Y)
[] val_real(Y) then val_real({IntToFloat X} + Y)
else raise evaluator('Unexpected error for plus') end
end
[] val_real(X) | T then
case {PrimitivePlus T}
of val_int(Y) then val_real(X + {IntToFloat Y})
[] val_real(Y) then val_real(X + Y)
else raise evaluator('Unexpected error for plus') end
end
else raise evaluator('Invalid argument for plus') end
end
end
fun {PrimitiveMinus Args}
case Args
of nil then raise evaluator('Invalid argument for minus') end
[] val_int(X)|nil then val_int(~X)
[] val_int(X)|T then
case {PrimitivePlus T}
of val_int(Y) then val_int(X - Y)
[] val_real(Y) then val_real({IntToFloat X} - Y)
else raise evaluator('Unexpected error for minus') end
end
[] val_real(X)|nil then val_real(~X)
[] val_real(X)|T then
case {PrimitivePlus T}
of val_int(Y) then val_real(X - {IntToFloat Y})
[] val_real(Y) then val_real(X - Y)
else raise evaluator('Unexpected error for minus') end
end
else raise evaluator('Invalid argument for plus') end
end
end
fun {PrimitiveMultiply Args}
case Args
of nil then val_int(1)
[] val_int(X)|nil then val_int(X)
[] val_real(X)|nil then val_real(X)
[] val_int(X)|T then
case {PrimitiveMultiply T}
of val_int(Y) then val_int(X * Y)
[] val_real(Y) then val_real({IntToFloat X} * Y)
else raise evaluator('Unexpected error for multiply') end
end
[] val_real(X)|T then
case {PrimitiveMultiply T}
of val_int(Y) then val_real(X * {IntToFloat Y})
[] val_real(Y) then val_real(X * Y)
else raise evaluator('Unexpected error for multiply') end
end
else raise evaluator('Invalid argument for multiply') end
end
end
% Note: not currently supporting scheme's rational fractions
fun {PrimitiveDivide Args}
case Args
of nil then raise evaluator('Invalid argument for minus') end
[] val_int(X)|nil then val_real(1.0 / {IntToFloat X})
[] val_real(X)|nil then val_real(1.0 / X)
[] val_int(X)|T then
case {PrimitiveMultiply T}
of val_int(0) then raise evaluator('Divide by zero error') end
[] val_real(0.0) then raise evaluator('Divide by zero error') end
[] val_int(Y) then val_real({IntToFloat X} / {IntToFloat Y})
[] val_real(Y) then val_real({IntToFloat X} / Y)
else raise evaluator('Unexpected error for divide') end
end
[] val_real(X)|T then
case {PrimitiveMultiply T}
of val_int(Y) then val_real(X / {IntToFloat Y})
[] val_real(Y) then val_real(X / Y)
else raise evaluator('Unexpected error for divide') end
end
else raise evaluator('Invalid argument for divide') end
end
end
fun {PrimitiveNull L}
case L
of [val_unit] then val_bool(true)
[] _|_ then val_bool(false)
[] nil then val_bool(false)
end
end
fun {PrimitiveCons L}
case L
of Car|Cdr|nil then val_tuple(Car Cdr)
else raise evaluator('Invalid arguments for cons') end
end
end
fun {PrimitiveCar L}
case L
of [val_tuple(Car Cdr)] then Car
else raise evaluator('Invalid arguments for car') end
end
end
fun {PrimitiveCdr L}
case L
of [val_tuple(Car Cdr)] then Cdr
else raise evaluator('Invalid arguments for cdr') end
end
end
fun {PrimitiveAnd L}
case L
of nil then val_bool(true)
[] H|nil then H
[] val_bool(false)|_ then val_bool(false)
[] H|T then {PrimitiveAnd T}
end
end
fun {PrimitiveOr L}
case L
of nil then val_bool(false)
[] H|nil then H
[] val_bool(true)|_ then val_bool(true)
[] val_bool(false)|T then {PrimitiveOr T}
[] H|T then H
end
end
fun {PrimitiveNot L}
case L
of [val_bool(false)] then val_bool(true)
[] [_] then val_bool(false)
else raise evaluator('Invalid number of arguments for not') end
end
end
fun {PrimitiveDisplay L}
case L
of H|nil then
{Browse H}
val_unit
[] X|Y|nil then {PrimitiveDisplay X|nil}
else raise evaluator('Invalid number of arguments for display') end
end
end
fun {PrimitiveStringAppend Args}
fun {Iter S L}
case L
of nil then val_string(S)
[] val_string(X)|T then {Iter S#X T}
else raise evaluator('Invalid arguments for string-append') end
end
end
in
{Iter "" Args}
end
fun {MakeGlobalEnvironment}
Frame = {NewDictionary}
in
{Dictionary.put Frame '=' val_primitive('=' PrimitiveEq )}
{Dictionary.put Frame '<>' val_primitive('<>' PrimitiveNeq )}
{Dictionary.put Frame '>' val_primitive('>' PrimitiveGt )}
{Dictionary.put Frame '<' val_primitive('<' PrimitiveLt )}
{Dictionary.put Frame '>=' val_primitive('>=' PrimitiveGte )}
{Dictionary.put Frame '<=' val_primitive('<=' PrimitiveLte )}
{Dictionary.put Frame '+' val_primitive('+' PrimitivePlus )}
{Dictionary.put Frame '-' val_primitive('-' PrimitiveMinus )}
{Dictionary.put Frame '*' val_primitive('*' PrimitiveMultiply )}
{Dictionary.put Frame '/' val_primitive('/' PrimitiveDivide )}
{Dictionary.put Frame 'null?' val_primitive('null?' PrimitiveNull )}
{Dictionary.put Frame 'cons' val_primitive('cons' PrimitiveCons )}
{Dictionary.put Frame 'car' val_primitive('car' PrimitiveCar )}
{Dictionary.put Frame 'cdr' val_primitive('cdr' PrimitiveCdr )}
{Dictionary.put Frame 'and' val_primitive('and' PrimitiveAnd )}
{Dictionary.put Frame 'or' val_primitive('or' PrimitiveOr )}
{Dictionary.put Frame 'not' val_primitive('not' PrimitiveNot )}
{Dictionary.put Frame 'Display' val_primitive('Display' PrimitiveDisplay )}
{Dictionary.put Frame 'StringAppend' val_primitive('StringAppend' PrimitiveStringAppend)}
Frame|nil
end
end
[Scheme] = {Module.apply [SCHEME]}
% 4.1.4 - The Metacircular Evaluator - Running the Evaluator as a Program
TheGlobalEnvironment = {Scheme.makeGlobalEnvironment}
fun {EvalPrint Code}
Val = {Eval Code TheGlobalEnvironment}
in
{Browse Val}
Val
end
% 1 + 6
_ = {EvalPrint tm_application(tm_symbol('+') [tm_int(10) tm_int(6)])}
% 1 + (2 * 3)
_ = {EvalPrint tm_application(tm_symbol('+') [tm_int(1) tm_application(tm_symbol('*') [tm_int(2) tm_int(3)])])}
% X = 6
_ = {EvalPrint tm_definition('X' tm_int(6))}
% (1 + X)
_ = {EvalPrint tm_application(tm_symbol('+') [tm_int(1) tm_symbol('X')])}
% Pi = 3.14
_ = {EvalPrint tm_definition('Pi' tm_real(3.14))}
% 27.0 / (13.0 - Pi)
_ = {EvalPrint tm_application(tm_symbol('/') [tm_real(27.0) tm_application(tm_symbol('-') [tm_real(13.0) tm_symbol('Pi')])])}
% Square = fun {$ X} X * X end
_ = {EvalPrint tm_definition('Square' tm_lambda(['X'] tm_application(tm_symbol('*') [tm_symbol('X') tm_symbol('X')])))}
% Z = {Square 5.0}
_ = {EvalPrint tm_definition('Z' tm_application(tm_symbol('Square') [tm_real(5.0)]))}
% fun {Append Xs, Ys}
% if Xs == nil
% then Ys
% else Xs.1 | {Append Xs.2 Ys}
% end
% end
_ = {EvalPrint
tm_definition(
'Append'
tm_lambda(
['Xs' 'Ys']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('Xs') tm_unit])
tm_symbol('Ys')
tm_application(
tm_symbol('cons')
[
tm_application(tm_symbol('car') [tm_symbol('Xs')])
tm_application(
tm_symbol('Append')
[
tm_application(tm_symbol('cdr') [tm_symbol('Xs')])
tm_symbol('Ys')
])
]))))}
% Xs = [a b c]
_ = {EvalPrint
tm_definition(
'Xs'
tm_application(
tm_symbol('cons')
[
tm_string(a)
tm_application(
tm_symbol('cons')
[
tm_string(b)
tm_application(tm_symbol('cons') [tm_string(c) tm_unit])
])
]))}
% Ys = [d e f]
_ = {EvalPrint
tm_definition(
'Ys'
tm_application(
tm_symbol('cons')
[
tm_string(d)
tm_application(
tm_symbol('cons')
[
tm_string(e)
tm_application(tm_symbol('cons') [tm_string(f) tm_unit])
])
]))}
% Zs = {Append Xs Ys}
_ = {EvalPrint tm_application(tm_symbol('Append') [tm_symbol('Xs') tm_symbol('Ys')])}
% (cond ((> x 0) x)
% ((= x 0) (display 'zero) 0)
% (else (- x)))
_ = {EvalPrint
tm_cond(
[
tm_application(tm_symbol('>') [tm_symbol('X') tm_int(0)])#tm_symbol('X')
tm_application(tm_symbol('=') [tm_symbol('X') tm_int(0)])#
tm_begin([tm_application(tm_symbol('Display') [tm_string('zero')]) tm_int(0)])
tm_bool(true)#tm_application(tm_symbol('-') [tm_symbol('X')])
])}
% if x > 0
% then x
% else
% if x == 0
% then {Browse "zero"} 0
% else ~x
% end
% end
_ = {EvalPrint
tm_if(
tm_application(tm_symbol('>') [tm_symbol('X') tm_int(0)])
tm_symbol('X')
tm_if(
tm_application(tm_symbol('=') [tm_symbol('X') tm_int(0)])
tm_begin([tm_application(tm_symbol('Display') [tm_string "zero"]) tm_int(0)])
tm_application(tm_symbol('-') [tm_symbol('X')])))}
% local
% X = 3
% Y = X + 2
% Z = X + Y + 5
% in
% X * Z
% end
_ = {EvalPrint
tm_application(
tm_lambda(
nil
tm_begin(
[
tm_definition('X' tm_int(3))
tm_definition('Y' tm_application(tm_symbol('+') [tm_symbol('X') tm_int(2)]))
tm_definition('Z' tm_application(tm_symbol('+')
[tm_symbol('X') tm_application(tm_symbol('+') [tm_symbol('Y') tm_int(5)])]))
tm_application(tm_symbol('*') [tm_symbol('X') tm_symbol('Z')])
]))
nil)}
% The "and" is not working properly for val.
% The answer given is 5, but it should be 3.
% X = 1
% local
% X = 3
% Y = X + 2
% in
% Y
% end
_ = {EvalPrint tm_definition('X' tm_int(1))}
_ = {EvalPrint
tm_application(
tm_lambda(
nil
tm_begin(
[
tm_definition('X' tm_int(3))
tm_definition('Y' tm_application(tm_symbol('+') [tm_symbol('X') tm_int(2)]))
tm_symbol('Y')
]))
nil)}
% An extension to the eval function should address this problem:
% ((let? exp) (m-eval (let->combination exp) env))
% (define (let->combination let-exp)
% (let ((names (let-bound-variables let-exp))
% (values (let-values let-exp))
% (body (let-body let-exp)))
% (cons (list 'lambda names body) values)))
% fun {Fib N}
% fun {FibIter A B Count}
% case Count
% of 0 then B
% else {FibIter A+B A Count-1}
% end
% in
% {FibIter 1 0 N}
% end
_ = {EvalPrint
tm_definition(
'Fib'
tm_lambda(
['N']
tm_begin(
[
tm_definition(
'FibIter'
tm_lambda(
['A' 'B' 'Count']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('Count') tm_int(0)])
tm_symbol('B')
tm_application(
tm_symbol('FibIter')
[
tm_application(tm_symbol('+') [tm_symbol('A') tm_symbol('B')])
tm_symbol('A')
tm_application(tm_symbol('-') [tm_symbol('Count') tm_int(1)])
]))))
tm_application(tm_symbol('FibIter') [tm_int(1) tm_int(0) tm_symbol('N')])
])))}
% fib 10
_ = {EvalPrint tm_application(tm_symbol('Fib') [tm_int(10)])}
% 4.1.5 - The Metacircular Evaluator - Data as Programs
% fun {Factorial N}
% if N == 1
% then 1
% else N * {Factorial N-1}
% end
% end
_ = {EvalPrint
tm_definition(
'Factorial'
tm_lambda(
['N']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('N') tm_int(1)])
tm_int(1)
tm_application(
tm_symbol('*')
[
tm_symbol('N')
tm_application(tm_symbol('Factorial') [tm_application(tm_symbol('-') [tm_symbol('N') tm_int(1)])])
]))))}
% {Factorial 5}
_ = {EvalPrint tm_application(tm_symbol('Factorial') [tm_int(5)])}
% (eval '( * 5 5) user-initial-environment)
_ = {EvalPrint tm_application(tm_symbol('*') [tm_int(5) tm_int(5)])}
% Need to write a parser before I can translate this:
% (eval (cons '* (list 5 5)) user-initial-environment)
% Exercise 4.15
fun {RunForever} {RunForever} end
fun {Halts P Q} true end
fun {Try P}
if {Halts P P}
then {RunForever}
else raise halted end
end
end
% 4.1.6 - The Metacircular Evaluator - Internal Definitions
% fun {F X}
% fun {IsEven N}
% if N == 0
% then true
% else {IsOdd N-1}
% end
% end
% fun {IsOdd N}
% if N == 0
% then false
% else {IsEven N-1}
% end
% end
% in
% ... rest of body of f ...
% {IsEven X}
% end
_ = {EvalPrint
tm_definition(
'F'
tm_lambda(
['X']
tm_begin(
[
tm_definition(
'IsEven'
tm_lambda(
['N']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('N') tm_int(0)])
tm_bool(true)
tm_application(
tm_symbol('IsOdd')
[tm_application(tm_symbol('-') [tm_symbol('N') tm_int(1)])]))))
tm_definition(
'IsOdd'
tm_lambda(
['N']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('N') tm_int(0)])
tm_bool(false)
tm_application(
tm_symbol('IsEven')
[tm_application(tm_symbol('-') [tm_symbol('N') tm_int(1)])]))))
tm_application(tm_symbol('IsEven') [tm_symbol('X')])
])))}
_ = {EvalPrint tm_application(tm_symbol('F') [tm_int(3)])}
% Exercise 4.19
% local
% A = 1
% fun {F X}
% B = A + X
% in
% local
% A = 5
% in
% A + B
% end
% end
% in
% _ = {F 10}
% end
_ = {EvalPrint
tm_begin(
[
tm_definition('A' tm_int(1))
tm_definition(
'F'
tm_lambda(
['X']
tm_begin(
[
tm_definition('B' tm_application(tm_symbol('+') [tm_symbol('A') tm_symbol('X')]))
tm_definition('A' tm_int(5))
tm_application(tm_symbol('+') [tm_symbol('A') tm_symbol('B')])
])))
tm_application(tm_symbol('F') [tm_int(10)])
])}
% fun {Factorial N}
% if N == 1
% then 1
% else N * {Factorial N-1}
% end
% end
_ = {EvalPrint
tm_definition(
'Factorial'
tm_lambda(
['N']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('N') tm_int(1)])
tm_int(1)
tm_application(
tm_symbol('*')
[
tm_symbol('N')
tm_application(tm_symbol('Factorial') [tm_application(tm_symbol('-') [tm_symbol('N') tm_int(1)])])
]))))}
% Exercise 4.21
% Y Combinator
% _ = {fun {$ N}
% {fun {$ Fact}
% {Fact Fact N}
% end
%
% fun {$ Ft K}
% if K == 1
% then 1
% else K * {Ft Ft K-1}
% end
% end}
% end 10}
_ = {EvalPrint
tm_application(
tm_application(
tm_lambda(['Fact'] tm_application(tm_symbol('Fact') [tm_symbol('Fact')]))
[
tm_lambda(
['Ft']
tm_lambda(
['K']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('K') tm_int(1)])
tm_int(1)
tm_application(
tm_symbol('*')
[
tm_symbol('K')
tm_application(
tm_application(tm_symbol('Ft') [tm_symbol('Ft')])
[tm_application(tm_symbol('-') [tm_symbol('K') tm_int(1)])])
]))))
])
[tm_int(10)])}
% 4.1.7 - The Metacircular Evaluator - Separating Syntactic Analysis from Execution
fun {EvalA Exp Env}
{{Analyze Exp} Env}
end
fun {Analyze Exp}
case Exp
of tm_unit then fun {$ Env} val_unit end
[] tm_bool(Exp) then fun {$ Env} val_bool(Exp) end
[] tm_int(Exp) then fun {$ Env} val_int(Exp) end
[] tm_real(Exp) then fun {$ Env} val_real(Exp) end
[] tm_string(Exp) then fun {$ Env} val_string(Exp) end
[] tm_quoted(Exp) then fun {$ Env} val_quoted(Exp) end
[] tm_if(Exp E1 E2) then local
Pproc = {Analyze Exp}
Cproc = {Analyze E1}
Aproc = {Analyze E2}
in
fun {$ Env}
if {Pproc Env} == val_bool(true) then {Cproc Env} else {Aproc Env} end
end
end
[] tm_cond(Exp) then {Analyze {Cond2If Exp}}
[] tm_begin(Exp) then local
Aprocs = {Map Exp Analyze}
in
fun {$ Env} {FoldL Aprocs fun {$ _ X} {X Env} end val_unit} end
end
[] tm_symbol(Exp) then fun {$ Env} {LookupVariableValue Exp Env} end
[] tm_definition(E1 E2) then local Vproc = {Analyze E2} in fun {$ Env} {DefineVariable E1 {Vproc Env} Env} end end
[] tm_assignment(E1 E2) then local Vproc = {Analyze E2} in fun {$ Env} {SetVariableValue E1 {Vproc Env} Env} end end
[] tm_lambda(Parms Body) then local Aproc = {Analyze Body} in fun {$ Env} val_closure(Parms Aproc Env) end end
[] tm_application(F Args) then local
Fproc = {Analyze F}
Aprocs = {Map Args Analyze}
in
fun {$ Env}
{ExecuteApplication {Fproc Env} {Map Aprocs fun {$ X} {X Env} end}}
end
end
end
end
fun {ExecuteApplication F Args}
case F
of val_primitive(Sym F) then {F Args}
[] val_closure(Parameters Body Env) then
if {Length Parameters} \= {Length Args}
then
if {Length Parameters} < {Length Args}
then raise evaluator('Too many arguments supplied') end
else raise evaluator('Too few arguments supplied') end
end
else
local
% create the closure environment
NewEnv = {NewDictionary}|Env
% pair up the parameters and arguments into a list
Pairs = {ListPairZip Parameters Args}
in
% push the parameters/arguments into the closure environment
_ = {Map Pairs fun {$ X#Y} {DefineVariable X Y NewEnv} end}
% return the evaluated body of the closure
{Body NewEnv}
end
end
else raise evaluator('Unknown procedure type -- APPLY') end
end
end
% repeated from above
TheGlobalEnvironmentA = {Scheme.makeGlobalEnvironment}
fun {EvalPrintA Code}
Val = {EvalA Code TheGlobalEnvironmentA}
in
{Browse Val}
Val
end
% fun {Factorial N}
% if N == 1
% then 1
% else N * {Factorial N-1}
% end
% end
_ = {EvalPrintA
tm_definition(
'Factorial'
tm_lambda(
['N']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('N') tm_int(1)])
tm_int(1)
tm_application(
tm_symbol('*')
[
tm_symbol('N')
tm_application(tm_symbol('Factorial') [tm_application(tm_symbol('-') [tm_symbol('N') tm_int(1)])])
]))))}
% {Factorial 5}
_ = {EvalPrintA tm_application(tm_symbol('Factorial') [tm_int(5)])}
% 4.2.1 - Variations on a Scheme -- Lazy Evaluation - Normal Order and Applicative Order
fun {Try_ A B}
if A == 0
then 1
else B
end
end
fun {Unless Condition UsualValue ExceptionalValue}
if Condition
then ExceptionalValue
else UsualValue
end
end
% Exercise 4.25
fun {Factorial_ N}
{Unless N==1 N*{Factorial_ N-1} 1}
end
% 4.2.2 - Variations on a Scheme -- Lazy Evaluation - An Interpreter with Lazy Evaluation
fun {EvalL Exp Env}
case Exp
of tm_unit then val_unit
[] tm_bool(Exp) then val_bool(Exp)
[] tm_int(Exp) then val_int(Exp)
[] tm_real(Exp) then val_real(Exp)
[] tm_string(Exp) then val_string(Exp)
[] tm_quoted(Exp) then val_quoted(Exp)
[] tm_if(Exp E1 E2) then if {EvalL Exp Env} == val_bool(true) then {EvalL E1 Env} else {EvalL E2 Env} end
[] tm_cond(Exp) then {EvalL {Cond2If Exp} Env}
[] tm_begin(Exp) then {FoldL Exp fun {$ _ X} {EvalL X Env} end val_unit}
[] tm_symbol(Exp) then {LookupVariableValue Exp Env}
[] tm_definition(E1 E2) then {DefineVariable E1 {EvalL E2 Env} Env}
[] tm_assignment(E1 E2) then {SetVariableValue E1 {EvalL E2 Env} Env}
[] tm_lambda(Parms Body) then val_closure(Parms Body Env)
[] tm_application(F Args) then {ApplyL {EvalL F Env} {Map Args fun lazy {$ X} {EvalL X Env} end}}
end
end
fun {ApplyL F Args}
case F
of val_primitive(Sym F) then {F Args}
[] val_closure(Parameters Body Env) then
if {Length Parameters} \= {Length Args}
then
if {Length Parameters} < {Length Args}
then raise evaluator('Too many arguments supplied') end
else raise evaluator('Too few arguments supplied') end
end
else
local
% create the closure environment
NewEnv = {NewDictionary}|Env
% pair up the parameters and arguments into a list
Pairs = {ListPairZip Parameters Args}
in
% push the parameters/arguments into the closure environment
_ = {Map Pairs fun {$ X#Y} {DefineVariable X Y NewEnv} end}
% evaluate the body of the closure
{EvalL Body NewEnv}
end
end
else raise evaluator('Unknown procedure type -- APPLY') end
end
end
TheGlobalEnvironmentL = {Scheme.makeGlobalEnvironment}
fun {EvalPrintL Code}
Val = {EvalL Code TheGlobalEnvironmentL}
in
{Browse {Scheme.valueToString Val}}
Val
end
% fun lazy {Unless Condition UsualValue ExceptionalValue}
% if Condition
% then ExceptionalValue
% else UsualValue
% end
% end
_ = {EvalPrintL
tm_definition(
'Unless'
tm_lambda(
['Condition' 'UsualValue' 'ExceptionalValue']
tm_if(
tm_symbol('Condition')
tm_symbol('UsualValue')
tm_symbol('ExceptionalValue'))))}
% fun {Test} {Unless 1==1 true {Browse "whoops\n"}} end
_ = {EvalPrintL tm_application(tm_symbol('Unless')
[
tm_bool(true)
tm_bool(true)
tm_begin([tm_application(tm_symbol('Display') [tm_string('whoops\n')]) tm_bool(false)])
])}
% fun {Try A B}
% if A == 0 then 1 else B end
% end
_ = {EvalPrintL
tm_definition(
'Try'
tm_lambda(
['A' 'B']
tm_if(
tm_application(tm_symbol('=') [tm_symbol('A') tm_int(0)])
tm_symbol('A')
tm_symbol('B'))))}
% {Try 0 (1 div 0)}
_ = {EvalPrintL tm_application(tm_symbol('Try')
[
tm_int(0)
tm_application(tm_symbol('/') [tm_int(1) tm_int(0)])
])}
% Exercise 4.27
% Count = {NewCell 0}
_ = {EvalPrintL tm_definition('Count' tm_int(0))}
% fun {Id X}
% Count := @Count + 1
% X
% end
_ = {EvalPrintL
tm_definition(
'Id'
tm_lambda(
['X']
tm_begin(
[
tm_assignment('Count' tm_application(tm_symbol('+') [tm_symbol('Count') tm_int(1)]))
tm_symbol('X')
])))}
% W = {Id {Id 10}}
_ = {EvalPrintL
tm_definition(
'W'
tm_application(tm_symbol('Id') [tm_application(tm_symbol('Id') [tm_int(10)])]))}
% @Count
_ = {EvalPrintL tm_symbol('Count')}
% W
_ = {EvalPrintL tm_symbol('W')}
% @Count
_ = {EvalPrintL tm_symbol('Count')}
% Exercise 4.29
% fun {Square X} X * X end
_ = {EvalPrintL tm_definition('Square' tm_lambda(['X'] tm_application(tm_symbol('*') [tm_symbol('X') tm_symbol('X')])))}
% {Square {Id 10}}
_ = {EvalPrintL tm_application(tm_symbol('Id') [tm_int(10)])}
% @Count;
_ = {EvalPrintL tm_symbol('Count')}
% Exercise 4.30
% PART A
proc {ForEach Proc L}
case L
of nil then skip
[] H|T then
{Proc H}
{ForEach Proc T}
end
end
{ForEach proc {$ X} {Browse X} end [57 321 88]}
% PART B
fun {P1 X} X := @X|[2] @X end
fun {P2 X}
fun {P E} {E X} end
in
{P fun {$ X} X := @X|[2] @X end}
end
_ = {P1 {NewCell 1}}
_ = {P2 {NewCell 1}}
% 4.2.3 - Variations on a Scheme -- Lazy Evaluation - Streams as Lazy Lists
fun {CONS X Y}
fun {$ M} {M X Y} end
end
fun {CAR Z}
{Z fun {$ P Q} P end}
end
fun {CDR Z}
{Z fun {$ P Q} Q end}
end
fun lazy {ListRef L N}
case L#N
of (H|T)#0 then H
[] (H|T)#_ then {ListRef T N-1}
end
end
fun lazy {Map_ L Proc}
case L
of nil then nil
[] H|T then {Proc H} | {Map_ T Proc}
end
end
fun lazy {ScaleList Items Factor}
{Map Items fun {$ X} X * Factor end}
end
fun lazy {AddLists List1 List2}
case List1#List2
of nil#_ then List2
[] _#nil then List1
[] (H1|T1)#(H2|T2) then (H1+H2) | {AddLists T1 T2}
end
end
fun lazy {OnesGen} 1 | {OnesGen} end
Ones = {OnesGen}
fun lazy {IntegersGen} 1 | {AddLists Ones {IntegersGen}} end
Integers = {IntegersGen}
/*
;: (list-ref integers 17)
(define (integral integrand initial-value dt)
(define int
(cons initial-value
(add-lists (scale-list integrand dt)
int)))
int)
(define (solve f y0 dt)
(define y (integral dy y0 dt))
(define dy (map f y))
y)
;: (list-ref (solve (lambda (x) x) 1 .001) 1000)
;; Exercise 4.33
;: (car '(a b c))
*/
% Solve From CTM Chapter 9
% Lazy problem solving (Solve)
% This is the Solve operation, which returns a lazy list of solutions
% to a relational program. The list is ordered according to a
% depth-first traversal. Solve is written using the computation space
% operations of the Space module.
fun {Solve Script}
{SolStep {Space.new Script} nil}
end
fun {SolStep S Rest}
case {Space.ask S}
of failed then Rest
[] succeeded then {Space.merge S}|Rest
[] alternatives(N) then
{SolLoop S 1 N Rest}
end
end
fun lazy {SolLoop S I N Rest}
if I>N then Rest
elseif I==N then
{Space.commit S I}
{SolStep S Rest}
else Right C in
Right={SolLoop S I+1 N Rest}
C={Space.clone S}
{Space.commit C I}
{SolStep C Right}
end
end
fun {SolveOne F}
L = {Solve F}
in
if L==nil then nil else [L.1] end
end
fun {SolveAll F}
L = {Solve F}
proc {TouchAll L}
if L==nil then skip else {TouchAll L.2} end
end
in
{TouchAll L}
L
end
fun {SolveN N F}
L = {Solve F}
in
{List.take L N}
end
% 4.3 - Variations on a Scheme -- Nondeterministic Computing
fun {HasNoDivisors N C}
case C
of 1 then true
else
if N mod C == 0
then false
else {HasNoDivisors N C-1}
end
end
end
fun {IsPrime N}
{HasNoDivisors N N-1}
end
fun {AnElementOf L}
choice
L = nil
fail
[] H T in
L = H|T
H
[] H T in
L = H|T
{AnElementOf T}
end
end
fun {PrimeSumPair List1 List2}
X = {AnElementOf List1}
Y = {AnElementOf List2}
in
{IsPrime X+Y} = true
X#Y
end
{Browse {SolveAll fun {$} {PrimeSumPair [1 3 5 8] [20 35 110]} end}}
% 4.3.1 - Variations on a Scheme -- Nondeterministic Computing - Amb and Search
{Browse {SolveAll fun {$} choice 1 [] 2 [] 3 end # choice a [] b end end}}
proc {Require P}
P = true
end
fun {AnIntegerStartingFrom N}
choice
N
[] {AnIntegerStartingFrom N+1}
end
end
{Browse {SolveAll fun {$} {PrimeSumPair [19 27 30] [11 36 58]} end}}
% Exercise 4.35
fun {AnIntegerBetween Low High}
choice
Low
[] Low < High = true
{AnIntegerBetween Low+1 High}
end
end
fun {APythagoreanTripleBetween Low High}
I = {AnIntegerBetween Low High}
J = {AnIntegerBetween Low High}
K = {AnIntegerBetween Low High}
in
I*I + J*J = K*K
I#J#K
end
{Browse {SolveAll fun {$} {APythagoreanTripleBetween 1 10} end}}
% Exercise 4.37
% fun {APythagoreanTripleBetween Low High}
% I = {AnIntegerBetween Low High}
% Hsq = High*High
% J = {AnIntegerBetween I High}
% Ksq = I*I + J*J
% K
% in
% Hsq >= Ksq = true
% K = {Sqrt {IntToFloat Ksq}}
% K*K = {IntToFloat Ksq}
% I#J#K
% end
% {Browse {SolveAll fun {$} {APythagoreanTripleBetween 1 10} end}}
% 4.3.2 - Variations on a Scheme -- Nondeterministic Computing - Examples of Nondeterministic Programs
% Logic Puzzles
fun {IsDistinct Items}
case Items
of nil then true
[] H|nil then true
[] H|T then
if {Member H T}
then false
else {IsDistinct T}
end
end
end
fun {MultipleDwelling}
Baker = choice 1 [] 2 [] 3 [] 4 [] 5 end
Cooper = choice 1 [] 2 [] 3 [] 4 [] 5 end
Fletcher = choice 1 [] 2 [] 3 [] 4 [] 5 end
Miller = choice 1 [] 2 [] 3 [] 4 [] 5 end
Smith = choice 1 [] 2 [] 3 [] 4 [] 5 end
in
{Require {IsDistinct? [Baker Cooper Fletcher Miller Smith]}}
{Require Baker \= 5}
{Require Cooper \= 1}
{Require Fletcher \= 5}
{Require Fletcher \= 1}
{Require Miller > Cooper}
{Require {Abs Smith-Fletcher} \= 1}
{Require {Abs Fletcher-Cooper} \= 1}
[
baker#Baker
cooper#Cooper
fletcher#Fletcher
miller#Miller
smith#Smith
]
end
{Browse {SolveAll MultipleDwelling}}
% Parsing natural language
Nouns = [noun student professor cat 'class']
Verbs = [verb studies lectures eats sleeps]
Articles = [article the a]
local
fun {ParseSentence}
sentence({ParseNounPhrase} {ParseWord Verbs})
end
fun {ParseNounPhrase}
noun_phrase({ParseWord Articles} {ParseWord Nouns})
end
Unparsed = {NewCell nil}
fun {ParseWord WordList}
{Require Unparsed \= nil}
{Require {Member @Unparsed.1 WordList.2}}
local FoundWord TypeWord in
FoundWord = @Unparsed.1
Unparsed := @Unparsed.2
TypeWord = WordList.1
TypeWord(FoundWord)
end
end
fun {Parse Input}
Unparsed := Input
Sent = {ParseSentence}
in
{Require @Unparsed == nil}
Sent
end
in
{Browse {Parse [the cat eats]}}
end
% Note: Globals not allowed in Oz spaces, so we have to pass unparsed to the functions
Prepositions = [prep 'for' to 'in' by with]
fun {ParseSentence Unparsed}
sentence({ParseNounPhrase Unparsed} {ParseVerbPhrase Unparsed})
end
fun {ParsePrepositionalPhrase Unparsed}
prep_phrase({ParseWord Unparsed Prepositions} {ParseNounPhrase Unparsed})
end
fun {ParseSimpleNounPhrase Unparsed}
simple_noun_phrase({ParseWord Unparsed Articles} {ParseWord Unparsed Nouns})
end
fun {ParseNounPhrase Unparsed}
fun {MaybeExtend NounPhrase}
choice
NounPhrase
[] {MaybeExtend noun_phrase(NounPhrase {ParsePrepositionalPhrase Unparsed})}
end
end
in
{MaybeExtend {ParseSimpleNounPhrase Unparsed}}
end
fun {ParseVerbPhrase Unparsed}
fun {MaybeExtend VerbPhrase}
choice
VerbPhrase
[] {MaybeExtend verb_phrase({ParsePrepositionalPhrase Unparsed})}
end
end
in
{MaybeExtend {ParseWord Unparsed Verbs}}
end
fun {ParseWord Unparsed WordList}
{Require @Unparsed \= nil}
{Require {Member @Unparsed.1 WordList.2}}
local FoundWord TypeWord in
FoundWord = @Unparsed.1
Unparsed := @Unparsed.2
TypeWord = WordList.1
TypeWord(FoundWord)
end
end
fun {Parse Input}
Unparsed = {NewCell Input}
Sent = {ParseSentence Unparsed}
in
{Require @Unparsed == nil}
Sent
end
{Browse {SolveAll fun {$} {Parse [the student with the cat sleeps 'in' the 'class']} end}}
{Browse {SolveAll fun {$} {Parse [the professor lectures to the student with the cat]} end}}
% Exercise 4.47
fun {ParseVerbPhrase_ Unparsed}
choice
{ParseWord Unparsed Verbs}
[] verb_phrase({ParseVerbPhrase_ Unparsed} {ParsePrepositionalPhrase Unparsed})
end
end
% 4.3.3 - Variations on a Scheme -- Nondeterministic Computing - Implementing the Amb Evaluator
fun {AmbEval Exp Env Succeed Fail}
{{AmbAnalyze Exp} Env Succeed Fail}
end
fun {AmbAnalyze Exp}
case Exp
of tm_unit then fun {$ Env Succeed Fail} {Succeed val_unit Fail} end
[] tm_bool(Exp) then fun {$ Env Succeed Fail} {Succeed val_bool(Exp) Fail} end
[] tm_int(Exp) then fun {$ Env Succeed Fail} {Succeed val_int(Exp) Fail} end
[] tm_real(Exp) then fun {$ Env Succeed Fail} {Succeed val_real(Exp) Fail} end
[] tm_string(Exp) then fun {$ Env Succeed Fail} {Succeed val_string(Exp) Fail} end
[] tm_quoted(Exp) then fun {$ Env Succeed Fail} {Succeed val_quoted(Exp) Fail} end
[] tm_if(Exp E1 E2) then local
Pproc = {AmbAnalyze Exp}
Cproc = {AmbAnalyze E1}
Aproc = {AmbAnalyze E2}
in
fun {$ Env Succeed Fail}
{Pproc
Env
fun {$ PredValue Fail}
if PredValue == val_bool(true)
then {Cproc Env Succeed Fail}
else {Aproc Env Succeed Fail}
end
end
Fail}
end
end
[] tm_cond(Exp) then {AmbAnalyze {Cond2If Exp}}
[] tm_begin(Exp) then local
Aprocs = {Map Exp AmbAnalyze}
fun {Sequentially Proc1 Proc2}
fun {$ Env Succeed Fail}
{Proc1
Env
fun {$ AValue Fail} {Proc2 Env Succeed Fail} end
Fail}
end
end
fun {Loop FirstProc RestProcs}
case RestProcs
of H|T then {Loop {Sequentially FirstProc H} T}
[] nil then FirstProc
end
end
in
case Aprocs
of H|T then {Loop H T}
[] nil then raise evaluator('Empty sequence -- ANALYZE') end
end
end
[] tm_symbol(Exp) then fun {$ Env Succeed Fail} {Succeed {LookupVariableValue Exp Env} Fail} end
[] tm_definition(E1 E2) then local
Vproc = {AmbAnalyze E2}
in
fun {$ Env Succeed Fail}
{Vproc Env fun {$ Val Fail} {Succeed {DefineVariable E1 Val Env} Fail} end Fail}
end
end
[] tm_assignment(E1 E2) then local
Vproc = {AmbAnalyze E2}
in
fun {$ Env Succeed Fail}
{Vproc
Env
fun {$ Val Fail}
OldValue = {LookupVariableValue E1 Env}
in
_ = {SetVariableValue E1 Val Env}
{Succeed OldValue fun {$} {Succeed {SetVariableValue E1 OldValue Env} Fail} end}
end
Fail}
end
end
[] tm_lambda(Parms Body) then local
Aproc = {AmbAnalyze Body}
in
fun {$ Env Succeed Fail} {Succeed val_closure(Parms Aproc Env) Fail} end
end
[] tm_application(F Args) then local
Fproc = {AmbAnalyze F}
Aprocs = {Map Args AmbAnalyze}
fun {GetArgs Aprocs Env Succeed Fail}
case Aprocs
of H|T then
{H
Env
fun {$ Arg Fail}
{GetArgs T Env fun {$ Args Fail} {Succeed Arg|Args Fail} end Fail}
end
Fail}
[] nil then {Succeed nil Fail}
end
end
in
fun {$ Env Succeed Fail}
{Fproc
Env
fun {$ Proc Fail}
{GetArgs
Aprocs
Env
fun {$ Args Fail} {AmbExecuteApplication Proc Args Succeed Fail} end
Fail}
end
Fail}
end
end
[] tm_amb(Exp) then local
Cprocs = {Map Exp AmbAnalyze}
in
fun {$ Env Succeed Fail}
fun {TryNext Choices}
case Choices
of H|T then {H Env Succeed fun {$} {TryNext T} end}
[] nil then {Fail}
end
end
in
{TryNext Cprocs}
end
end
end
end
fun {AmbExecuteApplication F Args Succeed Fail}
case F
of val_primitive(Sym F) then {Succeed {F Args} Fail}
[] val_closure(Parameters Body Env) then
if {Length Parameters} \= {Length Args}
then
if {Length Parameters} < {Length Args}
then raise evaluator('Too many arguments supplied') end
else raise evaluator('Too few arguments supplied') end
end
else
local
% create the closure environment
NewEnv = {NewDictionary}|Env
% pair up the parameters and arguments into a list
Pairs = {ListPairZip Parameters Args}
in
% push the parameters/arguments into the closure environment
_ = {Map Pairs fun {$ X#Y} {DefineVariable X Y NewEnv} end}
% return the evaluated body of the closure
{Body NewEnv Succeed Fail}
end
end
else raise evaluator('Unknown procedure type -- APPLY') end
end
end
% repeated from above
AmbGlobalEnvironment = {Scheme.makeGlobalEnvironment}
fun {AmbEvalPrint Code}
fun {Fsucc V F} V|{F} end
fun {Ffail} nil end
Val = {AmbEval Code AmbGlobalEnvironment Fsucc Ffail}
in
{Browse Val}
Val
end
% 4.4.1 - Logic Programming - Deductive Information Retrieval
% A sample data base
proc {Address ?Employee ?City ?Street ?Num}
choice
Employee = 'Bitdiddle Ben' City = 'Slumerville' Street='Ridge Road' Num='10'
[] Employee = 'Hacker Alyssa P' City = 'Cambridge' Street='Mass Ave' Num='78'
[] Employee = 'Fect Cy D' City = 'Cambridge' Street='Ames Street' Num='3'
[] Employee = 'Tweakit Lem E' City = 'Boston' Street='Bay State Road' Num='22'
[] Employee = 'Reasoner Louis' City = 'Slumerville' Street='Pine Tree Road' Num='80'
[] Employee = 'Warbucks Oliver' City = 'Swellesley' Street='Top Heap Road'
[] Employee = 'Scooge Eben' City = 'Weston' Street='Shady Lane' Num='10'
[] Employee = 'Cratchet Robert' City = 'Allston' Street='N Harvard Street' Num='16'
[] Employee = 'Aull DeWitt' City = 'Slumerville' Street='Union Square' Num='5'
end
end
proc {Job ?Employee ?Title}
choice
Employee = 'Bitdiddle Ben' Title = 'computer wizard'
[] Employee = 'Hacker Alyssa P' Title = 'computer programmer'
[] Employee = 'Fect Cy D' Title = 'computer programmer'
[] Employee = 'Tweakit Lem E' Title = 'computer technician'
[] Employee = 'Reasoner Louis' Title = 'computer programmer trainee'
[] Employee = 'Warbucks Oliver' Title = 'administration big wheel'
[] Employee = 'Scooge Eben' Title = 'acounting chief accountant'
[] Employee = 'Cratchet Robert' Title = 'accounting scrivener'
[] Employee = 'Aull DeWitt' Title = 'administration secretary'
end
end
proc {Salary ?Employee ?Amount}
choice
Employee = 'Bitdiddle Ben' Amount = 60000
[] Employee = 'Hacker Alyssa P' Amount = 40000
[] Employee = 'Fect Cy D' Amount = 35000
[] Employee = 'Tweakit Lem E' Amount = 25000
[] Employee = 'Reasoner Louis' Amount = 30000
[] Employee = 'Warbucks Oliver' Amount = 150000
[] Employee = 'Scooge Eben' Amount = 75000
[] Employee = 'Cratchet Robert' Amount = 18000
[] Employee = 'Aull DeWitt' Amount = 25000
end
end
proc {Supervisor ?Employee ?Boss}
choice
Employee = 'Bitdiddle Ben' Boss = 'Warbucks Oliver'
[] Employee = 'Hacker Alyssa P' Boss = 'Bitdiddle Ben'
[] Employee = 'Fect Cy D' Boss = 'Bitdiddle Ben'
[] Employee = 'Tweakit Lem E' Boss = 'Bitdiddle Ben'
[] Employee = 'Reasoner Louis' Boss = 'Hacker Alyssa P'
[] Employee = 'Scooge Eben' Boss = 'Warbucks Oliver'
[] Employee = 'Cratchet Robert' Boss = 'Scooge Eben'
[] Employee = 'Aull DeWitt' Boss = 'Warbucks Oliver'
end
end
proc {CanDoJob ?Expert ?Title}
choice
Expert = Title
[] Expert = 'computer wizard' Title = 'computer programmer'
[] Expert = 'computer wizard' Title = 'computer technician'
[] Expert = 'computer wizard' Title = 'computer programmer trainee'
[] Expert = 'computer programmer' Title = 'computer programmer trainee'
[] Expert = 'administration secretary' Title = 'administration big wheel'
end
end
% Simple queries
% computer programmers
{Browse
{SolveAll
fun {$}
Employee
Title='computer programmer'
in
{Job Employee Title}
Employee#Title
end}}
% all addresses
{Browse
{SolveAll
fun {$}
Employee
City
Street
Num
in
{Address Employee City Street Num}
Employee#City#Street#Num
end}}
% all that supervise themselves
{Browse
{SolveAll
fun {$}
Employee
in
{Supervisor Employee Employee}
Employee#Employee
end}}
% all that have 'computer' as first word in their title
{Browse
{SolveAll
fun {$}
Employee
Title
in
{Job Employee Title}
{AtomToString Title} = {Append {AtomToString 'computer'} _}
Employee#Title
end}}
% Compound queries
{Browse
{SolveAll
fun {$}
Employee
Title='computer programmer'
City
Street
Num
in
{Job Employee Title}
{Address Employee City Street Num}
Employee#Title#City#Street#Num
end}}
% Employees that are supervised by Bitdiddle or Hacker
{Browse
{SolveAll
fun {$}
Employee
Boss
in
choice
Boss = 'Bitdiddle Ben'
[] Boss = 'Hacker Alyssa P'
end
{Supervisor Employee Boss}
Employee#Employee#Boss
end}}
% computer programmers supervised by Bitdiddle
{Browse
{SolveAll
fun {$}
Employee
Boss = 'Bitdiddle Ben'
Title
in
{Supervisor Employee Boss}
{Job Employee Title}
true = Title \= 'computer programmer'
Employee#Boss#Title
end}}
% employees that make salary over 30000
{Browse
{SolveAll
fun {$}
Employee
Amount
in
{Salary Employee Amount}
true = Amount > 30000
Employee#Amount
end}}
% Rules
proc {LivesNear ?Person1 ?Person2}
City
in
{Address Person1 City _ _}
{Address Person2 City _ _}
true = Person1 \= Person2
end
proc {Same ?X ?Y}
true = X == Y
end
% note: this can return same employee multiple times
proc {Wheel ?Employee}
MiddleManager
in
{Supervisor MiddleManager Employee}
{Supervisor _ MiddleManager}
end
% lives near Bitdiddle
{Browse
{SolveAll
fun {$}
Employee
in
{LivesNear Employee 'Bitdiddle Ben'}
Employee
end}}
% computer programmers that live near Bitdiddle
{Browse
{SolveAll
fun {$}
Employee
Title
in
{Job Employee Title}
Title = 'computer programmer'
{LivesNear Employee 'Bitdiddle Ben'}
Employee
end}}
proc {OutrankedBy ?StaffPerson ?Boss}
choice
{Supervisor StaffPerson Boss}
[] MiddleManager in
{Supervisor StaffPerson MiddleManager}
{OutrankedBy MiddleManager Boss}
end
end
% Logic as programs
% Note: Lifted from CTM 9.3.3
proc {AppendL ?A ?B ?C}
choice
A = nil
B = C
[] As Cs X in
A = X|As
C = X|Cs
{AppendL As B Cs}
end
end
{Browse
{SolveAll
fun {$}
Z
in
{AppendL [a b] [c d] Z}
Z
end}}
{Browse
{SolveAll
fun {$}
Y
in
{AppendL [a b] Y [a b c d]}
Y
end}}
{Browse
{SolveAll
fun {$}
X
Y
in
{AppendL X Y [a b c d]}
X#Y
end}}
% 4.4.2 - Logic Programming - How the Query System Works
{Browse
{SolveAll
fun {$}
Employee
in
{Job Employee 'computer programmer'}
Employee
end}}
{Browse
{SolveAll
fun {$}
Expert
Employee
in
{CanDoJob Expert 'computer programmer trainee'}
{Job Employee Expert}
Employee#Expert
end}}
{Browse
{SolveAll
fun {$}
Boss
Employee
Title
in
{Supervisor Employee Boss}
{Job Employee Title}
true = Title \= 'computer programmer'
Boss#Employee#Title
end}}
local X Y Z in
X = [a Y c]
X = [a b Z]
{Browse X}
end
{Browse
{SolveAll
fun {$}
Employee
in
{LivesNear Employee 'Hacker Alyssa P'}
Employee
end}}
% 4.4.3 - Logic Programming - Is Logic Programming Mathematical Logic?
{Browse
{SolveAll
fun {$}
Employee
Boss
in
{Job Employee 'computer programmer'}
{Supervisor Employee Boss}
Employee#Boss
end}}
{Browse
{SolveAll
fun {$}
Employee
Boss
in
{Supervisor Employee Boss}
{Job Employee 'computer programmer'}
Employee#Boss
end}}
proc {Married ?X ?Y}
choice
X = 'Minnie' Y = 'Mickie'
end
end
proc {MarriedTo ?X ?Y}
choice
{Married X Y}
[] {Married Y X}
end
end
{Browse
{SolveAll
fun {$}
Who
in
{MarriedTo 'Mickie' Who}
Who
end}}
{Browse
{SolveAll
fun {$}
Boss
Employee
Title
in
{Supervisor Employee Boss}
{Job Employee Title}
true = Title \= 'computer programmer'
Boss#Employee#Title
end}}
{Browse
{SolveAll
fun {$}
Boss
Employee
Title
in
{Job Employee Title}
true = Title \= 'computer programmer'
{Supervisor Employee Boss}
Boss#Employee#Title
end}}
% Exercise 4.64
/* infinite loop
proc {OutrankedBy_ ?StaffPerson ?Boss}
choice
{Supervisor StaffPerson Boss}
[] MiddleManager in
{OutrankedBy_ MiddleManager Boss}
{Supervisor StaffPerson MiddleManager}
end
end
{Browse
{SolveAll
fun {$}
Boss
in
{OutrankedBy_ 'Bitdiddle Ben' Boss}
Boss
end}}
*/
% 4.4.4.1 - Logic Programming - Implementing the Query System - The Driver Loop and Instantiation
% ;;; **SEE ALSO** ch4-query.scm (loadable/runnable query system)
%
% (define input-prompt ";;; Query input:")
% (define output-prompt ";;; Query results:")
%
% (define (query-driver-loop)
% (prompt-for-input input-prompt)
% (let ((q (QuerySyntaxProcess (read))))
% (cond ((IsAssertionToBeAdded q)
% (add-rule-or-assertion! (AddAssertionBody q))
% (newline)
% (display "Assertion added to data base.")
% (query-driver-loop))
% (else
% (newline)
% (display output-prompt)
% ;; [extra newline at end] (announce-output output-prompt)
% (display-stream
% (stream-map
% (lambda (frame)
% (instantiate q
% frame
% (lambda (v f)
% (ContractQuestionMark v))))
% (qeval q (SingletonStream '()))))
% (query-driver-loop)))))
%
% (define (instantiate exp frame unbound-var-handler)
% (define (copy exp)
% (cond ((IsVar exp)
% (let ((binding (BindingInFrame exp frame)))
% (if binding
% (copy (BindingValue binding))
% (unbound-var-handler exp frame))))
% ((pair? exp)
% (cons (copy (car exp)) (copy (cdr exp))))
% (else exp)))
% (copy exp))
% 4.4.4.2 - Logic Programming - Implementing the Query System - The Evaluator
% (define (qeval query frame-stream)
% (let ((qproc (get (type query) 'qeval)))
% (if qproc
% (qproc (contents query) frame-stream)
% (simple-query query frame-stream))))
%
% ;;;Simple queries
%
% (define (simple-query query-pattern frame-stream)
% (StreamFlatmap
% (lambda (frame)
% (StreamAppendDelayed
% (find-assertions query-pattern frame)
% (delay (apply-rules query-pattern frame))))
% frame-stream))
%
% ;;;Compound queries
%
% (define (conjoin conjuncts frame-stream)
% (if (IsEmptyConjunction conjuncts)
% frame-stream
% (conjoin (RestConjuncts conjuncts)
% (qeval (FirstConjunct conjuncts)
% frame-stream))))
%
% (put 'and 'qeval conjoin)
%
%
% (define (disjoin disjuncts frame-stream)
% (if (IsEmptyDisjunction disjuncts)
% the-empty-stream
% (InterleaveDelayed
% (qeval (FirstDisjunct disjuncts) frame-stream)
% (delay (disjoin (RestDisjuncts disjuncts)
% frame-stream)))))
%
% (put 'or 'qeval disjoin)
%
% ;;;Filters
%
% (define (negate operands frame-stream)
% (StreamFlatmap
% (lambda (frame)
% (if (stream-null? (qeval (NegatedQuery operands)
% (SingletonStream frame)))
% (SingletonStream frame)
% the-empty-stream))
% frame-stream))
%
% (put 'not 'qeval negate)
%
% (define (lisp-value call frame-stream)
% (StreamFlatmap
% (lambda (frame)
% (if (execute
% (instantiate
% call
% frame
% (lambda (v f)
% (error "Unknown pat var -- LISP-VALUE" v))))
% (SingletonStream frame)
% the-empty-stream))
% frame-stream))
%
% (put 'lisp-value 'qeval lisp-value)
%
% (define (execute exp)
% (apply (eval (Predicate exp) user-initial-environment)
% (Args exp)))
%
% (define (always-true ignore frame-stream) frame-stream)
%
% (put 'always-true 'qeval always-true)
% 4.4.4.3 - Logic Programming - Implementing the Query System - Finding Assertions by Pattern Matching
% (define (find-assertions pattern frame)
% (StreamFlatmap (lambda (datum)
% (check-an-assertion datum pattern frame))
% (fetch-assertions pattern frame)))
%
% (define (check-an-assertion assertion query-pat query-frame)
% (let ((match-result
% (pattern-match query-pat assertion query-frame)))
% (if (eq? match-result 'failed)
% the-empty-stream
% (SingletonStream match-result))))
%
% (define (pattern-match pat dat frame)
% (cond ((eq? frame 'failed) 'failed)
% ((equal? pat dat) frame)
% ((IsVar pat) (extend-if-consistent pat dat frame))
% ((and (pair? pat) (pair? dat))
% (pattern-match (cdr pat)
% (cdr dat)
% (pattern-match (car pat)
% (car dat)
% frame)))
% (else 'failed)))
%
% (define (extend-if-consistent var dat frame)
% (let ((binding (BindingInFrame var frame)))
% (if binding
% (pattern-match (BindingValue binding) dat frame)
% (Extend var dat frame))))
% 4.4.4.4 - Logic Programming - Implementing the Query System - Rules and Unification
% (define (apply-rules pattern frame)
% (StreamFlatmap (lambda (rule)
% (apply-a-rule rule pattern frame))
% (fetch-rules pattern frame)))
%
% (define (apply-a-rule rule query-pattern query-frame)
% (let ((clean-rule (rename-variables-in rule)))
% (let ((unify-result
% (unify-match query-pattern
% (conclusion clean-rule)
% query-frame)))
% (if (eq? unify-result 'failed)
% the-empty-stream
% (qeval (RuleBody clean-rule)
% (SingletonStream unify-result))))))
%
% (define (rename-variables-in rule)
% (let ((rule-application-id (NewRuleApplicationId)))
% (define (tree-walk exp)
% (cond ((IsVar exp)
% (MakeNewVariable exp rule-application-id))
% ((pair? exp)
% (cons (tree-walk (car exp))
% (tree-walk (cdr exp))))
% (else exp)))
% (tree-walk rule)))
%
% (define (unify-match p1 p2 frame)
% (cond ((eq? frame 'failed) 'failed)
% ((equal? p1 p2) frame)
% ((IsVar p1) (extend-if-possible p1 p2 frame))
% ((IsVar p2) (extend-if-possible p2 p1 frame)) ; {\em ; ***}
% ((and (pair? p1) (pair? p2))
% (unify-match (cdr p1)
% (cdr p2)
% (unify-match (car p1)
% (car p2)
% frame)))
% (else 'failed)))
%
% (define (extend-if-possible var val frame)
% (let ((binding (BindingInFrame var frame)))
% (cond (binding
% (unify-match
% (BindingValue binding) val frame))
% ((IsVar val) ; {\em ; ***}
% (let ((binding (BindingInFrame val frame)))
% (if binding
% (unify-match
% var (BindingValue binding) frame)
% (Extend var val frame))))
% ((depends-on? val var frame) ; {\em ; ***}
% 'failed)
% (else (Extend var val frame)))))
%
% (define (depends-on? exp var frame)
% (define (tree-walk e)
% (cond ((IsVar e)
% (if (equal? var e)
% true
% (let ((b (BindingInFrame e frame)))
% (if b
% (tree-walk (BindingValue b))
% false))))
% ((pair? e)
% (or (tree-walk (car e))
% (tree-walk (cdr e))))
% (else false)))
% (tree-walk exp))
% 4.4.4.5 - Logic Programming - Implementing the Query System - Maintaining the Data Base
proc {PutX Key Tag Stream} skip end % CMR
fun {GetX Key1 Key2} Key1 end % CMR
THE_ASSERTIONS = nil
% (define (fetch-assertions pattern frame)
% (if (UseIndex pattern)
% (get-indexed-assertions pattern)
% (get-all-assertions)))
%
% (define (get-all-assertions) THE-ASSERTIONS)
%
% (define (get-indexed-assertions pattern)
% (GetStream (IndexKeyOf pattern) 'assertion-stream))
fun {GetStream Key1 Key2}
S = {GetX Key1 Key2}
in
if S \= not_found
then S
else nil
end
end
THE_RULES = nil
% (define (fetch-rules pattern frame)
% (if (UseIndex pattern)
% (get-indexed-rules pattern)
% (get-all-rules)))
%
% (define (get-all-rules) THE-RULES)
%
% (define (get-indexed-rules pattern)
% (stream-append
% (GetStream (IndexKeyOf pattern) 'rule-stream)
% (GetStream '? 'rule-stream)))
%
% (define (add-rule-or-assertion! assertion)
% (if (IsRule assertion)
% (add-rule! assertion)
% (add-assertion! assertion)))
%
% (define (add-assertion! assertion)
% (store-assertion-in-index assertion)
% (let ((old-assertions THE-ASSERTIONS))
% (set! THE-ASSERTIONS
% (cons-stream assertion old-assertions))
% 'ok))
%
% (define (add-rule! rule)
% (StoreRuleInIndex rule)
% (let ((old-rules THE-RULES))
% (set! THE-RULES (cons-stream rule old-rules))
% 'ok))
%
% (define (store-assertion-in-index assertion)
% (if (IsIndexable assertion)
% (let ((key (IndexKeyOf assertion)))
% (let ((current-assertion-stream
% (GetStream key 'assertion-stream)))
% (put key
% 'assertion-stream
% (cons-stream assertion
% current-assertion-stream))))))
proc {StoreRuleInIndex Rule}
Pattern = {Conclusion Rule}
in
if {IsIndexable Pattern}
then
local
Key = {IndexKeyOf pattern}
CurrentRuleStream = {GetStream Key 'rule-stream'}
in
{PutX Key 'rule-stream' Rule|CurrentRuleStream}
end
else skip
end
end
fun {IsIndexable Pat}
{Or {IsConstantSymbol Pat.1} {IsVar Pat.1}}
end
fun {IndexKeyOf Pat}
Key = Pat.1
in
if {IsVar Key}
then '?'
else Key
end
end
fun {UseIndex Pat}
{IsConstantSymbol Pat.1}
end
% 4.4.4.6 - Logic Programming - Implementing the Query System - Stream operations
fun lazy {StreamAppendDelayed S1 DelayedS2}
case S1
of nil then DelayedS2
[] H|T then H | {StreamAppendDelayed T DelayedS2}
end
end
fun lazy {InterleaveDelayed S1 DelayedS2}
case S1
of nil then DelayedS2
[] H|T then H | {InterleaveDelayed DelayedS2 T}
end
end
fun {StreamFlatmap Proc S}
{FlattenStream {Map S Proc}}
end
fun lazy {FlattenStream Stream}
case Stream
of nil then nil
[] H|T then {InterleaveDelayed H {FlattenStream T}}
end
end
fun {SingletonStream X}
X | nil
end
% 4.4.4.7 - Logic Programming - Implementing the Query System - Query syntax procedures
fun {Type Exp}
case Exp
of H#T then H
else raise error('Unknown expression TYPE'#Exp) end
end
end
fun {Contents Exp}
case Exp
of H#T then T
else raise error('Unknown expression CONTENTS'#Exp) end
end
end
fun {IsAssertionToBeAdded Exp}
{Type Exp} == 'assert!'
end
fun {AddAssertionBody Exp}
{Contents Exp}.1
end
fun {IsEmptyConjunction Exps} Exps == nil end
fun {FirstConjunct Exps} Exps.1 end
fun {RestConjuncts Exps} Exps.2 end
fun {IsEmptyDisjunction Exps} Exps == nil end
fun {FirstDisjunct Exps} Exps.1 end
fun {RestDisjuncts Exps} Exps.2 end
fun {NegatedQuery Exps} Exps.1 end
fun {Predicate Exps} Exps.1 end
fun {Args Exps} Exps.2 end
fun {IsTaggedList Exp Tag}
case Exp
of H|T then H == tag
else false
end
end
fun {IsRule Statement}
{IsTaggedList Statement 'rule'}
end
fun {Conclusion Rule} Rule.2.1 end
fun {RuleBody Rule}
if Rule.2.2 == nil
then 'always-true'
else Rule.2.2.1
end
end
fun {QuerySyntaxProcess Exp}
{MapOverSymbols ExpandQuestionMark Exp}
end
fun {MapOverSymbols Proc Exp}
case Exp
of H|T then {MapOverSymbols Proc H} | {MapOverSymbols Proc T}
else
if {IsAtom Exp}
then {Proc Exp}
else Exp
end
end
end
fun {ExpandQuestionMark Symbol}
Chars = {AtomToString Symbol}
in
if {Char.toAtom Chars.1} == '?'
then '?' | {StringToAtom Chars.2}
else Symbol
end
end
fun {IsVar Exp}
{IsTaggedList Exp '?'}
end
fun {IsConstantSymbol Exp} {IsAtom Exp} end
RuleCounter = {NewCell 0}
fun {NewRuleApplicationId}
RuleCounter := @RuleCounter + 1
@RuleCounter
end
fun {MakeNewVariable Var RuleApplicationId}
'?' | (RuleApplicationId | Var.2)
end
fun {ContractQuestionMark Variable}
{StringToAtom
{Append
"?"
if {IsNumber Variable.2.1}
then
{Append
{Append {AtomToString Variable.2.2.1} "-"}
{IntToString Variable.2.1}}
else {AtomToString Variable.2.1}
end}}
end
% 4.4.4.8 - Logic Programming - Implementing the Query System - Frames and bindings
fun {MakeBinding Variable Value}
Variable#Value
end
fun {BindingVariable Binding}
case Binding
of Variable#_ then Variable
end
end
fun {BindingValue Binding}
case Binding
of _#Value then Value
end
end
fun {BindingInFrame Variable Frame}
case Frame
of H|T then
if {BindingVariable H} == Variable
then H
else {BindingInFrame Variable T}
end
end
end
fun {Extend Variable Value Frame}
{MakeBinding Variable Value}|Frame
end
% ;; Exercise 4.71
% (define (simple-query query-pattern frame-stream)
% (StreamFlatmap
% (lambda (frame)
% (stream-append (find-assertions query-pattern frame)
% (apply-rules query-pattern frame)))
% frame-stream))
%
% (define (disjoin disjuncts frame-stream)
% (if (IsEmptyDisjunction disjuncts)
% the-empty-stream
% (interleave
% (qeval (FirstDisjunct disjuncts) frame-stream)
% (disjoin (RestDisjuncts disjuncts) frame-stream))))
%
%
% ;; Exercise 4.73
% (define (FlattenStream stream)
% (if (stream-null? stream)
% the-empty-stream
% (interleave
% (stream-car stream)
% (FlattenStream (stream-cdr stream)))))
%
% ;; Exercise 4.74
% (define (simple-stream-flatmap proc s)
% (simple-flatten (stream-map proc s)))
% (define (simple-flatten stream)
% (stream-map ??FILL-THIS-IN??
% (stream-filter ??FILL-THIS-IN?? stream)))
%
% ;; Exercise 4.75
%
% (unique (job ?x (computer wizard)))
%
% (unique (job ?x (computer programmer)))
%
% (and (job ?x ?j) (unique (job ?anyone ?j)))
%
% (put 'unique 'qeval uniquely-asserted)
%
%
% ;; Exercise 4.79
%
% (define (square x)
% ( * x x))
%
% (define (sum-of-squares x y)
% (+ (square x) (square y)))
%
% (sum-of-squares 3 4)
|