APL/D Source Code:

────────────────────────────────────────────────────────────────────────────────

max←{                                   ⍝ Max compiler/interpreter.

    stream←{                            ⍝ Process input stream.
        src rem←''next ⍵                ⍝ next line and remainder.
        ')'=⊃src:envt←retract ⍺         ⍝ quit returning (shy) envt.
        exp←⍺ lambda parse src          ⍝ lambda expr tree from source.
        (⍺ show exp)∇ rem               ⍝ show evaluation of statement.
    }                                   ⍝ {env} ← env :: [src]

    next←{                              ⍝ Next complete expression.
        clean←{(∧\⍵≠'/')/⍵}∘{⍵~' ·'}    ⍝ blanks and comments removed.
        src←clean ⍺ input ⍵             ⍝ clean source line.
        0∊src∊chars:⍺ ∇(⎕←'?')⊢1↓⍵      ⍝ bad char: error and retry.
        ''≡src:⍺ ∇ 1↓⍵                  ⍝ blank lines ignored.
        acc←⍺,src                       ⍝ accumulated source.
        nxt←clean⊃1↓⍵                   ⍝ following line.
        ~'·'∊acc prompt nxt:acc(1↓⍵)    ⍝ complete: srce and remainder.
        acc ∇ 1↓⍵                       ⍝ accumulate current line.
    }                                   ⍝ src [src] ← src :: [src]

    input←{                             ⍝ Input from buffer or keybd.
        ×⍴⍵:{⍞←⍵,⊃⌽⎕TC ⋄ ⍵}⊃⍵           ⍝ next item from buffer, else
        ⍞⊣⍞←⍺ prompt''                  ⍝ prompt and input from keybd.
    }                                   ⍝ src ← src :: [src]

    prompt←{                            ⍝ Prompt string.
        last next←¯1 1↑¨⍺ ⍵             ⍝ joining characters.
        dots←'.'∊last,next              ⍝ trailing or leading dots.
        more←last∊'([,.'                ⍝ more to come.
        depth←0⌈-/+/¨⍺∘∊¨'([' '])'      ⍝ bracket nesting depth.
        dent←0⌈dots+depth-~more         ⍝ indentation for depth.
        cont←4↑(dots∨×depth)/'·'        ⍝ continuation indication.
        cont,∊dent⍴⊂4↑'·'               ⍝ prompt string.
    }                                   ⍝ [char] ← src :: src

    retract←{↑((⊃⍵)∊alph)/↓⍉↑⍵}         ⍝ Envt without primitive defs.

    alph←const'alph'                    ⍝ definition alphabet.

    chars←{                             ⍝ Max alphabet:
        a←alph                          ⍝ names a=z,
        n←'0123456789'                  ⍝ numbers 0-9,
        s←'.()=[,]:+~'                  ⍝ syntax.
        t←'#→',const'vars'              ⍝ type expressions.
        f←⊃↓⍉↑const'ptypes'             ⍝ primitive functions.
        c←⊃↓⍉↑const'cdefs'              ⍝ combinator names.
        l←'\._∇'                        ⍝ lambda syntax.
        ∪a,n,s,t,⍵/f,c,l                ⍝ names, nums, sntx, type, xtra.
    }1                                  ⍝ accept extended Max exprs.

    ⍺←0 4⍴'' ⋄ env←extend↓⍺             ⍝ starting environment.
    script←(⍵≡'')↓↓⎕FMT↑⍵               ⍝ script as vector of vectors.
    env stream script                   ⍝ Input streamed from script.
}

────────────────────────────────────────────────────────────────────────────────

