APL/D Source Code:

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

trip←{⎕IO ⎕ML←1 0                       ⍝ Trip from/to ⍵ in network space ⍺.

    0=⍺.⎕NC'graph':⍺{                   ⍝ source not compiled for this space.
        ⎕←'compiling graph ...'         ⍝ explain slight delay.
        (compile ⍺)trip ⍵               ⍝ try again with compiled graph.
    }⍵

    access←⍺.((1=≡¨labels)/labels)      ⍝ access via station entrances.

    legs←{                              ⍝ start and end station indices.
        hits←∨/⍵⍷↑access                ⍝ stations containing supplied string.
        best←1+⊃⍋↑⍴¨hits/access         ⍝ best (tightest) fit.
        best⊃0,hits/⍳⍴hits              ⍝ index of chosen station.
    }¨⍵                                 ⍝ for each leg of the journey.

    0∊legs:'Can''t find: ',↑{           ⍝ misspelled station name:
        ⍺,' or ',⍵                      ⍝ (one or more stations)
    }/(0=legs)/⍵                        ⍝ give up :-(

    find←⍺.graph{⍺⍺ path ⍺ ⍵}           ⍝ find one leg of the route.
    route←↑{⍺,1↓⍵}/2 find/legs          ⍝ suggested route via all points.

    labels←⍺.labels[route]              ⍝ labels for all legs of route.

    masks←1 2=⊂≡¨labels                 ⍝ masks of stations and stops.
    stats stops←masks/¨⊂labels          ⍝ station and stop labels.

    zip←{↓⍉↑⍵}                          ⍝ transpose vector-of-vectors.
    cat←{↑,/⍵}                          ⍝ concatenate   ..      ..
    pad←{↓↑⍵}                           ⍝ pad vectors with blanks.

    slabs←cat¨zip pad¨zip stops         ⍝ aligned stop labels.
    ↑(stats,slabs)[⍋⍋2⊃masks]           ⍝ merged stations and stops.
}

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

compile←{⎕IO ⎕ML←1 0                    ⍝ Compile graph from ⍵.source.

    zip←{↓⍉↑⍵} ⋄ cat←{↑,/⍵}             ⍝ transpose/concatenate vec-of-vecs.

    lines stats ctrls←zip zip¨{         ⍝ first pass: source → line sections.
        vecs←{↓⎕FMT↑⍵}                  ⍝ normalise source to vector-of-vectors.
        rcom←{(∧\~'//'⍷⍵)/⍵}            ⍝ remove comments '// ···' from line.
        rbls←{(∨/¨' '≠⍵)/⍵}             ⍝ remove blanks lines: ''  '' ···
        segt←{(' '≠⊃¨⍵)⊂⍵}              ⍝ segment at non-blank first column.
        trim←{(∨\⍵≠' ')/⍵}{⌽⍺⍺⌽⍺⍺ ⍵}    ⍝ remove blanks, fore and aft.
        tupl←'+↓∊'{⍺(trim ⍵~⍺⍺)(⍺⍺∩⍵)}  ⍝ tupl: (line stat ctrl).
        tups←{(⊂trim⊃⍵)tupl¨1↓⍵}        ⍝ tuples: tupl tupl ···.
        tups¨segt rbls rcom¨vecs ⍵      ⍝ line segments.
    }⍵.source

    seqs←{(⍳¨⍵)+0,+\¯1↓⍵}               ⍝ sequence of sequences.
    csids←{⍵\¨seqs+/¨⍵}'+'∊¨¨ctrls      ⍝ stations marked as cross-tracks.
    stops←zip¨zip lines stats csids     ⍝ subway stops.
    plats←{↓⍵∘.,'^∨'}¨stops             ⍝ platform for each direction.
    slist←{⍵[⍋↑⍵]}∪cat stats            ⍝ sorted station list.
    verts←slist,∪cat cat plats          ⍝ graph vertices.
    platx←{↓verts⍳↑⍵}¨plats             ⍝ platform indices within graph.
    statx←{2/¨verts⍳⍵}¨stats            ⍝ station indices within graph.
    linex←{(∪⍵)⍳⍵}⊃¨lines               ⍝ line indices per segment.
    rests←'↓∊'∘∊¨¨ctrls                 ⍝ restrictions: 1-way sects and forks.

    plinks←cat¨2{                       ⍝ platform-to-platform links / section.
        links((ow fk)_)←zip ⍺ ⍵         ⍝ directions and restrictions.
        rev←{⌽⍵}\                       ⍝ reverse second pair.
        oway←{⍺:1↑⍵ ⋄ rev ⍵}            ⍝ one-way section.
        fork←{⍺:⌽zip rev ⍵ ⋄ zip ⍵}     ⍝ fork.
        ow oway fk fork links           ⍝ ⍺←→⍵ links.
    }/¨zip¨zip platx rests              ⍝ pairwise for each line section.

    clinks←((∪linex)=⊂linex)/¨⊂plinks   ⍝ link sections collected by line.

    llinks←cat↑{                        ⍝ connected sections for all lines.
        next←⍺~⍵                        ⍝ next section, duplicates removed.
        clash←↑∪zip∩⌿↑zip¨next ⍵        ⍝ incompatible directions.
        diffs←⍉¯1 1∘.×-/clash           ⍝ vertex index differences.
        avecs←↑+/,diffs×clash=⊂next     ⍝ adjustment vectors.
        (next+avecs),⍵                  ⍝ connected line subsections.
    }/¨clinks                           ⍝ for each section of each line.

    slinks←cat zip¨zip cat¨statx platx  ⍝ (stat plat) ··· links.
    elinks←0 1∘.⌽slinks                 ⍝ station-platform each-way links.
    nlinks←{⍵[⍋↑⍵]}∪(,elinks),llinks    ⍝ combined network-wide links.
    ⍵.graph←↑{(⍺≠¯1⌽⍺)⊂⍵}/zip nlinks    ⍝ network graph.

    stags←2/⌽¨2↑¨∪cat stops             ⍝ (stop line) label pairs.
    slabs←cat¨zip¨zip(⊂4 1↑¨⊂'')stags   ⍝ indented stop labels.
    ⍵.labels←slist,slabs                ⍝ station/stop labels.

    1:shy←⍵                             ⍝ shy result: namespace ref.
}

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

path←{                      ⍝ Shortest path from/to ⍵ in graph ⍺.
    graph←⍺                 ⍝ ⍺ is graph vector.
    fm to←⍵                 ⍝ starting and target vertex(ices).
    tree←¯2+(⍳⍴⍺)∊fm        ⍝ initial spanning tree.
    free←{(¯2=tree[⍵])/⍵}   ⍝ free vertices in ⍵.
    ⍬{                      ⍝ path accumulator.
        ⍵<0:(⍵=¯2)↓⍺        ⍝ root or unvisited vertex: finished.
        (⍵,⍺)∇ ⍵⊃tree       ⍝ otherwise: prefix previous (parent) vertex.
    }{                      ⍝ find partial spanning tree:
        ⍵≡⍬:¯1              ⍝ no vertices left: stitched.
        1∊to∊⍵:1↑⍵∩to       ⍝ found target: finished.
        next←free¨graph[⍵]  ⍝ next vertices to visit.
        back←↑,/⍵+0×next    ⍝ back links.
        wave←↑,/next        ⍝ vertex wave front.
        tree[wave]←back     ⍝ set back links in tree.
        ∇∪wave              ⍝ advance wave front.
    }fm                     ⍝ from starting vertex.
}

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

ed←{                    ⍝ Edit source for subway ⍵.
    _←'→'⍵.⎕ED'source'  ⍝ edit source.
    _←⍵.⎕EX'graph'      ⍝ force recompilation by removing: graph,
    _←⍵.⎕EX'labels'     ⍝ and vertex labels.
}

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

test←{                                  ⍝ Run test script: no news => good news.
    ⍺←0                                 ⍝ default: don't show progress.
    ⍵≡'':⍺ ∇ ⎕NL 2                      ⍝ null: test all scripts.
    2=⍴⍴⍵:⍺ ∇↓⍵                         ⍝ matrix: each row is a script.
    2=≡⍵:⍺ ∇¨⍵                          ⍝ nested: test each script.

    tag scr←{                           ⍝ name and content of script.
        ⎕PATH←''                        ⍝ isolate test.
        6::{'' ''}⎕←'No test.',⍵        ⍝ value error:: display message.
        ⍵(⍎⍵)                           ⍝ name and content.
    }⍵

    exec←{⎕ML←0                         ⍝ execute script lines in tmp space.
        0=⍴⍵:⍺                          ⍝ no more, finished.
        ⎕←show⊃⍵                        ⍝ show expression.
        exp←unc⊃⍵                       ⍝ uncommented first line.
        ''≡exp~' ':⍺ ∇ 1↓⍵              ⍝ ignore blank line.
        1∊'←{'⍷unq exp:⍺ ∇ dfn ⍵        ⍝ make local dfn.
        '←'∊unq exp:⍺ ∇ asgn ⍵          ⍝ make local var.
        act←tmp{6::0 0⍴'' ⋄ ⍺⍎⍵}exp     ⍝ actual result.
        ⎕←show act                      ⍝ show result.
        ok rem←act check 1↓⍵            ⍝ check against expected result.
        (⍺∧ok)∇ rem                     ⍝ check remaining script.
    }

    check←{⎕ML←0
        act←↓tmp.⎕FMT ⍺                 ⍝ actual result,
        exp←(⍴act)↑⍵                    ⍝ expected result,
        act≡exp:1,⊂(⍴act)↓⍵             ⍝ match: continue.
        dexp dact←dots¨exp act          ⍝ dots for spaces in,
        ⎕←tag,⊂dexp'→'dact              ⍝ display of differences.
        0,⊂(⍴act)↓⍵                     ⍝ and continue.
    }

    dfn←{                               ⍝ fix temp dfn.
        raw←unq∘unc¨⍵                   ⍝ raw code
        depth←+\{⊃⌽-⌿+\'{}'∘.=⍵}¨raw    ⍝ {}-nesting depth per line.
        lines←1++/∧\×depth              ⍝ no of lines in defn.
        _←tmp.⎕FX↑lines↑⍵               ⍝ fix dfn in temp space.
        ⎕←show↑1↓lines↑⍵                ⍝ show dfn body.
        lines↓⍵                         ⍝ continue with remaining lines.
    }

    nest←{⎕ML←0                         ⍝ split line vector,
        nl←⊃2↓⎕TC                       ⍝ at nl char into,
        1↓¨(1,⍵=nl)⊂nl,⍵                ⍝ vector of char vecs.
    }

    dots←{⎕IO←0                         ⍝ replace ' ' with '·' in diff display.
        sx←⎕AV⍳' '                      ⍝ index of space.
        to←(sx↑⎕AV),'·',1↓sx↓⎕AV        ⍝ [·/ ]⎕av
        ↑{(⎕AV⍳⍵)⊃¨⊂to}¨⍵               ⍝ translated value.
    }

    asgn←{_←tmp⍎⊃⍵ ⋄ 1↓⍵}               ⍝ assign local name.
    unq←{(~≠\''''=⍵){⍺\⍺/⍵}⍵}           ⍝ unquoted chars.
    unc←{(∧\'⍝'≠unq ⍵)/⍵}               ⍝ uncommented line.
    show←⍺∘{↑⍺/↓⎕FMT ⍵}                 ⍝ show progress.

    tmp←##.(⎕NS ⎕NL 3 4 9)              ⍝ tmp space for evaluation.
    ''≡scr:ok←0                         ⍝ bad script name.
    2=≡⍵:ok←1 exec scr                  ⍝ vector of vectors: go ahead,
    1:ok←1 exec nest scr                ⍝ split line vector.
}

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


Back to: contents