APL/D Source Code:
────────────────────────────────────────────────────────────────────────────────
min←{ ⍝ Min Compiler / Interpreter.
stream←{ ⍝ Streamed input.
src rem←1 input ⍵ ⍝ Next line and remainder.
')'=⊃src:envt←⍉↑⍺ ⍝ Quit returning (shy) environment.
'~'=⊃src:⍺ remv src rem ⍝ Remove definition.
exp←parse chk src~';' ⍝ Parse tree.
'='=⊃exp:(⍺ defn exp)∇ rem ⍝ Definition.
⎕←format{ ⍝ Show reduced expression.
';'∊src:trace ⍵ ⍝ Traced reduction.
reduce ⍵ ⍝ Quiet reduction.
}⍺ compile exp ⍝ Compiled expression.
⍺ ∇ rem ⍝ Stream remainder.
}
input←{ ⍝ Input from buffer, then keyboard.
2=⍴⍴⍵:⍺ ∇↓⍵ ⍝ Char matrix script.
0=⍴,⍵:0 ∇,⊂⍞⊣⍞←4↑'' ⍝ Prompt and return input.
hd tl←(⊃⍵)(1↓⍵) ⍝ First and remaining lines.
⎕←↑⍺/↓hd ⍝ Display if input from buffer.
mask←∧\hd≠'/' ⍝ Mask chars to left of comment.
line←(mask/hd)~' ' ⍝ Blanks and comments removed.
''≡line~';':⍺ ∇ tl ⍝ Ignore blank line.
line tl ⍝ Return first line and rest.
} ⍝ :: echo → [line] → line [line]
alph←{ ⍝ Min alphabet:
a←'abcdefghijklmnopqrstuvwxyz' ⍝ Name a-z,
n←'0123456789' ⍝ Number 0-9,
s←'+()=;' ⍝ Syntax,
f←⊃combo'tab' ⍝ Function names.
a,n,s,⍵/f,'?' ⍝ Alpha, numb, syntax, [functions].
}1 ⍝ Accept raw functions.
chk←{∧/⍵∊alph:⍵ ⋄ '?'} ⍝ Check source chars.
remv←{ ⍝ Remove definition.
tags←⊃⍺ ⍝ Prevailing definitions.
cmd rem←⍵
mask←~tags∊cmd ⍝ Defs to keep.
keep←mask∘/¨⍺
⎕←∊2↑¨⊃keep ⍝ Display remaining definitions.
keep stream rem ⍝ Stream with new environment.
}
⍺←0 3⍴'' ⋄ (↓⍉⍺)stream ⍵ ⍝ Eval source stream ⍵ with envt ⍺.
}
────────────────────────────────────────────────────────────────────────────────
parse←{ ⍝ Lambda expression :: [char] → \exp
exp rem←''{ ⍝ Parse tree and remainder.
0=⍴⍵:⍺ ⍵ ⍝ Null: tree and remainder.
hd tl←(⊃⍵)(1↓⍵) ⍝ Head and tail of expr.
'('=hd:⍺ ∇{ ⍝ Parenthesised sub-expr:
sx rm←''⍺⍺ ⍵ ⍝ Sub-expr and remainder.
0=⍴,⍺:sx ⍺⍺ rm ⍝ Redundant parens.
('@'⍺ sx)⍺⍺ rm ⍝ @-node and remainder.
}tl
')'=hd:⍺ tl ⍝ Complete sub-expression.
'='=hd:⍺ ∇{ ⍝ Assign.
sx rm←''⍺⍺ ⍵
('='⍺ sx)rm
}tl
0=⍴,⍺:hd ∇ tl ⍝ Atom.
('@'⍺ hd)∇ tl ⍝ Function application.
}⍵~' ' ⍝ Ignoring blanks.
rem≡'':exp ⋄ '?' ⍝ No remainder: expression tree.
}
────────────────────────────────────────────────────────────────────────────────
combo←{ ⍝ Combinators.
'tab'≡⍵:↓⍉↑{ ⍝ Combinator reference table:
tmp def←{parse ⍵}\⍵~¨' ' ⍝ Template and definition.
{⍵ def}\(⊃tmp)(1↓tmp) ⍝ Name and args vector.
}¨{
⌽{ ⍝ Smullyan's talking birds:
⍵,⊂' Ix ' ' x '}{ ⍝ I Identity/Idiot
⍵,⊂' Kcx ' ' c '}{ ⍝ K Kestrel
⍵,⊂' Sfgx ' ' fx(gx) '}{ ⍝ S Starling
⍵,⊂' Bfgx ' ' f(gx) '}{ ⍝ B Bluebird
⍵,⊂' Cfgx ' ' fxg '}{ ⍝ C Cardinal
⍵,⊂' $cfgx ' ' c(fx)(gx) '}{ ⍝ S' Phoenix
⍵,⊂' ¢cfgx ' ' c(fx)g '}{ ⍝ C'
⍵,⊂' &cfgx ' ' c(f(gx)) '}{ ⍝ B* Becard
⍵,⊂' Yx ' ' x(Yx) '}{ ⍝ Y Sage bird
⍵,⊂' +n ' ' '}{ ⍝ Succ (Primitive functions)
⍵,⊂' -n ' ' '}{ ⍝ Pred
⍵,⊂' !ntf ' ' '}{ ⍝ Nil?
⍵}''
}⍵
'opt'≡⍵:parse¨¨{ ⍝ Curry/Turner optimisations.
⌽{
⍵,⊂' SKK ' ' I '}{
⍵,⊂' S(Kp)(Kq) ' ' K(pq) '}{
⍵,⊂' S(Kp)I ' ' p '}{
⍵,⊂' S(Kp)(Bqr) ' ' &pqr '}{
⍵,⊂' S(Kp)q ' ' Bpq '}{
⍵,⊂' S(Bpq)(Kr) ' ' ¢pqr '}{
⍵,⊂' Sp(Kq) ' ' Cpq '}{
⍵,⊂' S(Bpq)r ' ' $pqr '}{
⍵}''
}⍵
}
────────────────────────────────────────────────────────────────────────────────
compile←{ ⍝ Combinator expression :: \exp → @exp
comp←{ ⍝ Compile lambda expression.
n l r←⍵ ⍝ Tree node type 'n':
'@'=n:n,∇¨l r ⍝ C[e f] → C[e] C[f]
'\'=n:l abs ∇ r ⍝ C[\x.e] → Ax[ C[e] ]
(⎕D⍳⍵)⊃(⍳⍴⎕D),⍵ ⍝ C[c] → c
} ⍝ :: \exp → @exp
abs←{ ⍝ Variable abstraction.
apply←{'@'⍺ ⍵}{↑⍺⍺⍨/⌽⍵} ⍝ left-associative apply.
0=⍴⍴⍵:⍺{ ⍝ atom:
⍺≠⍵:apply'K'⍵ ⍝ Ax[c] → Kc
ovec opt apply'SKK' ⍝ Ax[x] → SKK
}⍵
af ag←⍺ ∇¨1↓⍵
ovec opt apply'S'af ag ⍝ Ax[f g] → O[ S Ax[f] Ax[g] ]
}
opt←{
0=⍴⍺:⍵ ⍝ No optimisation.
fm to tl←(⊃⍺),⊂(1↓⍺) ⍝ First optimisation and tail.
dict←↓⍉↑fm{ ⍝ Substitution dictionary.
6=⍴⍺,⍵:↑,/⍺ ∇¨⍵ ⍝ Both expressions: recur.
⍴⍴⍺:⊂'∘'⍵ ⍝ Atomic ⍵: no match.
⍺∊'pqr':⊂⍺ ⍵ ⍝ Wild card: dictionary entry.
⍺≡⍵:'' ⋄ '∘' ⍝ Literal match or mis-match.
}⍵
'∘'∊⊃dict:tl ∇ ⍵ ⍝ Not this opt, try next.
dict subs to ⍝ Substitute optimisation.
}
link←{ ⍝ Refs satisfied from environment.
tags _ coms←⍺ ⍝ Names and combinator definitions.
(tags coms)subs ⍵
}
subs←{ ⍝ Substitute from dictionary.
tags vals←⍺ ⍝ Split dictionary.
{
⍴⍴⍵:'@',∇¨1↓⍵ ⍝ Apply: traverse tree,
(tags⍳⍵)⊃vals,⍵ ⍝ Name: corresponding value.
}⍵
}
ovec←combo'opt' ⍝ Combinator optimisations.
⍺ link comp ⍵ ⍝ Compile \exp
}
────────────────────────────────────────────────────────────────────────────────
defn←{ ⍝ Extended environment.
⍺←3/⊂'' ⋄ tags lams _←⍺ ⍝ Default null environment.
lexpr←{ ⍝ Lambda expression from equation.
0=⍴⍴⍺:⍺ ⍵
_ hd tl←⍺
hd ∇ tl arg ⍵
}
arg←{ ⍝ Function argument.
0≠≡⍺:'∆'abs ⍺ apply ⍵ ⍝ apply arg: (+i), (+(+i)), ···
⍺∊⎕D:'∆'abs ⍺ digit ⍵ ⍝ numeric arg: 0, 1, ···
⍺ abs ⍵ ⍝ simple arg: i, j, ···
}
apply←{ ⍝ Apply arg.
_ f a←⍺
~'+'≡f:'?' ⍝ Fn must be +.
test a arg ⍵
}
digit←{ ⍝ Numeric arg.
⍺='0':⍵ nil'?'
pd←((¯1+⎕D⍳⍺)⊃⎕D)∇ ⍵ ⍝ Predecessor.
test'∆'abs pd
}
app←{'@'⍺ ⍵} ⍝ Apply construct.
abs←{'\'⍺ ⍵} ⍝ Lambda abstraction.
nil←{↑app⍨/⌽'!∆',⍺ ⍵} ⍝ Construct: nil? ⍺ else ⍵.
test←{'?'nil↑app/⍵'-' '∆'} ⍝ Nil? test.
tag lex←↑lexpr/1↓⍵ ⍝ f i j k = ⍵ → f = \ijk.⍵
lam←lex{ ⍝ merged current and new \defns.
6=⍴⍺,⍵:⍺ ∇¨⍵ ⍝ both compound: examine each.
(⍺ ⍵⍳'?')⊃⍵ ⍺ ⍺ ⍝ one unknown: use the other.
}(tags⍳tag)⊃lams,⊂lex ⍝ current \defn.
renv←(tag≠tags)∘/¨⍺ ⍝ remaining environment.
com←renv compile tag{ ⍝ New object code.
''≡⍵:'?' ⍝ Value error.
~⍺∊∊⍵:⍵ ⍝ Not recursive: def.
'Y'app ⍺ abs ⍵ ⍝ Recursive: Y(\tag.def).
}lam
renv,∘⊂¨tag lam com ⍝ New environment.
}
────────────────────────────────────────────────────────────────────────────────
reduce←{ ⍝ Combinator reduction.
1002::'...' ⍝ quit on interrupt.
tags defs←combo'tab' ⍝ combinator reference table.
eval←{ ⍝ Value of @exp.
⍴⍴⍵:(eval 1⊃⍵)apply 2⊃⍵ ⍝ function application.
0=⊃0⍴⍵:⍵ ⍝ number.
⍵'',(tags⍳⍵)⊃defs,⊂'' '' ⍝ function suspension.
}
apply←{ ⍝ Function application.
0=⍴⍴⍺:'?' ⍝ bad function: error.
tag rgs tmp def←⍺ ⍝ name, args, template, defn.
args←rgs,⊂⍵ ⍝ extended args vector.
susp←(tmp≡'')∨(⍴args)<⍴tmp ⍝ two few args:
susp:tag args tmp def ⍝ suspension.
tag∊'+-!':tag prim args ⍝ primitive function.
eval{ ⍝ combinator:
⍴⍴⍵:'@',∇¨1↓⍵ ⍝ traverse definition,
(tmp⍳⍵)⊃args,⍵ ⍝ substituting values.
}def
}
prim←{ ⍝ Primitive function.
n←eval⊃⍵ ⍝ strict in first arg.
0≠⊃0⍴n:'?' ⍝ not a number: error.
'+'=⍺:n+1 ⍝ + succ
'-'=⍺:n-1 ⍝ - pred
eval(1+×n)⊃⍵ ⍝ ! nil?
}
eval ⍵ ⍝ reduced expression.
}
────────────────────────────────────────────────────────────────────────────────
trace←{ ⍝ Traced combinator reduction.
1002::'...' ⍝ quit on interrupt.
tags defs←combo'tab' ⍝ combinator reference table.
show←{ ⍝ Underlined redex.
os←+/∧\~⍵⍷⍺ ⍝ offset of redex in expr.
ul←(os,⍴⍵)/' ¯' ⍝ underline.
↑⍺ ul ⍝ 2-row char matrix.
}
{ ⍝ Reduce.
line←format ⍵ ⍝ formatted @exp.
eval←{ ⍝ Evaluation of @exp
⍴⍴⍵:(eval 1⊃⍵)apply 2⊃⍵ ⍝ function application.
0=⊃0⍴⍵:⍵ ⍝ number: done.
⍵'',(tags⍳⍵)⊃defs,⊂'' '' ⍝ function suspension.
}
apply←{ ⍝ Function application.
⍺≡'?':'?' ⍝ error: error.
0=⍴⍴⍺:'@'⍺ ⍵ ⍝ primitive atom.
3=⍴⍺:'@'⍺ ⍵ ⍝ apply node.
tag rgs tmp def←⍺ ⍝ suspension:
args←rgs,⊂⍵ ⍝ argument vector,
susp←(tmp≡'')∨(⍴args)<⍴tmp ⍝ two few args:
susp:tag args tmp def ⍝ suspension.
tag∊'+-!':tag prim args ⍝ primitive function.
⎕←line show format'@'⍺ ⍵ ⍝ trace combinator reduction.
{ ⍝ combinator evaluation.
⍴⍴⍵:'@',∇¨1↓⍵ ⍝ apply node.
(tmp⍳⍵)⊃args,⍵ ⍝ primitive.
}def
}
prim←{ ⍝ Primitive function.
4=⍴,⊃⍵:'?' ⍝ arg is suspension: error.
arg←eval⊃⍵ ⍝ strict first arg:
rdx←↑{'@'⍵ ⍺}/⌽⍺ arg,1↓⍵ ⍝ new redex.
⍴⍴⊃⍵:rdx ⍝ complex arg: re-evaluate.
⎕←line show format rdx ⍝ trace primitive reduction.
0≠⊃0⍴arg:'?' ⍝ bad number: error.
'+'=⍺:arg+1 ⍝ + succ
'-'=⍺:arg-1 ⍝ - pred
(arg≠0)⊃1↓⍵ ⍝ ! nil?
}
eval ⍵
}{ ⍝ Apply above operand,
exp←⍺⍺ ⍵ ⍝ reduce until ..
0=⍴⍴exp:exp ⍝ atom: finished.
3=⍴exp:∇ exp ⍝ apply node: re-evaluate.
tag rgs tmp def←exp ⍝ suspension:
(tmp≡'')∨(⍴rgs)<⍴tmp:exp ⍝ too few args: finished.
⍺⍺'@'tag rgs ⍝ args galore: re-evaluate.
}⍵
}
────────────────────────────────────────────────────────────────────────────────
format←{ ⍝ Format \exp.
0=⍴⍴⍵:⍕⍵ ⍝ Atom: format single item.
(,4)≡⍴⍵:∇↑{'@'⍵ ⍺}/⌽↑,/2↑⍵ ⍝ Curried function.
'@'≡⊃⍵:∇{ ⍝ Function application.
fun arg←⍵ ⍝ Function and argument.
paren←{∊⍺ 1 ⍺/¨'('⍵')'} ⍝ Parenthesise.
pars←('\'=⊃fun)(⍴⍴arg) ⍝ Required lft & rgt parentheses.
↑,/pars paren∘⍺⍺¨fun arg ⍝ fun arg.
}1↓⍵
'\'≡⊃⍵:''∇{ ⍝ Lambda abstraction.
bvar body←⍵ ⍝ Bound variable and body.
args←⍺,bvar ⍝ Arguments.
'\'=⊃body:args ∇ 1↓body ⍝ Collect multiple arguments.
'\',args,'.',⍺⍺ body ⍝ \args.body.
}1↓⍵
∇¨⍵ ⍝ Perhaps an array of expr's.
}
────────────────────────────────────────────────────────────────────────────────
trees←{ ⍝ Format :: \exp → [char;]
0=≡⍵:⍵ ⍝ Lonely leaf.
⍺←'┌─┐' ⋄ ll mm rr←⍺ ⍝ Default line drawing chars.
~(⊂⊃⍵)∊'@\=':⍺∘∇¨⍵ ⍝ Perhaps a spinney?
1 0↓' '{ ⍝ Dummy header for top node.
0=≡⍵:↑(⊃1↓⍺)(,⍕⍵) ⍝ Atom - done.
subs←(' 'll mm)(mm rr' ')∇¨1↓⍵ ⍝ Formatted sub trees.
r c←↑⌈/⍴¨subs ⍝ Rows and cols.
fill←r↑⊃⍵ ⍝ Filler between subs.
mr←{(⍺⍺⌽⊃⍵)(⍺⍺⊃⌽⍵)} ⍝ Mirror operator.
xsbs←⊢mr{r c↑⍵}mr subs ⍝ Expanded sub trees.
gap←{+/∧\⍵∊' ',mm}mr xsbs ⍝ Extra space between subtrees.
cut←⌊/↑+/gap ⍝ Number of cols to cut.
rc←cut+lc←-cut⌊⊃gap ⍝ Left cut and right cut.
lt rt←lc rc{⍺↓¨↓⍵}¨xsbs ⍝ Inside extra cols removed.
this←{(∨⌿⍵≠' ')/⍵}↑lt,¨fill,¨rt ⍝ Outside blank cols removed.
mask←(⊃⍵)≠⊃↓this ⍝ Left and right spacing.
repl←{+/∧\⍵}¨(mask)1(⌽mask) ⍝ Replication for header.
(repl/⍺)⍪this ⍝ Formatted tree and header.
}⍵
}
────────────────────────────────────────────────────────────────────────────────
Back to: contents