parse←{                                 ⍝ Parse tree from Max source vector.

    prep←''∘{                           ⍝ Preprocess.
        ''≡⍵:⍺                          ⍝ no source: accumulated tokens.
        '\.'≡2↑⍵:⍺ ∇ 2↓⍵                ⍝ \.x      → x
        '\'=⊃⍵:(⍺,⌽2↑⍵)∇'\',2↓⍵         ⍝ \abc.x   → a\b\c\x
        '::'≡2↑⍵:(⍺,'⊤')∇ 2↓⍵           ⍝ ::       → ⊤
        dots←+/∧\⍵='.'                  ⍝ number of 'where' dots.
        ×dots:(⍺,-dots)∇ dots↓⍵         ⍝ . .. ... ··· → ¯1 ¯2 ¯3 ···
        (⍺,⊃⍵)∇ 1↓⍵                     ⍝ accumulate token.
    }

    post←'-' '-' '' ''∘{                ⍝ Postfix from infix.
        st bk ac sk←⍺                   ⍝ StaTe BracKet AcCumulator StacK.
        os←st='⍵'                       ⍝ operand state.
        ''≡⍵:(ac,os↓'?',sk)⍵            ⍝ no source: accumulated tokens.
        s ss←split ⍵                    ⍝ first and remaining source tokens.
        0 1≡os,s∊ops:⍺ ∇'?',⍵           ⍝ missing operand: inject dummy.

        s∊ops:s ∇{                      ⍝ Infix operator:
            '(,'≡bk,⍺:'?'               ⍝ no tuples for the nonce.
            s←('-,'≡bk,⍺)⊃⍺'⋄'          ⍝ cons or statement separator.
            ∆ac ∆sk←ac s,¨s cut sk      ⍝ op slotted into ac-sk stacks.
            '∇'bk ∆ac ∆sk ⍺⍺ ⍵          ⍝ new stacks in '∇' state.
        }ss

        s∊'([':s ∇{                     ⍝ Left paren or bracket.
            sx rm←'-'⍺'' ''⍺⍺ ⍵         ⍝ sub expression and remainder.
            r rr←split rm               ⍝ right bracket and remainder.
            r≠('(['⍳⍺)⊃')]':'?'         ⍝ mismatched brackets: error.
            ∆ac←ac,sx,os/'@'            ⍝ new accumulator.
            '⍵'bk ∆ac sk ⍺⍺ rr          ⍝ output sub expression.
        }ss

        s∊'])':{                        ⍝ Right bracket or paren.
            '∇'=st:'?'                  ⍝ incomplete expression: error.
            ')'=⊃ac,s:'?'               ⍝ (): error.
            ']'=⊃ac,s:'⍬'⍵              ⍝ []: null.
            ')'=s:(ac,sk)⍵              ⍝ sub-expression and remainder.
            (∊ac'⍬,',¨','cut sk)⍵       ⍝ 'a,b]' → a,b,⍬
        }⍵

        ∆ac←ac,(rand s),os/'@'          ⍝ new accumulator.
        '⍵'bk ∆ac sk ∇ ss               ⍝ output operand.
    }

    tree←''∘{                           ⍝ Tree from postfix.
        0=⍴,⍵:⊃⍺                        ⍝ no tokens: accumulated tree.
        t tt←split ⍵                    ⍝ first and remaining tokens.
        ~t∊ops:(⍺,t)∇ tt                ⍝ not an operator: pass it along.
        oo a b←(⊂¯2↓⍺),¯2↑'?',⍺         ⍝ operator:2 operands & remainder.
        t∊',:':(oo,⊂app'⊂'a b)∇ tt      ⍝ cons becomes applied function.
        op←(t∊dots)⊃t'.'                ⍝ restore "where" dot.
        (oo,⊂op a b)∇ tt                ⍝ operator bound with operands.
    }

    split←{(⊃⍵)(1↓⍵)}                   ⍝ First and remaining items.
    cut←{/∘⍵¨1 0=</ops∘⍳¨⍺ ⍵}           ⍝ ⍵ cut at binding strength of ⍺.
    app←{↑{'@'⍺ ⍵}⍨/⌽⍵}                 ⍝ function application.
    rand←{⍵∊⎕D:⎕D⍳⍵ ⋄ ⍵}                ⍝ operand: '0'··'9' → 0··9

    dots←¯1-⍳⍴⎕A                        ⍝ where dots: .a=··.z= → ¯1··¯26
    ⍺←'⋄~⊤,→',dots,'=\:@' ⋄ ops←,⍺      ⍝ Default operator set.
    tree⊃post prep ⍵~' ·'               ⍝ Parse tree from source.
}

────────────────────────────────────────────────────────────────────────────────

const←{                                     ⍝ Implementation constants.

    'alph'≡⍵:'abcdefghijklmnopqrstuvwxyz'   ⍝ Object name alphabet.

    'vars'≡⍵:'⍺⍵∊⍳⍴∆⌽⊖⍉⍙⍷○⍟⍎⍕⍋⍒⍫⍨⊢¥$£¢%⋄'   ⍝ Type variable alphabet.

    'cdefs'≡⍵:⌽{                            ⍝ Combinator definitions:
        ⍵,⊂'I' ' x    ' ' x         '}{     ⍝ I   Smullyan: Identity/Idiot
        ⍵,⊂'K' ' cx   ' ' c         '}{     ⍝ K             Kestrel
        ⍵,⊂'S' ' fgx  ' ' fx(gx)    '}{     ⍝ S             Starling
        ⍵,⊂'B' ' fgx  ' ' f(gx)     '}{     ⍝ B             Bluebird
        ⍵,⊂'C' ' fgx  ' ' fxg       '}{     ⍝ C             Cardinal
        ⍵,⊂'$' ' cfgx ' ' c(fx)(gx) '}{     ⍝ S'            Phoenix
        ⍵,⊂'¢' ' cfgx ' ' c(fx)g    '}{     ⍝ C'            -
        ⍵,⊂'&' ' cfgx ' ' c(f(gx))  '}{     ⍝ B*            Becard
        ⍵,⊂'Y' ' x    ' ' x(Yx)     '}{     ⍝ Y             Sage bird
        ⍵,⊂'∇' ' x    ' ' x(Yx)     '}⍬     ⍝ Y (synonym)

    'ptypes'≡⍵:⌽{                           ⍝ Primitive types:
        ⍵,⊂'+' ' #→#               '}{      ⍝ +  succ
        ⍵,⊂'-' ' #→#               '}{      ⍝ -  pred
        ⍵,⊂'!' ' #→⍺→⍺→⍺           '}{      ⍝ !  nil?
        ⍵,⊂'↑' ' [⍺]→⍺             '}{      ⍝ ↑  head
        ⍵,⊂'↓' ' [⍺]→[⍺]           '}{      ⍝ ↓  tail
        ⍵,⊂'∘' ' [⍺]→⍵→⍵→⍵         '}{      ⍝ ∘  null?
        ⍵,⊂'⊂' ' ⍺→[⍺]→[⍺]         '}{      ⍝ ⊂  cons (link)
        ⍵,⊂'?' ' ⍺                 '}{      ⍝ ?  error
        ⍵,⊂'⍬' ' [⍺]               '}{      ⍝ [] null
        ⍵,⊂'I' ' ⍺→⍺               '}{      ⍝ I  Identitätsfunktion
        ⍵,⊂'K' ' ⍺→⍵→⍺             '}{      ⍝ K  Konstanzfunktion
        ⍵,⊂'S' ' (⍺→∊→⍵)→(⍺→∊)→⍺→⍵ '}{      ⍝ S  VerSchmelzungsfunktion
        ⍵,⊂'Y' ' (⍺→⍺)→⍺           '}⍬      ⍝ Y "Paradoxical combinator"

    'opts'≡⍵:⌽{                             ⍝ Curry/Turner optimisations:
        ⍵,⊂' S(K⍺)(K⍵)  ' ' K(⍺⍵) '}{       ⍝ K
        ⍵,⊂' S(K⍺)I     ' ' ⍺     '}{       ⍝
        ⍵,⊂' S(K⍺)(B⍵∊) ' ' &⍺⍵∊  '}{       ⍝ B*
        ⍵,⊂' S(K⍺)⍵     ' ' B⍺⍵   '}{       ⍝ B
        ⍵,⊂' S(B⍺⍵)(K∊) ' ' ¢⍺⍵∊  '}{       ⍝ C'
        ⍵,⊂' S⍺(K⍵)     ' ' C⍺⍵   '}{       ⍝ C
        ⍵,⊂' S(B⍺⍵)∊    ' ' $⍺⍵∊  '}⍬       ⍝ S'

    'temps'≡⍵:⌽{                            ⍝ Pattern matching templates:
        ⍵,⊂'!' '\_.!_⍵?  '}{                ⍝ if zero.
        ⍵,⊂'+' '\_.!_?⍵  '}{                ⍝ if non-zero.
        ⍵,⊂'-' '⍵(-_)    '}{                ⍝ predecessor.
        ⍵,⊂'∘' '\_.∘_⍵?  '}{                ⍝ if null.
        ⍵,⊂'○' '\_.∘_?⍵  '}{                ⍝ if non-null.
        ⍵,⊂'↓' '⍵(↑_)(↓_)'}⍬                ⍝ split head and tail.
}

