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