────────────────────────────────────────────────────────────────────────────────

compile←{                               ⍝ Combinator expression

    comp←{                              ⍝ Compile expression.
        0=⍴⍴⍵:⍵                         ⍝ C[c] → c
        '@'=⊃⍵:(⊃⍵),∇¨1↓⍵               ⍝ C[e f] → C[e] C[f]
        '\'=⊃⍵:↑abs∘∇/1↓⍵               ⍝ C[\x.e] → Ax[ C[e] ]
    }                                   ⍝ @exp ← :: \exp

    abs←{                               ⍝ Variable abstraction.
        app←{'@'⍺ ⍵}                    ⍝ application node.
        0=⍴⍴⍵:⍺{                        ⍝ atom:
            ⍺=⍵:'I'                     ⍝ Ax[x] → I
            'K'app ⍵                    ⍝ Ax[c] → Kc
        }⍵                              ⍝
        otab opt↑app⍨/⌽'S',⍺ ∇¨1↓⍵      ⍝ Ax[f g] → O[ S Ax[f] Ax[g] ]
    }                                   ⍝ @exp ← :: \exp

    opt←{                               ⍝ Optimise combinator expression.
        0=⍴⍺:⍵                          ⍝ no optimisation.
        fm to tl←(⊃⍺),⊂(1↓⍺)            ⍝ first optimisation and tail.
                                        ⍝
        dict←↓⍉↑fm{                     ⍝ substitution dictionary.
            6=⍴⍺,⍵:↑,/⍺ ∇¨⍵             ⍝ both expressions: recur.
            ⍴⍴⍺:⊂'∘'⍵                   ⍝ atomic ⍵: no match.
            ⍺∊'⍺⍵∊':⊂⍺ ⍵                ⍝ wild card: dictionary entry.
            ⍺≡⍵:'' ⋄ '∘'                ⍝ literal match or mis-match.
        }⍵                              ⍝
                                        ⍝
        '∘'∊⊃dict:tl ∇ ⍵                ⍝ not this opt, try next.
        dict subs to                    ⍝ substitute optimisation.
    }                                   ⍝

    subs←{                              ⍝ Substitute from dictionary.
        tags vals←⍺                     ⍝ split dictionary.
        {                               ⍝
            ⍴⍴⍵:'@',∇¨1↓⍵               ⍝ apply: traverse tree,
            (tags⍳⍵)⊃vals,⍵             ⍝ name: corresponding value.
        }⍵                              ⍝
    }                                   ⍝

    otab←⍺ ⋄ comp ⍵                     ⍝ Compile \exp
}

────────────────────────────────────────────────────────────────────────────────

unify←{                                 ⍝ Unification of type expressions.

    ⍺≡⍵:⍺                               ⍝ Easy if identical.
    isvar←{0≡⊃0⍴⊂⍵}                     ⍝ Type variable test.
    case←isvar¨⍺ ⍵                      ⍝ any type variables?
    1∊case:(case⍳0)⊃⍺ ⍵ ⍺               ⍝ yes: choose the other.

    dist←{                              ⍝ Distinct type variables.
        lv rv←vars¨⍵                    ⍝ left and right expr type vars.
        0=⍴lv∩rv:⍵                      ⍝ already distinct: done.
        to←(1+⌈/lv,rv)+⍳⍴rv             ⍝ vars above those in left expr.
        ↑{⍺ ⍵}∘{rv to xlate ⍵}/⍵        ⍝ left followed by relocated right.
    }                                   ⍝ tex tex ← :: tex tex

    subs←⍬ ⍬∘{                          ⍝ Substitution table.
        ≡/⍵:⍺                           ⍝ early out if identical.
        1 1≡{⊃⍴⍴⍵}¨⍵:↑∇⍨/⌽(⊂⍺),↓⍉↑⍵     ⍝ both exprs deep: traverse each.
        case←isvar¨⍵                    ⍝ which are type vars?
        case≡0 0:(≡/⍵)⊃'?'⍺             ⍝ neither: must match.
        case≡1 1:⍺ merge(</⍵)⌽⍵         ⍝ both: merge into subs table.
        ⍺ merge(~⊃case)⌽⍵               ⍝ either: merge into subs table.
    }                                   ⍝ subs ← subs :: exp exp

    merge←{                             ⍝ Merge new subs into table.
        tag val←⍵                       ⍝ name and value.
        ~tag∊⊃⍺:⍺,∘⊂¨⍵                  ⍝ new name: append subs.
        (⊂val)∊⊃⍺:⍺                     ⍝ avoid cycle.
        cval←⍺ dref tag                 ⍝ current value.
        val≡cval:⍺                      ⍝ early out if no change.
        ↑∇⍨/⌽(⊂⍺),↓⍉↑subs val cval      ⍝ extended subs table.
    }                                   ⍝ subs ← subs :: sub

    fix←{                               ⍝ Fixpoint of function ⍺⍺.
        1∊∊{⍺∊∊⍵}¨/⍵:'?'                ⍝ cycle: error.
        ⍵≡z←⍺⍺ ⍵:⍵                      ⍝ arg ≡ rslt: done.
        ∇ z                             ⍝ arg ≢ rslt: refine.
    }

    refs←{↑⍵{⍺{⍺ ⍵}⍺⍺ xlate ⍵}/⍵}       ⍝ Resolve refs to refs.
    xlate←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍺ dref ⍵}        ⍝ Scalar-wise translation.
    dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,⊂⍺⍺}/⍺}           ⍝ Dereference from table.
    echk←{'?'∊∊⍵:'?' ⋄ ⍵}               ⍝ Error pervades expression.
    vars←{∪(∊⍵)~⎕AV}                    ⍝ Type variables used in expr.

    stab←refs fix subs dist ⍺ ⍵         ⍝ substitution table.
    echk stab xlate ⍺                   ⍝ left expr xlated from subs table.
}

────────────────────────────────────────────────────────────────────────────────

defn←{                                  ⍝ Extend environment.

    merge←{                             ⍝ Merge current and new \defns.
        ⍺≡⍵:⍺                           ⍝ identical: done.
        1 1≡{⊃⍴⍴⍵}¨⍺ ⍵:⍺ ∇¨⍵            ⍝ both compound: examine each.
        (⍺ ⍵⍳'?')⊃⍵ ⍺ ⍺                 ⍝ one unknown: use the other.
    }

    link←{                              ⍝ Bind external refs from envt ⍺.
        ⍴⍴⍵:(⊃⍵),∇¨1↓⍵                  ⍝ traverse expression scalar-wise.
        ~⍵∊alph:⍵                       ⍝ not a name: preserve.
        (tags⍳⍵)⊃cdefs,⍵                ⍝ replaced with value from envt.
    }

    free←{                              ⍝ Var ⍺ free in exp ⍵?
        0=⍴⍴⍵:⍺=⍵                       ⍝ atom: free if same as var.
        '\'⍺≡2↑⍵:0                      ⍝ var bound here: not free.
        ∨/⍺ ∇¨1↓⍵                       ⍝ not \abs, free in either sub?
    }                                   ⍝ bool ← var :: exp.

    alph←const'alph'                    ⍝ Name alphabet.
    yfree←{⍺ free ⍵:⍺ bindy ⍵ ⋄ ⍵}      ⍝ Bind free var with lambda.
    bindy←{'@' 'Y'('\'⍺ ⍵)}             ⍝ Bind var with lambda.

    tags ldefs cdefs tdefs←⍺            ⍝ Environment.
    _ tag lex←⍵                         ⍝ name and value.
    ~tag∊alph:⍺⊣⎕←'?'                   ⍝ bad name: retain current envt.
    odef←(tags⍳tag)⊃ldefs,⊂lex          ⍝ current \defn.
    ldef←lex merge odef                 ⍝ merged old and new \defns.
    otab←(tags⍳'○')⊃cdefs               ⍝ compilation optimisation table.
    cdef←otab compile tag yfree ldef    ⍝ combinator definition.
    told←(tags⍳tag)⊃tdefs,0             ⍝ existing type defn.
    tdef←told unify ⍺ type cdef         ⍝ new type defn.
    '?'∊∊tdef:⍺⊣⎕←'?'                   ⍝ error: retain existing envt.
    cabs←link cdef                      ⍝ bind external refs @ defn time.
    dnew←tag ldef cabs tdef             ⍝ complete new definition.
    dnew{(⊂⍺),⍵}¨(tag≠tags)∘/¨⍺         ⍝ merged into environment.
}

────────────────────────────────────────────────────────────────────────────────

extend←{                                ⍝ Extend supplied environment.

    show←{                              ⍝ show progress of function ⍺⍺.
        ⍺←'' ⋄ ⍞←⊃⍵                     ⍝ display name tag.
        (⍞←1 0 1\⊃⎕TC)⊢⍺ ⍺⍺ ⍵           ⍝ clear display after processing.
    }                                   ⍝ tab ← ⍺ ()

    ctypes←{                            ⍝ deduce combinator types.
        name args dsrc←⍵                ⍝ template, definition source.
        cdef←parse dsrc                 ⍝ combinator definition.
        temp←args~' '                   ⍝ argument template.
        lexp←↑{'\'⍺ ⍵}/temp,⊂cdef       ⍝ lambda definition.
        mask←(⊃¨⍺)∘{∧/⍵∊⍺}¨orefs        ⍝ mask for safe optimisations.
        cexp←(mask/opts)compile lexp    ⍝ combinator expression.
        tdef←(↓⍉↑⍺)type cexp            ⍝ type definition.
        renv←(name≠⊃¨⍺)/⍺               ⍝ remaining environment.
        renv,⊂name temp cdef tdef       ⍝ environment tuple.
    }show                               ⍝ env ← [src] :: env

    func←{                              ⍝ function table entry.
        name texp←table ⍵               ⍝ name, args and type source.
        temp←(+/'→'=∊texp)⍴'⍵'          ⍝ argument template.
        1 1 0 1\name temp texp          ⍝ function table entry.
    }show                               ⍝ def ← :: [src]

    patn←{{parse ⍵}\⍵}show              ⍝ pattern matching template.
    numb←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍵∊⍺:⍺⍳⍵ ⋄ ⍵}      ⍝ conv ⍺, ⍵, ∊, ··· → 0, 1, 2,
    table←{↑{⍺,⊂vars numb parse ⍵}/⍵}   ⍝ tag with parsed expression.

    vars←const'vars'                    ⍝ type variables.
    cdefs←const'cdefs'                  ⍝ combinator definitions.
    ptypes←const'ptypes'                ⍝ primitive types.
    ctags ptags←⊃¨¨cdefs ptypes         ⍝ combinator and function names.
    opts←'@'parse¨¨const'opts'          ⍝ combinator optimisations.
    orefs←(⊃¨cdefs)∘{⍺∩∊⍵}¨opts         ⍝ optimisation combinator refs.
    temps←↓⍉↑patn¨const'temps'          ⍝ pattern matching templates.

    boot←{1 0 0 1\table ⍵}              ⍝ combinator type bootstrap.
    btab←boot¨(ptags∊ctags)/ptypes      ⍝ bootstrap with primitive types.
    ctab←↑ctypes⍨/(⌽cdefs),⊂btab        ⍝ primitive combinator table.
    ftab←func¨(~ptags∊ctags)/ptypes     ⍝ primitive function table.
    otab←⊂1 0 1 0\'○'opts               ⍝ optimisation table.
    ptab←⊂1 1 0 0\'≡'temps              ⍝ pattern matching templates.
    ↓⍉↑ftab,ctab,otab,ptab,⍵            ⍝ complete environment.
}

────────────────────────────────────────────────────────────────────────────────

equn←{                                  ⍝ Lambda from equation.

    lexpr←{                             ⍝ Lambda expression from equation.
        0=⍴⍴⍺:⍺(env lambda ⍵)           ⍝ simple: finished.
        _ hd tl←⍺                       ⍝ head and tail of fun-arg list.
        hd ∇ tl larg ⍵                  ⍝ traverse subtree to left of '='.
    }

    larg←{                              ⍝ Lambda expr from argt pattern.
        '@'=⊃⍺:⍺ apply ⍵                ⍝ number successor: (+i), (+(+i)),
        0=⊃0⍴⍺:⍺ digit ⍵                ⍝ numeric literal:  0, 1,
        '⍬'=⍺:null ⍵                    ⍝ null list:        [],
        '\'⍺ ⍵                          ⍝ simple name:      i, j,
    }

    apply←{                             ⍝ Apply arg.
        _ fun arg←⍺                     ⍝ fun and arg.
        '+'≡fun:numb pred arg larg ⍵    ⍝ + succ
        '@⊂'≢2↑fun:'?'                  ⍝ not cons: error
        hd←2⊃fun ⋄ tl←arg               ⍝ head and tail.
        list cons hd larg tl larg ⍵     ⍝ list.
    }

    digit←{                             ⍝ Numeric arg.
        ⍺=0:zero ⍵                      ⍝ f 0: ···
        numb pred(⍺-1)∇ ⍵               ⍝ f n:
    }

    subs←{                              ⍝ Substitute ⍵ for '⍵' in ⍺.
        ⍴⍴⍺:⍺ ∇¨⊂⍵                      ⍝ traverse ⍺,
        ⍺='⍵':⍵ ⋄ ⍺                     ⍝ subs '⍵' for ⍵.
    }

    dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,⊂⍺⍺}/⍺}           ⍝ dereference from table.
    env←⍺ ⋄ temp←(2↑env)dref'≡'         ⍝ pattern matching templates.

    zero←(temp dref'!')∘subs            ⍝ template for zero test.
    numb←(temp dref'+')∘subs            ⍝   ..  ..  .. non-zero test.
    pred←(temp dref'-')∘subs            ⍝   ..  ..  .. predecessor.

    null←(temp dref'∘')∘subs            ⍝ template for null test.
    list←(temp dref'○')∘subs            ⍝   ..  ..  .. non-null test.
    cons←(temp dref'↓')∘subs            ⍝   ..  ..  .. list constructor.

    '=',↑lexpr/1↓⍵                      ⍝ f i j k = ⍵  →  f = \ijk.⍵
}

────────────────────────────────────────────────────────────────────────────────

lambda←{                                ⍝ Lambda expression from parse tree.
    0=⍴⍴⍵:⍵                             ⍝ atom: done.
    op lft rgt←⍵                        ⍝ split expression.
    '='=op:⍺ equn ⍵                     ⍝ equation:
    '.'=op:⍺ local ⍵                    ⍝ local definition:
    op,⍺∘∇¨lft rgt                      ⍝ process subtrees.
}

────────────────────────────────────────────────────────────────────────────────

local←{                                 ⍝ Lambda from 'where' clause(s).

    lexp←{                              ⍝ encapsulate local definitions.
        '='≢⊃⍵:'?'                      ⍝ not both equations: error.
        '='≢⊃⍺:2⊃('=_',⊂⍺)∇ ⍵           ⍝ complete primary definition.
        _ ltag lval←⍺                   ⍝ left equation.
        _ rtag rval←⍵                   ⍝ right equation.
        {'='ltag ⍵}rtag{                ⍝
            0=⍴⍴⍵:(⍺≡⍵)⊃⍵ rval          ⍝ atom:
            case←⍺ free¨1↓⍵             ⍝ name free in subtrees.
            0 0≡case:⍵                  ⍝ neither: omit local defn.
            1 1≡case:'@'('\'⍺ ⍵)rval    ⍝ both: insert lambda abs here.
            op lft rgt←⍵                ⍝ split expr.
            0 1≡case:op lft(⍺ ∇ rgt)    ⍝ pursue right subtree.
            1 0≡case:op(⍺ ∇ lft)rgt     ⍝ pursue left subtree
        }lval                           ⍝ local definition body.
    }                                   ⍝ exp ← exp :: exp

    merge←{                             ⍝ Merge current and new \defns.
        (2↑⍺)≢2↑⊃⍵:(⊂⍺),⍵               ⍝ distinct equation: continue.
        mrg←{                           ⍝ new merged equation.
            1 1≡{⊃⍴⍴⍵}¨⍺ ⍵:⍺ ∇¨⍵        ⍝ both compound: examine each.
            (⍺ ⍵⍳'?')⊃⍵ ⍺ ⍺             ⍝ one unknown: use the other.
        }                               ⍝ merged with previous equation.
        (⊂⍺ mrg⊃⍵),1↓⍵                  ⍝ new head of equations.
    }                                   ⍝ [exp] ← exp :: [exp]

    trav←{                              ⍝ Traverse where clauses.
        op lft rgt←⍵                    ⍝
        lexp←⊂⍺ lambda lft              ⍝
        op≡⊃rgt:lexp,⍺ ∇ rgt            ⍝
        lexp,⊂⍺ lambda rgt              ⍝
    }                                   ⍝ [exp] ← op :: exp

    yify←{                              ⍝ Use Y combinator for recursion.
        eq tag val←⍵                    ⍝ name and equation body.
        ~tag free val:⍵                 ⍝ name not free in body: done.
        abs←'\'tag val                  ⍝ lambda abstraction.
        app←'@' 'Y'abs                  ⍝ applied Y combinator.
        eq tag app                      ⍝ new equation.
    }                                   ⍝ exp ← :: exp

    free←{                              ⍝ Var ⍺ free in exp ⍵?
        0=⍴⍴⍵:⍺≡⍵                       ⍝ atom: free if it's the var.
        '\'⍺≡2↑⍵:0                      ⍝ var bound here: not free.
        ∨/⍺ ∇¨1↓⍵                       ⍝ not \abs, free in either sub?
    }                                   ⍝ bool ← var :: exp.

    defs←¯1↓↑merge/(⍺ trav ⍵),'?'       ⍝ local definitions.
    ↑lexp⍨/⌽(1↑defs),yify¨1↓defs        ⍝ complete definition.
}

────────────────────────────────────────────────────────────────────────────────

type←{                                  ⍝ Type of expression.

    infer←{                             ⍝ Expression type inference.
        0=⍴⍴⍵:⍺{                        ⍝ atom:
            0=⊃0⍴⍵:'#'                  ⍝ number: type num.
            ~⍵∊⊃env:'?'                 ⍝ unbound name: error.
            ⍺ bias env dref ⍵           ⍝ type from environment.
        }⍵                              ⍝ name or literal.
        _ fun arg←⍵                     ⍝ apply node: function and argument.
        op fm to←⍺ ∇ fun                ⍝ function component types.
        op≢'→':'?'                      ⍝ non-function
        base←⍺ next fm to               ⍝ variable base.
        targ←base ∇ arg                 ⍝ right subtree.
        ⊃⌽fm to unify targ 0            ⍝ unified result type.
    }                                   ⍝ tex ← nxt :: exp

    bias←{(⍺ btab ⍵)xlate ⍵}            ⍝ Bias type vars above ⍺.
    btab←{⍺{⍵(⍺+⍳⍴⍵)}vars ⍵}            ⍝ bias table
    xlate←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍺ dref ⍵}        ⍝ Scalar-wise translation.
    dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,⍺⍺}/⍺}            ⍝ Dereference from table.
    next←{1+⌈/⍺,vars ⍵}                 ⍝ Next avail type variable.
    vars←{∪(∊⍵)~⎕AV}                    ⍝ Type variables used in expr.
    env←1 0 0 1/⍺                       ⍝ type definitions.
    0 bias 1 infer ⍵                    ⍝ normalised inferred type.
}

────────────────────────────────────────────────────────────────────────────────

typex←{                                 ⍝ Type expression.

    query←{                             ⍝ query environment.
        otab←(tags⍳'○')⊃cdefs           ⍝ compile optimisation table.
        obj←otab compile exp            ⍝ object code.
        tex←env type obj                ⍝ expression type.
        tex≡obj:env(rem put'?')         ⍝ error: error.
        env(rem put tfmt tex)           ⍝ display type, return envt.
    }                                   ⍝ env rem ← :: exp

    tfmt←{                              ⍝ Type expr format.
        0=⍴⍴⍵:{                         ⍝ Atom:
            0=⊃0⍴⍵:⍵⊃vars               ⍝ type variable.
            ('⍬'=⍵)⊃⍵'[]'               ⍝ null or constructor.
        }⍵                              ⍝ formatted atom.

        '→'=⊃⍵:∇{                       ⍝ Function type:
            argt rslt←⍺⍺¨⍵              ⍝ arg and rslt types.
            lp rp←('→'=⊃⊃⍵)/¨'()'       ⍝ parens.
            lp,argt,rp,'→',rslt         ⍝ parenthesised expr.
        }1↓⍵                            ⍝ function and argument.

        '@'=⊃⍵:∇{                       ⍝ Cons application type.
            func argt←⍺⍺¨⍵              ⍝ head and tail.
            func≡'⊂':'[',argt           ⍝ leftmost application.
            func,1↓argt                 ⍝ ···:[] → ···]
        }1↓⍵                            ⍝ function and argument.
    }                                   ⍝ tex ← :: exp

    spec←{                              ⍝ Type specification.
        _ tag tex←⍵                     ⍝ name and type expression.
        renv←(tags≠tag)∘/¨env           ⍝ remaining environment.
        told←(tags⍳tag)⊃tdefs,0         ⍝ old type definition.
        tnew←told unify tex             ⍝ new refined type definition.
        '?'∊∊tnew:env(1 put'?')         ⍝ error: error.
        lnew←(tags⍳tag)⊃ldefs,'?'       ⍝ lambda defn or wild card.
        cnew←(tags⍳tag)⊃cdefs,'?'       ⍝ combinator defn or wild card.
        defn←tag lnew cnew tnew         ⍝ new definition.
        xenv←renv,∘⊂¨defn               ⍝ extended environment.
        xenv rem                        ⍝ new envt and remaining cols.
    }                                   ⍝ env rem ← :: def

    put←{rem←⍺⌊⍴,⍵ ⋄ ⍞←rem↑⍵ ⋄ ⍺-rem}   ⍝ Put string to session.

    env rem←⍺                           ⍝ envt and remaining cols.
    tags ldefs cdefs tdefs←env          ⍝ environment.
    op exp tex←⍵                        ⍝ ⊤, exp, type-def.
    vars←const'vars'                    ⍝ type variables.
    tex≡'?':query exp                   ⍝ type query.
    ~(⊂exp)∊const'alph':env(1 put'?')   ⍝ type spec of non-name: error.
    numb←{⍴⍴⍵:⍺∘∇¨⍵ ⋄ ⍵∊⍺:⍺⍳⍵ ⋄ ⍵}      ⍝ conv ⍺, ⍵, ∊, ··· → 0, 1, 2,
    spec vars numb ⍵                    ⍝ type specification.
}

────────────────────────────────────────────────────────────────────────────────

reduce←{                                ⍝ Combinator reduction.

    eval←{                              ⍝ Value of @exp.
        ⍴⍴⍵:(∇ 1⊃⍵)apply 2⊃⍵            ⍝ function application.
        ~⍵∊tags:⍵                       ⍝ number, null or error.
        ⍵'',(tags⍳⍵)⊃defs               ⍝ function suspension.
    }                                   ⍝ exp ← :: exp

    apply←{                             ⍝ Function application.
        '?'≡⍺:'?'                       ⍝ bad function: error.
        0=⍴⍴⍺:(eval ⍺)∇ ⍵               ⍝ evaluate primitive function.
        tag rgs tmp def←⍺               ⍝ name, args, template, defn.
        args←rgs,⊂⍵                     ⍝ extended args vector.
        (⍴args)<⍴tmp:tag args tmp def   ⍝ too few args: suspension.
        tag∊'+-!':tag numb args         ⍝ primitive numeric function.
        tag∊'⊂↑↓∘':tag list args        ⍝ primitive list function.
        eval{                           ⍝ combinator:
            ⍴⍴⍵:'@',∇¨1↓⍵               ⍝ traverse definition,
            (tmp⍳⍵)⊃args,⍵              ⍝ substituting values.
        }def                            ⍝ combinator definition.
    }                                   ⍝ exp ← exp :: exp

    numb←{                              ⍝ Number primitive function.
        n←whnf⊃⍵                        ⍝ strictly numeric first arg.
        '?'=n:'?'                       ⍝ error: error.
        '+'=⍺:n+1                       ⍝ + succ
        '-'=⍺:n-1                       ⍝ - pred
        eval(1+×n)⊃⍵                    ⍝ ! nil?
    }                                   ⍝ exp ← op :: exp

    list←{                              ⍝ List primitive function.
        h←whnf⊃⍵                        ⍝ first arg to weak head.
        '?'≡h:'?'                       ⍝ error: error.
        '⊂'=⍺:↑{'@'⍺ ⍵}⍨/⌽⍺ h,1↓⍵       ⍝ ⊂ cons
        '↑'=⍺:{⍵≡'⍬':'?' ⋄ 1 2⊃⍵}h      ⍝ ↑ head
        '↓'=⍺:{⍵≡'⍬':'?' ⋄ 2⊃⍵}h        ⍝ ↓ tail
        eval(2-h≡'⍬')⊃⍵                 ⍝ ∘ null?
    }                                   ⍝ exp ← op :: exp

    whnf←{                              ⍝ Weak Head Normal Form.
        0=⍴⍴⍵:⍵                         ⍝ atom: done.
        4=⍴⍵:↑{'@'⍺ ⍵}⍨/⌽↑,/2↑⍵         ⍝ function suspension.
        '@⊂'≡2↑1⊃⍵:⍵                    ⍝ list construction: done.
        ∇ eval ⍵                        ⍝ re-evaluate.
    }                                   ⍝ exp ← :: exp

    tags defs←{                         ⍝ Combinator definition table.
        tags temp cdefs tdefs←⍵         ⍝ environment.
        mask←~tags∊'⍬?'                 ⍝ ignoring null and error.
        mask∘/¨tags(↓⍉↑temp cdefs)      ⍝ definition table for eval.
    }⍺                                  ⍝ environment.

    whnf ⍵                              ⍝ Reduce to whnf.
}

────────────────────────────────────────────────────────────────────────────────

show←{                                  ⍝ Display output from statement.

    stmt←{                              ⍝ evaluate each ⋄ segment.
        env rem←⍺                       ⍝ envt and remaining cols.
        '⋄'=⊃⍵:⍺ segs ⍵                 ⍝ separator: evaluate left to right.
        '⊤'=⊃⍵:⍺ typex ⍵                ⍝ type: display or set type.
        '='=⊃⍵:(env defn ⍵)rem          ⍝ definition: extend environment.
        '~'=⊃⍵:⍺ remove ⍵               ⍝ remove: compress environment.
        obj←(env dref'○')compile ⍵      ⍝ object code.
        '?'≡env type obj:⍺ put'?'       ⍝ type error: error.
        ⍺ expr env reduce env link obj  ⍝ show reduced expr.
    }                                   ⍝ env rem ← env rem :: exp

    segs←{                              ⍝ Eval left and right ⋄ segments.
        lft←⍺ stmt 1⊃⍵                  ⍝ envt and cols after left segt.
        sepr←(≢/1⊃¨⍺ lft)/', '          ⍝ separator if output from left.
        (lft put sepr)stmt 2⊃⍵          ⍝ envt and cols after right segt.
    }                                   ⍝ env rem ← env rem :: exp

    expr←{                              ⍝ Session-wide display.
        0=⍴⍴⍵:⍺ put('⍬'=⍵)⊃⌽'[]'(⍕⍵)    ⍝ Atom.
        _ fn arg←⍵                      ⍝ function and argument.
        '@⊂'≡2↑fn:(⍺ put'[')list ⍵      ⍝ list.
        fun←⍺ ∇ fn                      ⍝ envt and cols after function.
        0=⍴⍴arg:fun ∇ arg               ⍝ atomic argument: no parentheses.
        ((fun put'(')∇ arg)put')'       ⍝ show argument in parentheses.
    }                                   ⍝ env rem ← env rem :: exp

    list←{                              ⍝ list items.
        env rem←⍺                       ⍝ envt and remaining cols.
        rem=0:⍺                         ⍝ run off edge of session: quit.
        ⍵≡'?':⍺ put'?'                  ⍝ error: error.
        head←⍺ expr env reduce 1 2⊃⍵    ⍝ envt and cols after head.
        tlex←env reduce 2⊃⍵             ⍝ tail expression.
        tlex≡'⍬':head put']'            ⍝ tail null: end of list.
        (head put',')∇ tlex             ⍝ envt and cols after tail.
    }                                   ⍝ env rem ← env rem :: exp

    remove←{                            ⍝ Removal/retention of names.
        env rem←⍺                       ⍝ envt and remaining cols.
        keep←(⊃env){                    ⍝ names to retain.
            '~'=⊃⍵:⍺~alph∩⍺ ∇ 2⊃⍵       ⍝ remv: exclude name.
            '@'=⊃⍵:∊⍺∘∇¨1↓⍵             ⍝ accumulate names.
            (⍴⍴⍵)↓⊂⍵                    ⍝ atom: name or null.
        }⍵                              ⍝ [char] ← [char] :: exp
        renv←((⊃env)∊keep)∘/¨env        ⍝ reduced environment.
        renv rem put∊2↑¨⌽keep∩alph      ⍝ show remaining definitions.
    }                                   ⍝ env rem ← env rem :: rex

    link←{                              ⍝ Bind external refs from envt.
        ⍴⍴⍵:(⊃⍵),⍺∘∇¨1↓⍵                ⍝ scalar-wise:
        ~⍵∊alph:⍵                       ⍝ not a name: preserve.
        ⍺ dref ⍵                        ⍝ replaced with value from envt.
    }                                   ⍝ exp ← env :: exp

    put←{env rem←⍺ ⋄ env(rem sput ⍵)}   ⍝ Envt and remainder after put.
    sput←{rem←⍺⌊⍴,⍵ ⋄ ⍞←rem↑⍵ ⋄ ⍺-rem}  ⍝ Put string to session.
    dref←{↑⍵{(⍺⍳⍺⍺)⊃⍵,'?'}/1 0 1 0/⍺}   ⍝ Dereference from table.

    alph←const'alph'                    ⍝ definition alphabet.
    maxw←⎕PW-1                          ⍝ maximum output width
    env rem←⍺ maxw stmt ⍵               ⍝ new env and remaining cols.
    ⊃env 1 put(rem<maxw)/⊃⌽⎕TC          ⍝ newline after any output.
}

────────────────────────────────────────────────────────────────────────────────

trees←{                                 ⍝ Format [char;] ← :: exp
    0=≡⍵:⍕⍵                             ⍝ lonely leaf.
    ⍺←'┌─┐' ⋄ ll mm rr←⍺                ⍝ default line drawing chars.
    (0≡⊃0⍴⍵)∨(0≠≡⊃⍵)∨(,3)≢⍴⍵:⍺∘∇¨⍵      ⍝ not a tree: 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