GitHub Lightshow - Toronto Toolkit.apl

⍝
⍝ Author:      Toronto ACM Special Interest Group (SIG) on APL and others
⍝ Date:        2015-7-19 and see toolkit.txt below
⍝ Copyright:   see files after ]NEXTFILE below
⍝ License:     see files after ]NEXTFILE below
⍝ Support email:
⍝ Portability:   L1 (ISO APL portability)
⍝
⍝ Purpose:
⍝ A collection of useful APL functions
⍝
⍝ Description:
⍝ This workspace is an adaptation of the Toronto Toolkit to GNU APL, kindly
⍝ provided by Fred Weigel. See also Fred's notes after ]NEXTFILE below
⍝

 ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝
⍝
⍝ ./toolkit 2015-07-19 06:19:28 (GMT-4)
⍝
 ⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝

⎕PW←10000

∇y←x adjust d;⎕IO;ex;i;line;lmrg;pw;w
 ⍝adjust each row of matrix <d> according to parameters <x>
 ⍝.e ('/' ∆box 'please do not  / enter') = 15 adjust 'please do not enter'
 ⍝.k formatting
 ⍝.n rml
 ⍝.t 1992.4.24.14.4.17
 ⍝.v 1.0 / 05jan82
 ⍝.v 2.0 / 05apr88 / change order of <x>, use subroutines
 ⍝.v 2.1 / 24apr92 / using signalerror
 ⍝ x[1] width of result in columns
 ⍝ x[2] width of left margin (i.e. number of blank columns)
 ⍝ x[3] number of blank lines to insert between each row
 ⎕IO←1
 'adjust' checksubroutine '∆dtb split'
 →(2<⍴⍴d)signalerror '/y/adjust rank error/right arg has rank greater than 2'
 d←(¯2↑1 1,⍴d)⍴d
 x←3↑x
 pw←x[1]
 lmrg←x[2]
 ex←x[3]
 ⍝result will have w columns
 w←pw-lmrg
 →(w<1)signalerror '/y/adjust domain error/text width (',(⍕w),') should be greater than 0'
 y←(0,w)⍴''
 i←0
 l1:→((1↑⍴d)<i←i+1)/end
 ⍝remove blanks at end of line
 line←∆dtb d[i;]
 ⍝if line is empty, treat as line (with one blank)
 y←y,[1]w split line,(0=⍴line)⍴' '
 →l1
 end:
 ⍝prepend lmrg blank columns
 y←(((1↑⍴y),lmrg)⍴' '),y
 ⍝insert ex blank lines between each row (except at bottom)
 y←(((-ex)+(1↑⍴y)×1+ex)⍴1,ex⍴0)⍀y
∇

∇Y←Funs after Ts;⎕IO;g∆sort∆columns;B;Tags
 ⍝get all functions in <Funs> with timestamp greater than <Ts>
 ⍝.e 'after' = ,'after' after 1989 1 1
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.23.0.31.11
 ⍝.v 1.0 / 19oct83
 ⍝.v 2.0 / 02may88 / added left argument
 ⍝.v 2.1 / 27mar92 / localized g∆sort∆columns and ⎕IO, simplified conversion
 ⍝<Funs> is namelist of functions
 ⎕IO←1
 Y←0 0⍴''
 Funs←'' ∆box ∆db,' ',Funs
 →L10 ∆if∼0∈⍴Funs
 Funs←⎕NL 3
 L10:
 ⍝-----get functions with non-empty t taglines
 Tags←'t' gettag Funs
 B←∨/Tags≠' '
 ⍝quit if all taglines are empty
 →(∼∨/B)/0
 Tags←B⌿Tags
 Funs←B⌿Funs
 ⍝-----make numeric, compare, and sort
 ⍝assume that all timestamps are well-formed (i.e. each with 6 numbers only)
 Tags←(10000,5⍴100)⊥⍉((1↑⍴Tags),6)⍴⍎,' ',(⍴Tags)⍴(Tags='.')⊖Tags,[0.5]' '
 Ts←(10000,5⍴100)⊥6↑Ts
 Y←(' ',⎕AV)sort(Ts≤Tags)⌿Funs
∇

∇y←amortize w;amortized;debt;i;interest;m;months;payment;rate;⎕IO
 ⍝amortization schedule based on <w> = debt, rate, months
 ⍝.e 1 50000 50625 50000 625 = ,amortize 50000 .15 1
 ⍝.k computation
 ⍝.t 1985.8.8.16.46.11
 ⍝source: adapted from the handbook of techniques (ibm)
 ⍝w[1] debt in total units (e.g. dollars)
 ⍝w[2] rate as yearly interest expressed as fraction
 ⍝       e.g. 10.5 per cent is .15
 ⍝w[3] time period in months
 ⍝<y> is 5 column matrix:
 ⍝(1)period (2)current debt (3)monthly payment (4)amortized (5)debt
 ⎕IO←1
 debt←w[1]
 rate←w[2]÷12
 months←w[3]
 m←(months,5)⍴i←0
 payment←debt×rate÷1-÷(1+rate)⋆months
 l10:→((debt≤0)∨i=1↑⍴m)/end
 i←i+1
 amortized←payment-interest←debt×rate
 m[i;]←i,debt,payment,amortized,interest
 debt←debt-amortized
 →l10
 end:
 y←m
∇

∇y←arabic x;⎕IO;a
 ⍝returns arabic (base 10) equivalent for character roman numeral <x>
 ⍝.e 14 = arabic 'xiv'
 ⍝.k translation
 ⍝.t 1992.3.28.18.15.14
 ⍝.v 1.0 / 04apr88
 ⍝.v 1.1 / 28may92 / signalerror used
 ⎕IO←1
 →(∼(⍴⍴x)∈0 1)signalerror '/y/arabic rank error'
 x←∆db x
 →(∼∧/x∈'ivxlcdm')signalerror '/y/arabic domain error'
 a←(1 5 10 50 100 500 1000)['ivxlcdm'⍳x]
 y←a+.ׯ1+2×a≥(a,0)[1+⍳⍴a]
∇

∇r←del array str;⎕IO;mask;p;shape
 ⍝general vector reshape. reshape vector <str> using delimiters <del>
 ⍝.e  2 3 4 = ⍴'/,' array 'fred,2,xx/joe,,zzz'
 ⍝.k reshape
 ⍝.n andreas werder
 ⍝.t 1988.4.8.3.11.42
 ⍝.v 1.0 / 15dec79
 ⎕IO←0
 r←0,(,del)∘.=str
 p←∨⍀((¯1↑⍴r)↑1),[0]r
 r←+\r,[0]∼(¯1,¯1↑⍴r)↑p
 r←r-⌈\p×0 ¯1↓0,r
 shape←1+⌈/r
 mask←(⍳×/shape)∈shape⊥r
 r←((-⍴shape)↑1)↓shape⍴mask\' ',str
∇

∇Z←J bal N;⎕IO;M;T
 ⍝display balance (nesting levels) in lines <J> of function <N>
 ⍝.e 'bal[21]'=7⍴21 bal 'bal'
 ⍝.k programming-tools
 ⍝.t 1992.4.4.14.52.37
 ⍝.v 1.0 / 18apr88
 ⍝.v 2.0 / 04apr92 / switched args, simplified function, using signalerror
 ⎕IO←1
 'bal' checksubroutine 'on balance'
 ⍝ ----- left argument
 →(' '≠1↑0⍴N)signalerror '/Z/bal domain error/right arg not character.'
 →(3≠⎕NC N)signalerror '/Z/bal domain error/(',N,') not a function.'
 M←⎕CR N
 →(0∈⍴M)signalerror '/Z/bal domain error/function (',N,') locked.'
 ⍝ ----- right argument
 J←,J
 →((⌈/J)>¯1+1↑⍴M)signalerror '/bal index error/right arg greater than last line number ',⍕¯1+1↑⍴M
 Z←0 1⍴''
 L10:
 →(0=⍴J)/Lend
 Z←Z on(N,'[',(⍕J[1]),']')on(balance M[1+J[1];])on ' '
 J←1↓J
 →L10
 Lend:
 ⍝remove separator line after last display
 Z←¯1 0↓Z
∇

∇y←balance n;⎕IO;k;km;l;m;ma;mb;t;xt
 ⍝display balance (nesting levels) in text vector <n>
 ⍝.e (2 13⍴'(...)⍴(...),x 5,2   2↑y   ') = balance '(5,2)⍴(2↑y),x'
 ⍝.k formatting
 ⍝.t 1992.4.4.15.15.42
 ⍝.v 1.0 / 18apr88
 ⍝.v 1.1 / 04apr92 / improved arg checking
 ⎕IO←0
 →(0 1∧.≠⍴⍴n)signalerror '/y/balance rank error/right arg not rank 0 or 1.'
 n←,n
 n←(-(' '≠⌽n)⍳1)↓n
 l←n
 k←l=''''
 l[(≠\k)/⍳⍴l]←' '
 ⍝
 t←l∈'(['
 m←(+\t)-+\l∈')]'
 xt←k\(+/k)⍴1 ¯1
 ma←((-1=xt)++\xt)+m-t
 mb←ma-⌊/ma
 ⍝
 km←⌈/mb
 n←(-mb)⊖n,[0](km,⍴n)⍴'.'
 y←(⍴n)⍴((⍳1+km)∘.>mb)⊖n,[¯0.5]' '
∇

∇r←cs base text;⎕IO
 ⍝encodes <text> to an integer using collating sequence <cs>
 ⍝.e 13='abcd' base 'cd'
 ⍝.k translation
 ⍝.t 1992.3.28.18.26.54
 ⍝.v 1.0 / 15jul83
 ⍝.v 1.1 / 15apr88 / matrix argument allowed for <text>
 ⍝,v 1,2 / 28mar92 / signalerror used.
 ⍝each row of <text> will be encoded into an integer
 ⎕IO←1
 →(2<⍴⍴text)signalerror '/r/base rank error'
 r←text
 →(0∈⍴text)/0
 text←(¯2↑1 1,⍴text)⍴text
 ⍝collating sequence <cs> defaults to ⎕AV
 cs←((0∈⍴cs)/⎕AV),(∼0∈⍴cs)/cs
 ⍝allow for unknown characters to be mapped into 1+⍴cs
 r←(1+⍴cs)⊥⍉¯1+cs⍳text
∇

∇y←a beside b;row
 ⍝catenate array <a> to array <b> (maximum rank 2) on last coordinate
 ⍝.e (4 3⍴'abbabba  a  ') = 'aaaa' beside 2 2⍴'b'
 ⍝.k catenation
 ⍝.t 1989.7.23.21.57.52
 ⍝.v 1.1 / 24apr88 (vector treated as 1-column matrix, not 1-row)
 a←(2↑(⍴a),1 1)⍴a
 b←(2↑(⍴b),1 1)⍴b
 row←⌈/1 0 1 0/(⍴a),⍴b
 y←((row,¯1↑⍴a)↑a),(row,¯1↑⍴b)↑b
∇

∇r←sep box1 x;len;m;pos;⎕IO
 ⍝return matrix <r> from vector <x> delimited by separator <sep>
 ⍝.e (3 5⍴'applebettycat  ') = '/' box1 'apple/betty/cat'
 ⍝.k reshape
 ⍝.t 1985.9.22.11.21.22
 ⍝.v 1.1 / 13jul83
 ⍝note: <sep> is a one-character vector specifying separator character
 ⍝      box1 always fills with blank/zero
 ⎕IO←1
 r←0 0⍴x
 →(0∈⍴x)/0
 ⍝sep=separator character; default is blank/zero
 sep←(1 0=0∈⍴sep)/(1↑0⍴x),1↑sep
 ⍝append separator only if no ending separator
 ⍝one trailing sep (e.g. 'apple/betty/cat/') does not make extra line
 x←x,(sep≠¯1↑x)/sep
 pos←(x=sep)/⍳⍴x
 m←⌈/len←¯1+pos-0,¯1↓pos
 r←((⍴len),m)⍴(,len∘.≥⍳m)\(x≠sep)/x
 ⍝note:  append this line to delete 'extra' rows caused by multiple sep
 ⍝ r←(∨/len∘.≥⍳m)/[1]r
∇

∇y←w boxf v;m;⎕IO
 ⍝box fields. <y[i;]> is a field of vector <v> specifed by width <w[i]>
 ⍝.e (3 5⍴'applebettycat  ') = 5 5 3 boxf 'applebettycat'
 ⍝.k reshape
 ⍝.t 1989.7.23.23.32.16
 ⍝.v 1.1 / 14jul83
 ⎕IO←1
 ⍝ensure v has +/w elements, else algorithm fails.
 v←(+/w)↑v
 m←⌈/w
 y←((⍴,w),m)⍴(,w∘.>(⍳m)-⎕IO)\v
∇

∇y←bp x
 ⍝search for 'break points' based on beginning of identical sequences in <x>
 ⍝.e 1 0 1 0 0 1 0 0 0 0 = bp 'aabbbccccc'
 ⍝.k searching
 ⍝.t 1992.3.19.11.48.59
 ⍝.v 1.0 / 18jul83
 ⍝treat vector as n×1 matrix (each element is a row)
 x←(2↑(⍴x),1 1)⍴x
 y←1,¯1↓∨/x≠1⊖x
∇

∇Y←S browse X;⎕IO;C;Flag;I;J;Text
 ⍝list occurrences of string <S> (name or any string) in functions <X>
 ⍝.k programming-tools
 ⍝.n rml
 ⍝.t 1992.4.22.23.12.1
 ⍝.v 1.0 / 22apr92
 ⍝format of search string <S> is: n=string, s=string, string
 ⍝example:  'n=X' browse 'ff'; 'abc' browse 'ff'
 ⍝result <Y> is report showing function lines containing string <S>
 ⎕IO←1
 'browse' checksubroutine 'on ss ssn ∆dtb'
 X←'' ∆box ∆db,' ',X
 ⍝browse type is arbitrary string (s=) or name (n=)
 C←2 2⍴'s=n='
 ⍝compute browse type <Flag> (default is S)
 Flag←1↑(,(C∧.=2↑S)⌿C),'s'
 ⍝remove browse type specification if present
 S←(2×∨/C∧.=2↑S)↓S
 Y←('... browsing with (',Flag,'=',S,')')on ''
 J←0
 L10:
 →((1↑⍴X)<J←J+1)/Lend
 Text←⎕CR X[J;]
 →((3≠⎕NC X[J;]),0∈⍴Text)/Err1,Err2
 ⍝find locations <I> of search string <S> in ravelled <Text>
 ⍝<ssn> and <ss> take vector args. delimiter ⎕AV[1] avoids line run-on.
 →('ns'=Flag)/Ln,Ls
 Ln:I←(,Text,⎕AV[1])ssn S
 →Lsend
 Ls:I←(,Text,⎕AV[1])ss S
 →Lsend
 Lsend:
 ⍝ignore 'not found'. not necessary, confusing when common, report too long
 →(0=⍴I)/L10
 ⍝convert to row numbers (subtract 1, encode, add 1 to rows - ignore columns)
 I←(1+(1+⍴Text)⊤¯1+I)[1;]
 ⍝remove duplicate row numbers
 I←((I⍳I)=⍳⍴I)/I
 ⍝select rows and label with line number
 Text←(⍕((⍴I),1)⍴I-1),' ',Text[I;]
 L30:
 ⍝label result <Text> with function name, search type, and search string
 Y←Y on('... ',X[J;],'  (',Flag,'=',S,')')on Text on 1 0⍴''
 →L10
 Lend:
 ⍝remove trailing blank lines after last Text, and trailing blanks
 Y←∆dtb ¯1 0↓Y
 →0
 Err1:Text←'... not a defined function.'
 →L30
 Err2:Text←'... locked function.'
 →L30
∇

∇Y←catoffun X;g∆sort∆columns;T
 ⍝return categories represented by functions <X>
 ⍝.e 'library-utility' = ,catoffun 'catoffun'
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.23.0.33.25
 ⍝.v 1.0 / 22may85
 ⍝.v 1.1 / 22apr92 / using new version of <sort>
 ⍝<X> is a vector or matrix of function names
 X←'' ∆box ∆db,' ',X
 T←'k' gettag X
 Y←(' ',⎕AV)sort(bp T)⌿T
∇

∇y←cdays n;⎕IO;d;m;p;r
 ⍝convert Gregorian day counts <n> to date format (mm dd yyyy)
 ⍝.e 5 13 1988 = ,cdays 725870
 ⍝.k date
 ⍝.t 1992.4.9.16.47.9
 ⍝.v 1.0 / 17may77
 ⍝.v 2.0 / 09apr92 / changed name from <dates> to <cdays>
 ⍝convert a day count (starting from 1/1/1) to format (mm dd yyyy)
 ⍝assume use of Gregorian calendar from 1/1/1
 ⎕IO←1
 d←,n
 y←(⌊(364+d)÷365.242499999999893)∘.+0 1
 m←(0,[0.0999999999999999778]4 100 400)⊤y
 p←=⌿0=m[2;;;]
 m←(365×y-1)+-⌿m[1;;;],[1]p
 r←d>m[;2]
 d←d-,0 ¯1↓r⌽m
 p←(r⌽p)[;1]
 d←30+d+(d>59+p)×2-p
 m←⌊d÷30.5599999999999916
 d←d-⌊30.5599999999999916×m
 y←((⍴n),3)⍴m,d,0 ¯1↓r⌽y
∇

∇Y←S change X;⎕IO;C;Flag;J;Text;Z
 ⍝change occurrences of Text (name or any string) in functions <X>
 ⍝.k programming-tools
 ⍝.n rml
 ⍝.t 1992.4.22.23.12.51
 ⍝.v 1.0 / 25apr88 / change names only, one function only
 ⍝.v 2.0 / 22apr92 / args switched, name or substring, many functions
 ⍝format of change specification <S> is: n=/old/new, S=/old/new, /old/new
 ⍝example:  'n=/X/y' change 'ff'; '/abc/xyz' change 'ff'
 ⍝result <Y> is summary report of changes
 ⍝underscored variable names to avoid name shadowing
 ⎕IO←1
 'change' checksubroutine 'on sr srn ss ssn'
 X←'' ∆box ∆db,' ',X
 ⍝change type is arbitrary string (s=) or name (n=)
 C←2 2⍴'s=n='
 ⍝compute change type <Flag> (default is 's')
 Flag←1↑(,(C∧.=2↑S)⌿C),'s'
 ⍝remove change type specification if present
 S←(2×∨/C∧.=2↑S)↓S
 ⍝define first line of report
 Y←'... changing with (',Flag,'=',S,')'
 J←0
 L10:
 →((1↑⍴X)<J←J+1)/0
 Text←⎕CR X[J;]
 →((3≠⎕NC X[J;]),0∈⍴Text)/Err1,Err2
 ⍝substitute new Text for old (name or arbitrary substring)
 ⍝<ssn> and <ss> have vector arguments, ⎕AV[1] is line delimiter
 →('ns'=Flag)/Ln,Ls
 Ln:Text←(,Text,⎕AV[1])srn S
 →Lsend
 Ls:Text←(,Text,⎕AV[1])sr S
 →Lsend
 Lsend:
 Z←⎕FX ⎕AV[1]∆box Text
 →(0=1↑0⍴Z)/Err3
 Text←'... ok (',Z,')'
 L30:
 ⍝report with function name and result
 Y←Y on X[J;],' ',Text
 →L10
 Err1:Text←'... not a defined function.'
 →L30
 Err2:Text←'... locked function.'
 →L30
 Err3:Text←'... not changed (⎕FX = ',(⍕Z),')'
 →L30
∇

∇Y←checksize List;⎕IO;Data;I;T
 ⍝return report showing sizes of objects in <List>, sorted by size
 ⍝.e 1=4⍴=⌿checksize 'checksize'
 ⍝.k programming-tools
 ⍝.n rml
 ⍝.t 1989.7.27.23.19.7
 ⎕IO←1
 'checksize' checksubroutine 'vtype'
 Y←⍳0
 →(2=⍴⍴List)/L10
 List←'' ∆box ∆db(,' ',List)
 L10:
 →(0∈⍴List)/0
 I←0
 L20:→((1↑⍴List)<I←I+1)/L20end
 →((2=⎕NC List[I;])∧2≠⎕SVO List[I;])/L20a
 →(3=⎕NC List[I;])/L20b
 ⍝some other object. assign size 0.
 Y←Y,0
 →L20
 L20a:
 Data←⍎List[I;]
 Y←Y,0.125 1 4 8[vtype Data]××/⍴Data
 →L20
 L20b:
 ⍝this is a close-enough approximation for our purposes
 Y←Y,+/' '≠,⎕CR List[I;]
 →L20
 L20end:
 ⍝compute total line and label it
 Y←(+/Y),Y
 List←'-',[1]List
 ⍝sort
 T←⍒Y
 ⍝report
 Y←(⍕((1↑⍴List),1)⍴Y[T]),' ',List[T;]
∇

∇N checksubroutine L;B;F
 ⍝check workspace for subroutines <L> used by function <N>
 ⍝.k programming
 ⍝.t 1988.4.28.1.42.16
 ⍝.v 1.0 / 28apr88
 ⍝.v 2.0 / 03apr92 / function suspends within itself, issues )pcopy message
 ⍝example:  'func' checksubroutine 'f1 f2 f3'
 B←3=⎕NC F←'' ∆box ∆db,' signalerror ',L
 →(∧/B)/0
 ⎕←'... ',N,' subroutine warning'
 ⎕←'... (1) please copy the toolkit functions listed below into this workspace.'
 ⎕←'... (2) resume execution.'
 ⎕←'      )pcopy toolkit ',∆db,' ',(∼B)⌿F
 ⎕←'      →⎕LC'
 ⍝the next line may have to be modified with ⎕stop in this APL system
 s∆checksubroutine←1+1↑⎕LC
 Suspend: ⍝suspend here, copy functions, resume execution here
∇

∇z←cjulian js;c;d;j;k;m;s;y
 ⍝convert Julian day numbers <js> to (mm dd yyyy style)
 ⍝.e (2 4⍴5 12 1988 1 5 17 1977 1) = cjulian 2447294 2443281
 ⍝.k date
 ⍝.t 1992.4.6.2.34.29
 ⍝.v 1.0 / 15apr78
 ⍝<js>
 ⍝   scalar or vector of julian dates
 ⍝   an n×2 array, where js[;1]=julian dates, js[;2]=styles
 js←(2↑(⍴js),1 1)⍴js
 j←js[;⎕IO]
 s←(j>2423434)∨(j>2299171)∧(js,2361221<j)[;⎕IO+1]
 j←j-1684595
 c←⌊j÷36524.25
 j←j+((∼s)×(2-c)+⌈c÷4)-⌈36524.25×c
 y←⌊(j+1)÷365.25024999999988
 j←j+31-⌊365.25×y
 d←j-⌊30.5874999999999915×m←⌊j÷30.5874999999999915
 m←m+2-12×k←⌊m÷11
 z←m,d,(k+y+100×c-1),[⎕IO+0.5]s
∇

∇Y←comments X;⎕IO;M
 ⍝return header and header comments (i.e. initial comments) in function <X>
 ⍝.e 9 = 1↑⍴comments 'comments'
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.16.17.31.3
 ⍝.v 1.0 / 24jul89
 ⍝.v 2.0 / 16apr92 / formerly function <header>
 ⍝underscored variables to avoid shadowed names
 ⎕IO←1
 'header' checksubroutine '∆dtb on'
 →(∼(⍴⍴X)∈0 1)signalerror '/Y/comments rank error/right arg not rank 0 or 1'
 →(3≠⎕NC X)signalerror '/Y/comments domain error/function (',X,') not in workspace.'
 M←⎕CR X
 Y←(∧\M[1;]≠';')/M[1;]
 M←1 0↓M
 Y←∆dtb Y on(∧\M[;1]='⍝')⌿M
∇

∇y←d condense v;b
 ⍝remove redundant blanks and blanks around characters specified in <d>
 ⍝.d 1985.6.20.10.10.10
 ⍝.e 'apple,betty,cat,,dog' = ',' condense '  apple, betty, cat, , dog'
 ⍝.k delete-characters
 ⍝.t 1992.3.10.20.19.23
 ⍝.v 1.1
 ⍝v is character vector (rank 1) only
 ⍝remove leading, trailing, and multiple internal blanks
 y←∆db,v
 ⍝remove blanks around characters specified in <d>
 ⍝e.g. if <d> =<,>, blanks are removed around commas in 'a , b , d'
 b←y∈d
 y←(∼(y=' ')∧(1⌽b)∨¯1⌽b)/y
∇

∇y←d condense1 x;b
 ⍝remove redundant blanks and blanks around characters specified in <d>
 ⍝.d 1985.6.20.10.10.10
 ⍝.e 'apple,''betty  ,  cat'',,dog' = ',' condense1 'apple, ''betty  ,  cat'', , dog'
 ⍝.k delete-characters
 ⍝.t 1992.3.10.20.28.58
 ⍝.v 1.1
 ⍝note: same as condense, but does not remove blanks within quotes
 ⍝remove leading, trailing, multiple internal blanks, but not in quotes
 b←' '≠x←' ',x
 ⍝note: ≠\ is the same as 2|+\
 y←1↓((≠\''''=x)∨b∨1⌽b)/x
 ⍝remove blanks around delimiters, not in quotes
 b←y∈d
 y←((≠\''''=y)∨∼(y=' ')∧(1⌽b)∨¯1⌽b)/y
∇

∇Y←contents X;⎕IO;BL;Heads;How;I;J;Keys;N;Purpose;S;T
 ⍝formatted report of functions <X> by category (with line 1 and header)
 ⍝.e (100⍴'-') ∧.= 100↑(contents '∆box')[2;]
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.16.12.3.17
 ⍝.v 1.0 / 20jul83
 ⍝.v 1.1 / 15may89 / ⎕IO localized, checksubroutine added
 ⍝.v 1.2 / 16apr92 / name changes, simplifications, performance improvements
 ⍝report is useful for any functions (even without category information)
 ⎕IO←1
 'contents' checksubroutine 'bp gettag gradeup on ∆dtb'
 Y←0 1⍴''
 X←'' ∆box ∆db,' ',X
 →(0∈⍴X)/0
 Keys←'k' gettag X
 ⍝first sort by X
 S←'' gradeup X
 X←X[S;]
 Keys←Keys[S;]
 ⍝second sort by Keys (ensure that blank is sorted to the beginning)
 S←(' ',⎕AV)gradeup Keys
 X←X[S;]
 Keys←Keys[S;]
 ⍝now get headers and purpose line for report (in order of X)
 Heads←0 gettag X
 Purpose←1 gettag X
 ⍝clean Heads (remove characters after ';', i.e. list of local variables)
 I←,∧\Heads≠';'
 Heads←(⍴Heads)⍴I\I/,Heads
 ⍝compute breakpoints of Keys
 N←bp Keys
 ⍝for each function determine if how variable is in workspace.
 ⍝then change to ⋆ or blank.
 How←2=⎕NC(((1↑⍴X),3)⍴'how'),X
 How←' ⋆'[1+How]
 ⍝now prepare report
 I←0
 l10:→((⍴N)<I←I+1)/End
 →(∼N[I])/l20
 ⍝print title of category. precede each title by <BL> blank lines
 BL←2
 Y←Y on((BL,0)⍴'')on Keys[I;]on 100⍴'-'
 l20:
 ⍝delete trailing blanks from name of function.
 ⍝extend name to 10 spaces or nearest multiple of 3 if
 ⍝not enough space to fit name
 T←⍴∆dtb X[I;]
 J←10⌈((T+2)>10)×3×⌈(2+T)÷3
 Y←Y on '  ',How[I],' ',(J↑X[I;]),(∆dtb Heads[I;]),'.  ',1↓Purpose[I;]
 →l10
 End:
 ⍝remove blank lines before title of first category
 Y←(BL,0)↓Y
∇

∇Y←contents1 X;⎕IO;How;I;Keys;S
 ⍝quick condensed report of functions <X> by category (with line 1)
 ⍝.e 5=1↑⍴contents1 '∆box ∆db foofunc'
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.16.11.22.1
 ⍝.v 1.0 / 23may85
 ⍝.v 1.1 / 14apr92 / function rewritten, comments clarified, how var ⋆ added
 ⍝report lists (category, function, purpose) sorted by function within category
 ⎕IO←1
 'contents1' checksubroutine 'bp expandbe gettag gradeup on ∆dtb'
 Y←0 0⍴''
 X←'' ∆box ∆db,' ',X
 →(0∈⍴X)/0
 Keys←'k' gettag X
 ⍝sort by function
 S←(' ',⎕AV)gradeup X
 X←X[S;]
 Keys←Keys[S;]
 ⍝sort again by category. (data will be sorted by function within category.)
 S←(' ',⎕AV)gradeup Keys
 X←X[S;]
 Keys←Keys[S;]
 ⍝find break points (beginning of each category)
 I←bp Keys
 ⍝determine if how variable is in workspace. then change to ⋆ or blank.
 How←' ⋆'[1+2=⎕NC(((1↑⍴X),3)⍴'how'),X]
 ⍝now get line 1 (purpose line) and remove leading comment symbol,
 ⍝catenate with function names, and category names without duplicates,
 ⍝insert a blank line before each new category, remove first blank line
 Y←1 0↓(expandbe I)⍀(I⍀I⌿Keys),How,X,' ',0 1↓1 gettag X
∇

∇z←cpucon;ot
 ⍝returns elapsed cpu and connect time since function last executed
 ⍝.e 1 ∆ cpucon
 ⍝.k timing
 ⍝.t 1992.3.28.15.21.51
 ⍝.v 1.0 / 20oct83
 ⍝check for old time (ot)
 ⍎(0=⎕NC 'g∆cpucon∆ot')/'g∆cpucon∆ot←⎕AI'
 ot←g∆cpucon∆ot
 ⍝cpu,connect is ⎕AI[2 3]
 ⍝find cpu and connect since last call
 z←(2↑1↓⎕AI)-2↑1↓ot
 ⍝reset global
 g∆cpucon∆ot←⎕AI
∇

∇y←date
 ⍝return today's date in format (monthname dd, yyyy)
 ⍝.e 1 ∆ date
 ⍝.k date
 ⍝.t 1992.4.9.10.28.25
 ⍝.v 1.0 / 19nov86
 ⍝.v 1.1 / 09apr92 / replace detailed code with call to <fdate>
 'date' checksubroutine 'fdate'
 y←'e' fdate ⎕TS[2 3 1]
∇

∇y←days d;⎕IO;n;p
 ⍝compute Gregorian day count for dates <d> = (mm dd yyyy)
 ⍝.e 725870 = days 5 13 1988
 ⍝.k date
 ⍝.t 1992.4.9.16.30.9
 ⍝.v 1.0 / 17may77
 ⍝.v 1.1 / 09apr92 / using signalerror
 ⍝<d> can be 3-element vector (1 date), or matrix of dates
 ⍝<y> is number of days elapsed from 1/1/1 to <d>
 ⎕IO←1
 d←(¯2↑1 1,⍴d)⍴d
 →(3≠¯1↑⍴d)signalerror '/y/days length error/last coordinate of right arg not equal to 3.'
 n←(0,[0.0999999999999999778]4 100 400)⊤d[;3]
 p←=⌿0=n[2;;]
 n←(365×d[;3]-1)+-⌿n[1;;],[1]p
 y←n+d[;2]+(⌊30.5599999999999916×d[;1])-30+(d[;1]≥3)×2-p
∇

∇y←ddup x
 ⍝delete duplicate elements from vector or matrix <x>
 ⍝.e 'abcd' = ddup 'aabbccddaabb'
 ⍝.k delete-elements
 'ddup' checksubroutine 'first'
 y←(first x)⌿x
∇

∇Y←Code deltag Fns;⎕IO;Fn;I;J;Mat;T
 ⍝delete tag line labelled with <Code> from functions <Fns>
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1989.7.24.18.17.10
 ⍝.v 1.0 / 04nov83
 ⍝.v 1.1 / 24jul89 / error message changes, ⎕IO localized
 ⎕IO←1
 Y←⍳0
 ⍎(2≠⍴⍴Fns)/'Fns←'' '' ∆box ∆db Fns'
 ⍝----- do it for every function
 J←0
 L10:→((J←J+1)>1↑⍴Fns)/End
 Mat←⎕CR Fn←Fns[J;]
 ⍝----- make sure Mat has at least one line
 →((0=1↑⍴Mat)/L15),L0
 ⍝no line. cannot get cr.
 L15:
 ⎕←'...deltag domain error.'
 ⎕←'...cannot get canonical form for ',Fn
 →Blend
 L0: ⍝this Mat has at least one line. search for tag line
 I←Mat[;⍳4]∧.='⍝.',2↑Code
 →(0=∨/I)/L1
 ⍝found it. so remove it and fix function
 T←⎕FX(∼I)⌿Mat
 →(0≠1↑0⍴T)/Lend
 ⎕←'...deltag error'
 ⎕←'...error when fixing function = ',Fn,'  line = ',(⍕T),'  ',Mat[T;]
 →Blend
 L1: ⍝did not find it. so skip it
 →Lend
 Lend:
 Y←Y,1
 →L10
 Blend:
 Y←Y,0
 →L10
 End:
∇

∇describe;⎕IO;x
 ⍝driver menu function for overall description of toolkit workspace
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.27.14.50.40
 ⍝.v 1.0 / 27apr92
 ⎕IO←1
 l10:
 ⎕←' '
 ⎕←howdescribeindex
 x←⎕
 →l10 ∆if 0=(∼x∈0,⍳9)signalerror '//Please enter a listed topic number.'
 →0 ∆if x=0
 ⍝delete potential leading blank (in case APL implementation appends it)
 ⎕←⍎'howdescribe',∆db⍕x
 →l10
∇

∇describe∆cr2lf
 'cr2lf string'
 ' '
 'converts cr (13) characters in string to lf (10). Old APL2'
 'used cr to terminate lines, while GNU APL needs lf (unix'
 'convention).'
∇

∇y←dfh x;⎕IO;n
 ⍝return decimal values of hex numbers <x>
 ⍝.e 10 274 = dfh 2 3⍴'00a112'
 ⍝.k translation
 ⍝.t 1992.4.16.21.9.44
 ⍝.v 1.0 / 00sep85
 ⍝.v 1.1 / 12apr88 / arg checking and reshaping improved
 ⍝.v 1.2 / 16apr92 / signalerror used
 ⍝each hex number is one row of a matrix
 ⍝warning: hex numbers must be zero-padded on the right if necessary
 ⎕IO←0
 →((⍴⍴x)>2)signalerror '/y/dfh rank error/right arg greater than rank 2'
 →(0∈⍴y←x)/0
 x←(¯2↑1 1,⍴x)⍴x
 y←16⊥'0123456789abcdef'⍳⍉x
∇

∇r←rcm dimension m;⎕IO;c;j;k;l;z
 ⍝compute (n-1) dimension array from coordinate/data matrix <m>
 ⍝.k reshape
 ⍝.n dan king
 ⍝.t 1992.4.25.17.36.18
 ⍝.v 1.0 / 23may85
 ⍝.v 1.1 / 25apr92 / using signalerror
 ⍝<m> has (n-1) attribute columns and 1 data column
 ⎕IO←1
 →((¯1↑⍴m)<2)signalerror '/r/dimension length error/last coordinate of right arg < 2'
 →((1↑⍴rcm)≠¯1+¯1↑⍴m)signalerror '/r/dimension length error/left and right args not conformable.'
 c←1
 z←0 1⍴0
 do:
 m←(m[;c]∈rcm[c;])⌿m
 j←rcm[c;]⍳m[;c]
 ⍝
 j←(¯2↑1 1,⍴j)⍴j
 z←(¯2↑1 1,⍴z)⍴z
 k←⌈/(⍴j)[2],(⍴z)[2]
 z←(((1↑⍴z),k)↑z),[1]((1↑⍴j),k)↑j
 ⍝
 →((¯1↑⍴m)≥1+c←c+1)/do
 z←z-1
 z[1↑⍴z;]←z[1↑⍴z;]+1
 j←+/rcm≠0
 k←j⊥z
 l←(×/j)⍴0
 l[k]←(0,¯1+¯1↑⍴m)↓m
 r←j⍴l
∇

∇y←e displayfunction a;⎕IO;b;n;r;z
 ⍝display of canonical matrix <a> using exdents <e>
 ⍝.e 'display'=7↑13↓20⍴4 displayfunction ⎕CR 'displayfunction'
 ⍝.k formatting
 ⍝.t 1992.3.13.20.59.55
 ⍝.v 1.0 / 13may88
 ⍝.v 2.0 / 13mar92 / new left argument, more comments, removed displayfunction1
 ⍝<e> = exdents for comments, branches, labels respectively
 ⎕IO←1
 y←0 0⍴''
 →(0∈⍴a)/0
 a←(¯2↑1 1,⍴a)⍴a
 ⍝compute left argument with defaults (defaults are usual system settings)
 e←e,(×/⍴e)↓1 0,1↑e,1
 ⍝compute location b of labelled lines (contains : not in quotes or comment)
 z←a=':'
 b←∨/z
 b←(a[;1]≠'⍝')∧b\(+/∨\b⌿z)>+/∨\''''=b⌿a
 ⍝compute rotations for comment lines, branch lines, labelled lines
 r←(e[1]×a[;1]='⍝')+(e[2]×a[;1]='→')+e[3]×b
 ⍝compute line numbers and rotations for 1-digit, 2-digit, etc.
 n←¯1+1↑⍴a
 z←n↑((n⌊9)⍴2),(0⌈90⌊n-9)⍴1
 ⍝form the complete function display
 y←((' ',[1]'[',z⌽(3 0⍕(n,1)⍴⍳n),']'),r⌽(((1↑⍴a),⌈/e)⍴' '),a),[1]' '
 y[1,n+2;5]←'∇'
∇

∇r←u dround v;e;n;⎕CT;⎕IO
 ⍝distributive rounding of a vector <v> to arbitrary scalar unit <u>
 ⍝.e (.01 dround +/100.982 100.973 100.966) = +/.01 dround 100.982 100.973 100.966
 ⍝.k computation
 ⍝.t 1989.7.23.22.15.9
 ⎕CT←⎕IO←0
 v←,v÷u
 e←1|v
 n←(⌊0.5++/v)-+/⌊v
 r←u×(⌊v)+n>⍋⍒e
∇

∇z←ds x;⎕IO
 ⍝set of descriptive statistics for data <x>
 ⍝.e 5.5 = (ds ⍳10)[2]
 ⍝.k computation
 ⍝.n k.w.smillie
 ⍝.t 1992.4.14.21.21.1
 ⍝.v 1.0 / 15feb69 / original Statpack2 version slightly modified
 ⎕IO←1
 z←10⍴0
 z[1]←⍴x←x[⍋x]
 z[2]←(+/x)÷z[1]
 z[3]←(+/(x-z[2])⋆2)÷z[1]-1
 z[4]←z[3]⋆0.5
 z[5]←z[4]÷z[1]⋆0.5
 z[6]←(+/|x-z[2])÷z[1]
 z[7]←0.5×+/x[(⌈z[1]÷2),1+⌊z[1]÷2]
 z[8 9]←x[z[1],1]
 z[10]←-/z[8 9]
∇

∇dstat x;z
 ⍝labelled set of descriptive statistics for data <x>
 ⍝.k computation
 ⍝.n k. w. smillie
 ⍝.t 1992.4.14.21.26.39
 ⍝.v 1.0 / 15feb69 / original Statpack2 version slightly modified
 'dstat' checksubroutine 'ds'
 z←ds x
 'sample size.......... ',⍕z[1]
 'mean................. ',⍕z[2]
 'variance............. ',⍕z[3]
 'standard deviation... ',⍕z[4]
 'standard error....... ',⍕z[5]
 'mean deviation....... ',⍕z[6]
 'median............... ',⍕z[7]
 'maximum.............. ',⍕z[8]
 'minimum.............. ',⍕z[9]
 'range................ ',⍕z[10]
∇

∇y←a duparray m;⎕IO;newarray;shape
 ⍝duplicate array <m>.  duplicate <a[1]> times along coordinate <a[2]>
 ⍝.e (2 6⍴'abababcdcdcd') = 3 2 duparray 2 2⍴'abcd'
 ⍝.k reshape
 ⍝.n rml
 ⍝.t 1992.4.25.17.28.1
 ⍝.v 1.0 / 14feb84
 ⍝.v 1.1 / 25apr92 / using signalerror
 ⍝a[2] must be in the range (1,⍴⍴m)
 ⍝note: the algorithm consists of applying <reparray> to
 ⍝ (1,⍴m)⍴m and then reshaping the result.
 ⎕IO←1
 'duparray' checksubroutine 'reparray'
 ⍝default a[2] to last coordinate
 a←2↑a,⍴⍴m
 →(∼(1≤a[2])∧a[2]≤⍴⍴m)signalerror '/y/duparray domain error/coordinate specification (',(⍕a[2]),') outside range (1,',(⍕⍴⍴m),')'
 newarray←a reparray(1,⍴m)⍴m
 shape←×/(⍴m),[1.5](a[2]≠⍳⍴⍴m)+(a[2]=⍳⍴⍴m)×a[1]
 y←shape⍴newarray
∇

∇y←n duparray1 m
 ⍝duplicate array <m>. duplicate <n> times along coordinate 1
 ⍝.e (6 2⍴'abcdabcdabcd') = 3 duparray1 2 2⍴'abcd'
 ⍝.k reshape
 ⍝.n rml
 ⍝.v 1.0 / 10feb84
 ⍝simplified version of duparray which handles first dimension only
 y←((n×1↑⍴m),1↓⍴m)⍴(n,⍴m)⍴m
∇

∇z←easter ys;c;epact;g;n;s;x;y
 ⍝compute date of Easter (mm dd yyyy) for years <ys> = (yyyy style)
 ⍝.e 4 15 1990 = ,easter 1990
 ⍝.k date
 ⍝.t 1992.4.5.23.19.47
 ⍝.v 1.0 / 05may88
 ⍝.v 1.1 / 05apr92 / matrix result in format (mm dd yyyy), signalerror used
 ⍝ys can be a vector of years or an array of years and styles.
 ys←(2↑(⍴ys),1 1)⍴ys
 y←ys[;⎕IO]
 →(y∨.<33)signalerror '/z/easter domain error/Easter was not celebrated before 33 A.D.'
 s←(y>1922)∨(y>1583)∧(ys,1752<y)[;⎕IO+1]
 c←1+⌊0.00999999999999999674×y
 x←s×2-⌊0.75×c
 g←1+19|y
 epact←30|20+(s×10+⌊0.319999999999999896×c-15)+x+11×g
 n←44-epact+s×(epact=24)∨(epact=25)∧g>11
 n←n+30×n<21
 n←n+7-7|n+7|x+⌊1.25×y
 ⍝n[i] represents day of easter within march or april for ys[i;]
 ⍝return decoded matrix with z[i;] in format mm dd yyyy
 z←⍉(3,⍴n)⍴((3×n≤30)+4×n≥31),(1+31|¯1+n),y
∇

∇Y←X example N;⎕IO;B;C;I;L;Name;R;Result;Trace
 ⍝display and execute an example for functions <N>. <X> specifies options.
 ⍝.e '1' = (2 example '∆box')[1;1]
 ⍝.k library-utility
 ⍝.t 1992.4.16.20.11.31
 ⍝.v 1.0 / 12apr88 / terminal output and result of example line of one function
 ⍝.v 2.0 / 15jul89 / first version of example with explicit result
 ⍝.v 3.0 / 16apr92 / combined <test> and <example>, new left arg
 ⍝<example> executes the .e example for each function in the list <N>.
 ⍝<X> specifies options for trace messages and result.
 ⍝X=1 -- display trace, X=2 -- return report, X=3 -- do both, X=0 -- do neither
 ⍝Note two situations:
 ⍝(1) if execution suspends, the function or the example could be wrong.
 ⍝(2) if an error is noted, then something is wrong enough to give an
 ⍝    incorrect result, but not bad enough to cause suspension.
 ⍝in either case, the example in question caused the problem and should be
 ⍝reviewed.  either the example or the function code could be the
 ⍝cause of the problem.  if <example> successfully executed examples for other
 ⍝functions, it is unlikely that there is an error in <example> itself.
 ⎕IO←1
 ⍝check and decode left arg (an encoding of 2-element binary vector)
 X←1↑X,1
 →(∼∧/X∈0,⍳3)signalerror '/Y/example domain error/left arg not a member of 0 1 2 3'
 X←,2 2⊤X
 Trace←X[2]
 Result←X[1]
 ⍝
 Y←0 1⍴''
 N←'' ∆box ∆db,' ',N
 I←0
 L10:
 →((1↑⍴N)<I←I+1)/0
 Name←N[I;]
 ⍝L is blank line if function locked, not found, or no example 'e' found
 L←,'e' gettag Name
 →Skip1 ∆if∼Trace
 ⎕←Name
 →Skip1 ∆if∧/L=' '
 ⍝example text indented 6 positions in apl terminal style
 ⎕←'      ',L
 Skip1:
 →L15 ∆if 3≠⎕NC Name
 →L20 ∆if∧/L=' '
 ⍝execute exampleline.  exampleline should have form: result = expression
 ⍝∧/,examplelline  returns 1 if the expression gives the result we expect
 ⍝if it returns 0 or suspends, check it out!  function or example may be wrong.
 B←⍎L
 →(1 0=∧/,B)/Lok,Lnok
 Lok:
 R←'1: ',L
 C←'... ok'
 →L99
 Lnok:
 R←'0: ',L
 C←'... example returns unexpected result.  review function ',Name
 →L99
 L15:
 R←'9: function ',Name,' not found.'
 C←'... ',3↓R
 →L99
 L20:
 R←'8: no .e example found in ',Name
 C←'... ',3↓R
 →L99
 L99:
 ⍝non-empty explicit result depends on option chosen
 →L100 ∆if∼Result
 Y←Y on R
 L100:
 ⍝do not display ending message if trace is off
 ⍝note: to suppress display of ok ending message, append ∨'1'=1↑R to line
 →L10 ∆if∼Trace
 ⎕←'      ',C
 →L10
∇

∇r←expandaf w
 ⍝<r> is expansion vector to insert <w[i]⍴0> after the i-th position
 ⍝.e 1 0 2 0 0 3 0 0 0 = (expandaf 1 2 3 )\1 2 3
 ⍝.k expansion
 ⍝.t 1988.4.5.18.44.4
 ⍝.v 1.0 / 12may88
 'expandaf' checksubroutine 'expandbe'
 r←¯1↓expandbe 0,w
∇

∇r←expandbe w
 ⍝<r> is expansion vector to insert <w[i]⍴0> before the i-th position
 ⍝.e 0 1 0 0 2 0 0 0 3 = (expandbe 1 2 3 )\1 2 3
 ⍝.k expansion
 ⍝.t 1988.4.5.18.44.4
 ⍝.v 1.0 / 12may88
 r←(⍳⍴w)++\w
 r←(⍳¯1↑r+∼⎕IO)∈r
∇

∇Y←explain X;⎕IO;I
 ⍝explain functions <x>. return how documents for specified functions
 ⍝.e 1 ∆ explain '∆box'
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.1.23.59.18
 ⍝.v 2.0 / 22may85 / first published version
 ⍝.v 2.1 / 14jul89 / revised based on explain and makedoc
 ⍝.v 3.0 / 01apr92 / no longer using <script> and script documents
 ⍝underscored variables to avoid shadowing function names
 ⍝how documents are vectors delimited by returns (<g∆cr>)
 ⎕IO←1
 Y←''
 X←'' ∆box ∆db,' ',X
 I←0
 L10:
 →((1↑⍴X)<I←I+1)/Lend
 →((3≠⎕NC X[I;]),(2≠⎕NC 'how',X[I;]),1)/L2nf,L2nh,L2ok
 L2nf:
 Y←Y,X[I;],': function not in workspace.'
 →L2end
 L2nh:
 Y←Y,X[I;],': how document not in workspace.'
 →L2end
 L2ok:
 Y←Y,⍎'how',X[I;]
 →L2end
 L2end:
 ⍝2 blank lines after each document
 Y←Y,2⍴g∆cr
 →L10
 Lend:
 ⍝remove the two blank lines after last document
 Y←¯2↓Y
∇

∇Buffer←fagl X;⎕IO;B
 ⍝find all global referents in function <X> and functions called by <X>
 ⍝.e '⎕EX'=3⍴fagl 'signalerror'
 ⍝.k programming-tools
 ⍝.t 1992.4.4.13.31.48
 ⍝.v 1.0 / 30jul89
 ⍝.v 1.1 / 04apr92 / improved arg checking and passing to fglr, signalerror used
 ⍝requires ⎕IO←1 because of <gradeup>
 ⎕IO←1
 'fagl' checksubroutine 'fgl fglr global gradeup on ∆rowmem'
 →(0 1∧.≠⍴⍴X)signalerror '/Buffer/fagl rank error/right arg not rank 0 or 1.'
 →(3≠⎕NC X)signalerror '/Buffer/fagl domain error/(',X,') not a function.'
 →(0∈⍴⎕CR X)signalerror '/Buffer/fagl domain error/function (',X,') locked.'
 Buffer←0 0⍴''
 ⍝<fglr> requires matrix argument
 fglr(1,⍴X)⍴X
 Buffer←Buffer['' gradeup Buffer;]
∇

∇z←fcpucon x;a;b;con;cpu;⎕IO
 ⍝format cpu and connect time integers <x>
 ⍝.e 1 ∆ fcpucon cpucon
 ⍝.k timing
 ⍝.t 1989.7.31.9.6.27
 ⍝.v 1.0 / 20oct83
 ⎕IO←1
 cpu←,0 60000⊤x[1]
 con←,0 60000⊤x[2]
 ⍝format minutes to a minimum of two spaces (99)
 a←(-2⌈⍴a)↑a←,⍕cpu[1]
 b←(-2⌈⍴b)↑b←,⍕con[1]
 z←'cpu=',a,' m  ',(6 3⍕cpu[2]÷1000),' s       connect=',b,' m  ',(6 3⍕con[2]÷1000),' s'
∇

∇y←lc fdate t;⎕IO;mo
 ⍝format dates <t> = (mm dd yyyy) as <y> = (monthname dd, yyyy)
 ⍝.e 'november 19, 1986' = ,'e' fdate 11 19 1986
 ⍝.k date
 ⍝.t 1992.4.5.23.15.29
 ⍝.v 1.0 / 19nov86
 ⍝.v 2.0 / 05apr92 / right arg now matrix (mm dd yyyy), added language code
 ⍝<t> is vector or matrix of dates in format (mm dd yyyy)
 ⍝<lc> is language code. 'e'=english, 'f'=french
 ⎕IO←1
 ⍝reshape arg <t> to matrix (possibly one-row)
 t←(¯2↑1 1,⍴t)⍴t
 ⍝check months (for one argument check, this is as good as any!)
 →(∼∧/t[;1]∈⍳12)signalerror '/y/fdate domain error/right arg (month) not in the set ⍳12'
 →(∼lc∈'ef')signalerror '/y/fdate domain error/left arg (language code) not in the set (ef).'
 ⍝define month names in specified language.
 mo←'january/february/march/april/may/june/july/august/september/october/november/december'
 →(lc='e')/next
 mo←'janvier/fevrier/mars/avril/mai/juin/juillet/aout/septembre/octobre/novembre/decembre'
 next:mo←'/' ∆box mo
 ⍝create character matrix, ravel, remove redundant blanks, recreate matrix
 y←'/' ∆box ∆db,mo[t[;⎕IO];],' ',(⍕t[;,⎕IO+1]),',',' ',(⍕t[;,⎕IO+2]),'/'
∇

∇y←fdmy t;⎕IO;mon
 ⍝format dates <t> = (mm dd yyyy) as <y> = (dd mon yy)
 ⍝.e '20 jun 47' = ,fdmy 6 20 1947
 ⍝.k date
 ⍝.n rml
 ⍝.t 1992.4.9.9.18.48
 ⍝.v 1.0 / 31oct83
 ⍝.v 2.0 / 09apr92 / right arg now matrix in format (mm dd yyyy)
 ⎕IO←1
 ⍝reshape arg <t> to matrix (possibly one-row)
 t←(¯2↑1 1,⍴t)⍴t
 ⍝check months (for one argument check, this is as good as any!)
 →(∼∧/t[;1]∈⍳12)signalerror '/y/fdmy domain error/right arg (month) not in the set ⍳12'
 mon←12 3⍴'janfebmaraprmayjunjulaugsepoctnovdec'
 ⍝get last 2 digits of each year (e.g. 1947 is 47). ensure 1-column matrix
 ⍝create character matrix, one row for each date, in new format
 y←(2 0⍕t[;,2]),' ',mon[t[;1];],' ',2 0⍕⍉(100 100⊤t[;3])[,2;]
∇

∇Z←fgl X;T
 ⍝find global referents of function <X>
 ⍝.e '⎕CR' = 3↑(fgl 'fgl')[⎕IO;]
 ⍝.k programming-tools
 ⍝.t 1992.3.27.21.34.19
 ⍝.v 1.0 / 05may88 / first version
 ⍝.v 1.1 / 30jul89 / better right arg checking
 ⍝.v 1.2 / 27mar92 / revised error checking, signalerror used
 'fgl' checksubroutine 'global'
 →(0 1∧.<⍴⍴X)signalerror '/Z/fgl rank error/right arg not rank 0 or 1.'
 →(3≠⎕NC X)signalerror '/Z/fgl domain error/(',X,') not a function.'
 T←⎕CR X
 →(0∈⍴T)signalerror '/Z/fgl domain error/function (',X,') locked.'
 ⍝X must be exactly the name of the function (no blanks)
 Z←((X≠' ')/X)global T
∇

∇fglr X;Y
 ⍝subroutine.  find global referents recursively for objects specified in <X>
 ⍝.k programming-tools
 ⍝.t 1992.4.4.13.44.53
 ⍝.v 1.0 / 30jul89
 ⍝.v 1.1 / 04apr92 / minor changes to arg passing and comments
 ⍝recursive subroutine for <fagl>
 ⍝<X> is always a matrix (possibly empty)
 →(0∈⍴X)/0
 →(1 0=1=1↑⍴X)/L1,L2
 L1:
 ⍝one name
 X←,X
 ⍝global referent may be a variable, not function.  quit now.
 →(3≠⎕NC X)/0
 ⍝global referent may be a locked function.  can't go further. quit now.
 →(0∈⍴⎕CR X)/0
 Y←fgl X
 ⍝if names already on buffer, remove them.
 ⍝this situation occurs if there is a recursive global referent, that is,
 ⍝some function calls another function recursively at some level.
 Y←(∼Y ∆rowmem Buffer)⌿Y
 Buffer←Buffer on Y
 ⍝a recursive step!
 ⍝get global referents for all the global objects found
 fglr Y
 →0
 L2:
 ⍝more than one name
 ⍝a recursive step!
 ⍝ (1) get global referents of first object
 ⍝ (2) get global referents of all the other objects
 fglr X[,⎕IO;]
 fglr 1 0↓X
∇

∇r←fi a;m;⎕IO
 ⍝fix (translate) text input <a> to numeric vector
 ⍝.e 1 2 0 0 123.35 = fi '1 2 1a 3.3.3 123.35'
 ⍝.k translation
 ⍝.n jeffrey multach
 ⍝.t 1989.7.27.23.11.43
 ⍝.v 1.0 / dec80
 ⎕IO←1
 'fi' checksubroutine 'vi'
 r←vi ' ',a
 →(∧/0=r)/0
 ⍝form mask for characters to convert
 m←a≠' '
 m←m>0,¯1↓m
 ⍝mask out and convert valid numbers
 r[r/⍳⍴r]←⍎(≠\m\r[1],(1↓r)≠¯1↓r)/a
∇

∇m←a fibspiral b;c
 ⍝fibonacci spiral. choose neighbouring pairs <a>,<b> from fibonacci series
 ⍝.e (3 5⍴' ○○  ○  ○ ○○  ○ ') = 3 fibspiral 5
 ⍝.k graphics
 ⍝.t 1985.9.20.19.37.50
 ⍝choose <a>,<b> ∈ 1 1 2 3 5 8 13 21 34 ... where a immediately precedes b
 c←'○'
 →(a>1)/l1
 m←1 2⍴c
 →0
 l1:m←(b-a)fibspiral a
 m←⊖⍉m
 m←m,(a,a)⍴c,a⍴' '
∇

∇a←n field m;i;j
 ⍝subroutine for <tower>
 ⍝.k plotting
 ⍝return 'ground' or 'field' for the tower chart
 a←((7×n)+1,17×m)⍴' '
 j←1+i←0
 l1:
 a[1+7×n-i;(i×7)+⍳m×17]←'_'
 →(n≥i←i+1)/l1
 l2:
 a[(7×n)+2-j;j,j+17×⍳m]←'/'
 →((7×n)≥j←j+1)/l2
∇

∇z←m findcoords s;coord;match
 ⍝find coordinates of sequence <s> in matrix <m>
 ⍝.e (6 2⍴1 2 1 3 3 1 4 2 4 3 6 1) = (6 5⍴'applebettypie  ') findcoords 'p'
 ⍝.k searching
 ⍝.t 1989.7.27.22.15.47
 ⍝use outer product to find every occurrence of substring present in matrix.
 ⍝if substring is present, there will be a sequence of 1's in the first
 ⍝dimension, that is, result[1;x;y], result[1;x;y+1], result[1;x;y+2] etc.,
 ⍝will be 1.
 match←(,s)∘.=m
 ⍝the phrase (...)⌽match lines up sequences.  each successive row is
 ⍝rotated one more than the previous row.
 ⍝the phrase ∧⌿ finds if there were any sequences.
 coord←∧⌿(⍉(⌽¯1↓⍴match)⍴-⎕IO-⍳⍴,s)⌽match
 z←⎕IO+⍉(⍴coord)⊤-⎕IO-(,coord)/⍳⍴,coord
∇

∇y←a findut b;z
 ⍝find position of unique truncation <b> in vector <a>
 ⍝.e 4=' apple betty cat boop' findut 'bo'
 ⍝.k searching
 ⍝.n j.p. benyi
 ⍝.t 1992.4.16.20.57.36
 ⍝.v 1.0 / 00xxx74
 ⍝<y> =¯1: not unique; =0: not found; >0: index of <b> in <a>
 ⍝<a> must contain fields each preceeded by a blank: ' xxx xxx xxxxx xx'
 b←,b
 z←(1-⍴b)↓a
 z←(z=1↑b)/⍳⍴z
 z←(a[z+y←¯1]=' ')/z
 z←(a[z∘.+¯1+⍳⍴b]∧.=b)/z
 →(1<⍴z)/0
 y←' '+.=(1↑z)↑a
∇

∇y←first x
 ⍝first occurrence of elements in scalar, vector or matrix <x>
 ⍝.e 1 1 1 0 0 0 = first 6 5⍴'applebettycat  '
 ⍝.k searching
 ⍝.t 1992.4.3.17.28.14
 ⍝.v 1.0 / 07apr88
 ⍝.v 1.1 / 03apr92 / improved comments, signalerror used, scalar arg allowed
 →(0 1 2∧.≠⍴⍴x)signalerror '/y/first rank error'
 →(0 1 2=⍴⍴x)/l1,l1,l2
 l1:
 ⍝ for vectors this is the often-used algorithm (x←,x allows scalar case)
 x←,x
 y←(x⍳x)=⍳⍴x
 →0
 l2:
 ⍝ x∧.=⍉x   compute comparison matrix
 ⍝     <⍀   turn off all 1's after first 1 in each column.
 ⍝          (first 1 in row i indicates x[i;] is first occurrence).
 ⍝          (all 1's after first 1 indicate second, etc. occurrence).
 ⍝     ∨/   select all rows containing a 1.
 ⍝ y[i]=1   indicates that x[i;] is first occurrence
 y←∨/<⍀x∧.=⍉x
 →0
∇

∇y←fisodate t;⎕IO
 ⍝format dates <t> = (mm dd yyyy) as <y> = (yyyy-mm-dd)
 ⍝.e '1992-04-09' = ,fisodate 4 9 1992
 ⍝.k date
 ⍝.t 1992.4.9.9.58.55
 ⍝.v 1.0 / 22sep85
 ⍝.v 2.0 / 09apr92 / added matrix right arg, name change (isodate->fisodate)
 ⍝iso format is yyyy-mm-dd, with leading zeros if necessary
 ⎕IO←1
 ⍝reshape arg <t> to matrix (possibly one-row)
 t←(¯2↑1 1,⍴t)⍴t
 ⍝check months (for one argument check, this is as good as any!)
 →(∼∧/t[;1]∈⍳12)signalerror '/y/fisodate domain error/right arg (month) not in the set ⍳12'
 y←(4 0⍕t[;,3]),'-',(2 0⍕t[;,1]),'-',2 0⍕t[;,2]
 ⍝replace spaces by zeros everywhere in matrix
 y←(⍴y)⍴(' '=y)⊖y,[0.5]'0'
∇

∇y←fixuparray data;⎕IO
 ⍝return character matrix representation of array <data>
 ⍝.e (5 2⍴'abcd  abcd') = fixuparray 2 2 2⍴'abcd'
 ⍝.k formatting
 ⍝.n rml
 ⍝.t 1992.3.19.3.32.14
 ⍝.v 1.0 / 23may85
 ⍝.v 1.1 / 04apr88 / remove trailing blank row
 ⍝.v 1.2 / 19mar92 / clarify comments and replace <matrix> with statement
 ⎕IO←1
 y←⍕data
 →(0 1 2=⍴⍴y)/l10,l10,end
 ⍝y has rank 3 or greater. append blank row to each plane of y.
 y←y,[¯1+⍴⍴y]' '
 ⍝reshape y to the equivalent matrix (this is the algorithm of <matrix>)
 y←((×/¯1↓⍴y),¯1↑1,⍴y)⍴y
 ⍝drop trailing blank row
 y←¯1 0↓y
 →end
 l10:y←(¯2↑1 1,⍴y)⍴y
 end:
∇

∇Y←E fnlist T;⎕IO;I;Name;Text
 ⍝function lister. display functions in list <T> using spacing parameters <E>
 ⍝.k programming-tools
 ⍝.t 1992.4.4.11.50.32
 ⍝.v 2.0 / 20sep85
 ⍝.v 2.1 / 02may88 / spacing between functions in report changed
 ⍝.v 2.2 / 04apr92 / ⎕ output changed to explicit result, left arg added
 ⍝<T> namelist of functions
 ⍝<E> (1) lines between functions, (2)- parameters for <displayfunction>
 ⍝example:  '' fnlist 3  ⍝display all functions in workspace using defaults
 ⎕IO←1
 ⍝default E[1]=1; let <displayfunction> compute its own defaults if needed
 E←E,(×/⍴E)↓1
 Y←0 0⍴''
 ⍝ Text is list of <fnlist> subroutines used twice below
 'fnlist' checksubroutine Text←'displayfunction gradeup on ∆rowmem'
 T←'' ∆box ∆db,' ',T
 →(∼0∈⍴T)/Lnext
 ⍝ get list of ⎕NL 3 and remove all <fnlist> toolbox functions from list
 Text←'' ∆box Text,' fnlist checksubroutine signalerror ∆box ∆db'
 T←⎕NL 3
 T←(∼T ∆rowmem Text)⌿T
 Lnext:
 ⍝ sort function list
 T←T['' gradeup T;]
 ⍝ display all functions in list
 I←0
 L1:
 →((1↑⍴T)<I←I+1)/Lend
 Text←⎕CR Name←∆db T[I;]
 →((3≠⎕NC Name),(0∈⍴Text),1)/L2nf,L2nd,L2f
 L2nf:Text←'... name (',Name,') not a function.'
 →L2end
 L2nd:Text←'... function (',Name,') not displayable (probably locked).'
 →L2end
 L2f:Text←(1↓E)displayfunction Text
 →L2end
 L2end:
 ⍝ append specified number of blank lines after each function listing
 Y←Y on Text on(E[1],0)⍴''
 →L1
 Lend:
 ⍝ remove appended blank lines after last function
 Y←(-E[1],0)↓Y
∇

∇y←frame x
 ⍝frame (i.e. surround) an array <x> with a character
 ⍝.k library-utility
 ⍝.t 1992.3.10.20.44.14
 y←'(',x,')'
∇

∇t←ftime ts;⎕IO
 ⍝return time of day <ts> (⎕TS format) in format hh:mm:ss (am/pm)
 ⍝.e '06:20:21 am' = ftime 6 20 21
 ⍝.k time
 ⍝.t 1992.4.22.22.14.5
 ⍝.v 1.0 / 31oct83
 ⍝.v 1.1 / 22apr92 / clarified comments
 ⎕IO←1
 ⍝ts[1 2 3] = hh mm ss
 ⍝change ts[1] to t[1 2] where t[1]=0(morning) or 1(afternoon)
 ⍝and t[2]=0 to 11 hours in morning or afternoon.
 t←(2 12⊤ts[1]),ts[2 3]
 ⍝change hour 0 to 12 (12 noon or 12 midnight).
 t[2]←t[2]+12×t[2]=0
 t←1+10,(2,6⍴10)⊤(⍳0)⍴100⊥t
 ⍝format minutes and seconds with zeros before single-digit numbers
 t←'0123456789:'[t[3 4 1 5 6 1 7 8]],' ','ap'[t[2]],'m'
∇

∇Y←N funsincat X;⎕IO;g∆sort∆columns;B;Keys;Rc
 ⍝list of functions in <n> belonging to categorys specified in <x>
 ⍝.e 'funsincat' ∧.= ('funsincat' funsincat 'library-utility')[1;]
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.23.0.51.34
 ⍝.v 1.0 / 22may85
 ⍝.v 2.0 / 02may88 / added left argument
 ⍝.v 2.1 / 23apr92 / sort blank first, internal rewrite, enhanced right arg
 ⍝<X> is one wildcard name specification for the category names
 ⍝<N> is namelist of functions
 ⎕IO←1
 'funsincat' checksubroutine 'gettag gradeup on sort vnames wildcard ∆dtb'
 ⍝empty N defaults to ⎕NL 3 (since ⎕NL 3 and maybe N are large matrices, use ⍎)
 ⍝N all blanks will become empty
 N←'' ∆box ∆db,' ',⍎((0∈⍴N)/'⎕NL 3'),(∼0∈⍴N)/'N'
 Rc←vnames X←∆db,' ',X
 →(1≠⍴Rc)signalerror '/Y/funsincat domain error/right arg contains more than one name specification.'
 →(0∈Rc)signalerror '/Y/funsincat domain error/right arg contains invalid wildcard specification.'
 Y←0 0⍴''
 →(0∈⍴N)/0
 Keys←'k' gettag N
 ⍝B[i]=1 means the .k tag-line for function i is non-blank
 B←' '∨.≠⍉Keys
 →(∼∨/B)/0
 ⍝sort the functions whose .k key belongs to list <X>
 ⍝consider only non-blank keys to avoid unnecessary computation
 ⍝ensure blank comes first in collating sequence when sorting function names
 ⍝all columns will be sorted
 Keys←B⌿Keys
 N←B⌿N
 Y←(' ',⎕AV)sort ∆db(Keys wildcard X)⌿N
∇

∇Y←X gettag M;⎕IO;Cr;I;L;Tag
 ⍝get line containing tag X (or line X if numeric) for functions in M
 ⍝.e  'library-utility' = ,'k' gettag 'gettag'
 ⍝.k library-utility
 ⍝.t 1992.3.30.1.12.22
 ⍝.v 1.0 / 28apr88
 ⍝.v 1.1 / 24jul89 / ensure cr has sufficient columns for processing
 ⍝.v 1.2 / 30mar92 / return last occurrence of a tag line (esp for v tags)
 ⎕IO←1
 'gettag' checksubroutine 'on ∆dtb'
 Y←0 0⍴''
 M←'' ∆box ∆db,' ',M
 ⍝compute actual tag phrase (⍝.k  ⍝.n  ... ) allow for numeric X
 Tag←'⍝.',(⍕X),' '
 L1:→(0∈⍴M)/End
 Cr←⎕CR M[1;]
 →(∼0∈⍴Cr)/Lok
 ⍝return blank line if function not found or locked
 L←' '
 →L10
 Lok:
 ⍝do special processing for numeric X
 →(0=1↑0⍴X)/Tagn
 ⍝----- search for position of (last occurrence of) Tag line
 ⍝Cr may not have sufficient columns.  extend using ↑
 ⍝editor's note:  the next line is a good line to inspect using <bal>!
 I←(⌽<\⌽(((1↑⍴Cr),⍴Tag)↑Cr)∧.=Tag)⍳1
 →(1 0=I≤1↑⍴Cr)/L03,L04
 L03:L←4↓Cr[I;]
 →L10
 L04:L←' '
 →L10
 ⍝----- get line X
 Tagn:
 ⍝does canonical form contain line X? (refer to header as line X=0)
 →(1 0=(1↑⍴Cr)≥1+X)/L06,L05
 L05: ⍝this function does not have line X
 L←' '
 →L10
 L06:L←Cr[1+X;]
 →L10
 ⍝----- append tagline L to matrix of tag lines
 L10:
 Y←Y on L
 M←1 0↓M
 →L1
 End:
 Y←∆dtb Y
 ⍝if Y is empty, then extend Y with a column of blanks
 Y←((1↑⍴Y),(1 0=0∈⍴Y)/1,¯1↑⍴Y)↑Y
∇

∇Y←getvtag M;⎕IO;Cr;Tag
 ⍝get tag lines identified by .v for function <M>
 ⍝.e  1=1⍴⍴getvtag 'getvtag'
 ⍝.k library-utility
 ⍝.t 1992.4.16.21.57.39
 ⍝.v 1.0 / 16apr92
 ⎕IO←1
 Y←0 0⍴''
 Tag←'⍝.v '
 Cr←⎕CR M
 ⍝return empty if function not found or locked
 →(0∈⍴Cr)/0
 ⍝Cr may not have sufficient columns.  extend using ↑
 Y←∆db 0 4↓((((1↑⍴Cr),4)↑Cr)∧.=Tag)⌿Cr
∇

∇g←f global m;⎕IO;b;l;w;x
 ⍝global referents in canonical form <m> of function <f>
 ⍝.e '⎕CR'=3⍴'fgl' global ⎕CR 'fgl'
 ⍝.k programming-tools
 ⍝.n roger hui
 ⍝.t 1988.4.30.18.24.1
 ⍝.v 1.0 / jun80
 ⎕IO←1
 g←',',m
 l←g[1;]
 l←(-+/∧\⌽l∈' ')↓l
 x←⌽(¯1+l⍳';')↑l
 l[(⍳⍴f)+(⍴x)-(⍴f)+(' '∈x)×x⍳' ']←' '
 b←≠\g∈''''
 b←b⍱∨\b<g∈'⍝'
 l←l,';⎕;',(,⌽∨\⌽b∧g∈':')/,g
 w←' ⎕abcdefghijklmnopqrstuvwxyz∆ABCDEFGHIJKLMNOPQRSTUVWXYZ⍙0123456789'
 g←l,(1↓⍴g)↓(,b)/,g
 x←g∈1↓w
 g←1↓(x∨1⌽x)/g
 f←(∼b←g∈1↓w)/⍳⍴g
 x←¯1+⌈/f←(f,1+⍴g)-0,f
 g←((⍴f),x)⍴(,f∘.>⍳x)\b/g
 b←⍳1↑⍴g←(g[;1]∈¯10↓w)⌿g
 l40:
 b←b[⍋w⍳g[b;x]]
 →(×x←x-1)⍴l40
 g←g[b;]
 f←l∈1↓w
 g←((b>f+.>1⌽f)∧∨/g≠¯1⊖g)⌿g
 g←(' '∨.≠g)/g
∇

∇y←cs gradeup m;⎕IO;c;i
 ⍝gradeup vector for character <m> based on collating sequence <cs>
 ⍝.e 4 3 2 1 = '' gradeup 4 5⍴'dog  cat  bettyapple'
 ⍝.k sorting
 ⍝.t 1992.4.14.22.2.49
 ⍝.v 1.0 / 15sep85
 ⍝.v 1.1 / 27jul89 / rank error check, minor name changes
 ⍝.v 1.2 / 14apr92 / signalerror used
 ⍝sorts vector or matrix <m> column by column
 ⎕IO←1
 y←⍳0
 →(0∈⍴m)/0
 →(∼(⍴⍴m)∈1 2)signalerror '/y/gradeup rank error/right arg not rank 1 or 2'
 cs←((0=×/⍴cs)/⎕AV),(0≠×/⍴cs)/cs
 ⍝a vector is treated as a one-column matrix
 m←(2↑(⍴m),1 1)⍴m
 ⍝assign columns on which to sort (sort on last column first)
 c←⌽⍳¯1↑⍴m
 ⍝this algorithm sorts the indices, not the complete matrix
 y←⍳1↑⍴m
 i←0
 l10:
 →((1↑⍴c)<i←i+1)/0
 y←y[⍋cs⍳m[y;c[i]]]
 →l10
∇

∇y←cs gradeup1 m
 ⍝gradeup vector for character <m> based on collating sequence <cs>
 ⍝.e 4 3 2 1 = '' gradeup1 4 5⍴'dog  cat  bettyapple'
 ⍝.k sorting
 ⍝.t 1989.7.27.22.47.57
 ⍝encode each row as an integer, then grade up
 'gradeup1' checksubroutine 'base'
 →(∼(⍴⍴m)∈1 2)/err1
 y←m
 →(0∈⍴m)/0
 ⍝the following line allows for scalar <cs>
 cs←((0∈⍴cs)/⎕AV),(∼0∈⍴cs)/cs
 ⍝treat vector <m> as n×1 matrix
 y←⍋cs base(2↑(⍴m),1 1)⍴m
 →0
 err1:
 ⎕←'gradeup1 rank error'
∇

∇gf←codes grafd x;ax;c;n;pds;s;y;⎕IO
 ⍝histogram of data <x> specified by <codes>
 ⍝.e 19 24 = ⍴16 4 grafd 20 22 24 19 15 16 14 30 15 19 26 24
 ⍝.k plotting
 ⍝.n eike kaiser
 ⍝.v 1.0 / 12 may 83
 ⍝codes[1] c = number of cells to be used along y axis
 ⍝codes[2] pds = periods per cycle in data
 ⎕IO←1
 n←1
 c←codes[1]
 pds←codes[2]
 l1:
 y←⌈((⌈/x)-⌊/x)÷c
 →(y>1)/l2
 x←x×10
 n←n×10
 →l1
 l2:
 s←(⌊/x)+(-y)+y×⍳c+1
 gf←⊖((c+1),⍴x)⍴(,s∘.≤x)\'⎕'
 s←s÷n
 s←⊖12 2⍕((⍴s),1)⍴s
 ax←(1↓⍴gf)⍴⌽¯1↓'○',pds⍴'-'
 gf←ax,[1]gf,[1]ax
 s←'∘',[1](((1↑⍴s),-+/∨/[1]s≠' ')↑s),[1]'∘'
 gf←(s,' '),gf,' ',s
∇

∇y←n hfd d;⎕IO
 ⍝return hex equivalent of integers <d> to <n> hex positions
 ⍝.e (1 3⍴'011') = 3 hfd 17
 ⍝.k translation
 ⍝.t 1988.4.12.19.49.28
 ⎕IO←0
 →((⍴⍴d)>1)/err1
 d←,d
 y←⍉'0123456789abcdef'[(n⍴16)⊤d]
 →0
 err1:⎕←'hfd rank error'
∇

∇y←hist x
 ⍝simple histogram of data vector <x>
 ⍝.e 10 10 = ⍴hist ⍳10
 ⍝.k plotting
 y←'⎕ '[1+(⌽⍳⌈/x)∘.≥x]
∇

∇r←jc x
 ⍝justify centre: centre all rows of left-justified character array <x>
 ⍝.e (2 6⍴'  ab    cd  ') = jc 2 6⍴'ab    cd    '
 ⍝.k formatting
 r←(-⌊0.5×+/∧\' '=⌽x)⌽x
∇

∇r←jl x
 ⍝justify left: justify character array <x>
 ⍝.e (2 6⍴'ab    cd    ') = jl 2 6⍴'ab    cd    '
 ⍝.k formatting
 r←(+/∧\' '=x)⌽x
∇

∇r←jr x
 ⍝justify right: justify character array <x>
 ⍝.e (2 6⍴'    ab    cd') = jr 2 6⍴'ab    cd    '
 ⍝.k formatting
 r←(-+/∧\⌽' '=x)⌽x
∇

∇z←julian date;c;d;jf;m;s;y
 ⍝compute Julian day number for dates <date> = (mm dd yyyy style)
 ⍝.e 2443281 2447295 = julian 2 3⍴5 17 1977 5 13 1988
 ⍝.k date
 ⍝.t 1992.4.6.2.35.28
 ⍝.v 1.0 / 17may77
 ⍝<date> = n×3 matrix (or n×4 matrix where date[;⎕IO+3] is optional style)
 ⍝       = 3-(or 4) element vector (treated as 1-row matrix)
 date←(¯2↑1,⍴date)⍴date
 m←date[;⎕IO]
 d←date[;1+⎕IO]
 y←date[;2+⎕IO]
 z←100⊥y,[⎕IO]m,[⎕IO-0.5]d
 s←(z>19230114)∨(z>15821025)∧(date,z>17520902)[;3+⎕IO]
 jf←2≥m
 c←(2×∼s)+0.75×s×⌊0.00999999999999999674×y-jf
 z←31+d+(⌊367×jf+(m-2)÷12)-⌈c-⌊365.25×4712+y-jf
∇

∇loop x;i;m;n
 ⍝perform computations for each element (or row) of <x>
 ⍝.k programming-tools
 ⍝.t 1992.3.18.11.57.1
 ⍝reshape vector to matrix
 m←(2↑(⍴x),1 1)⍴x
 ⍝if needed, line to reshape character namelist to matrix is below
 ⍝   m←'' ∆box ∆db,' ',x
 n←1↑⍴m
 i←0
 l1:
 →(n<i←i+1)/lend
 ⍝ --- insert computations using m[i;] here
 →l1
 lend:
∇

∇y←pw matacross m;cols;mat;rows
 ⍝format matrix <m> in columns across a page of width <pw>
 ⍝.e ' apple betty' = (15 matacross '/' ∆box 'apple/betty/cat/dog')[⎕IO;]
 ⍝.k formatting
 ⍝.t 1989.7.24.22.5.52
 ⍝.v 1.0 / 26jan84
 ⍝.v 2.0 / 05may88 / added left argument
 pw←pw,(×/⍴pw)↓⎕PW
 mat←' ',⍕m
 rows←⌈(1↑⍴mat)÷cols←⌊pw÷¯1↑⍴mat
 y←(rows,colsׯ1↑⍴mat)⍴((rows×cols),¯1↑⍴mat)↑mat
∇

∇y←a matdown m;⎕IO;cols;mat;rows;w
 ⍝format matrix <m> in columns down a page according to <a>
 ⍝.e 'apple  cat  '=12⍴15 2 matdown '/' ∆box 'apple/betty/cat/dog'
 ⍝.k formatting
 ⍝.t 1988.4.24.22.9.20
 ⍝.v 1.2 / 5nov83
 ⍝ a[1]=width of page(:⎕PW),  [2]=spaces between columns(:1)
 ⎕IO←1
 ⍝get defaults for a
 a←a,(×/⍴a)↓⎕PW,1
 ⍝compute as though there are a[2] extra spaces on right
 w←+/a
 mat←(⍕m),((1↑⍴m),a[2])⍴' '
 ⍝do 1⌈ to prevent cols=0 if w is specified too small
 rows←⌈(1↑⍴mat)÷cols←1⌈⌊w÷¯1↑⍴mat
 mat←2 1 3⍉(cols,rows,¯1↑⍴mat)⍴((rows×cols),¯1↑⍴mat)↑mat
 mat←((1↑⍴mat),×/1↓⍴mat)⍴mat
 ⍝now drop trailing blank columns on right
 y←(0,-a[2])↓mat
∇

∇y←matrix x
 ⍝reshape any array <x> (rank 0 - n) to a matrix
 ⍝.e 6 2 = ⍴matrix 3 2 2 ⍴'a'
 ⍝.k reshape
 ⍝.t 1992.3.18.11.11.30
 ⍝.v 1.0 / 20sep85 / first version
 ⍝.v 1.1 / 18mar92 / simplified computation of first dimension of result
 ⍝compute a=product of all dimensions except last (=1 if x is scalar or vector)
 ⍝compute b=last dimension (=1 if x is scalar)
 ⍝shape of result is (a,b)
 y←((×/¯1↓⍴x),¯1↑1,⍴x)⍴x
∇

∇r←mdyoford x;⎕IO;d;day;leap;m;md;month;n;year
 ⍝compute the (mm dd yyyy) format for ordinal dates <x>
 ⍝.e 5 12 1988 = ,mdyoford 88133
 ⍝.k date
 ⍝.t 1988.5.11.23.58.2
 ⍝.v 1.1 / 11may88 / corrected and enhanced version of <jul2ymd>
 ⎕IO←1
 md←0 31 59 90 120 151 181 212 243 273 304 334
 n←⍴x←,x
 d←1000 1000⊤x
 year←1900+d[1;]
 ⍝compute leap year flag for each x[i]
 leap←(0=400|year)∨(0=4|year)∧(0≠100|year)
 ⍝add 1 to months after february if leap year
 m←md[1],md[2],leap∘.+md[2↓⍳12]
 ⍝month of each x[i]
 month←+/(⍉(12,n)⍴d[2;])>m
 ⍝ ----- month day of each element in d[2;]
 ⍝md[month] is number of days in year up to beginning of month <month>.
 ⍝adjust <day> (days in this month) if d[2;] (ordinal date) is in march
 ⍝or greater in a leap year.
 day←d[2;]-md[month]+leap×month≥3
 ⍝return year,month,day as n÷3 matrix
 r←⍉(3,n)⍴month,day,year
∇

∇r←moonphase d
 ⍝compute phase of moon <r> for dates <d> = (mm dd yyyy style)
 ⍝.e 1 ∆ moonphase 1989 7 27
 ⍝.k date
 ⍝.t 1992.4.6.1.14.56
 ⍝.v 1.0 / 15apr78
 ⍝<d> is vector (1 date), or matrix of dates (passed to <julian>)
 ⍝<r> 0 is new moon, .5 is full moon, .75 is last quarter, etc.
 'moonphase' checksubroutine 'julian'
 r←1|÷29.530589999999993÷¯9+julian d
∇

∇Nly←Nls nl Nlc;⎕IO
 ⍝namelist of functions or variables <Nlc> within specification <Nls>
 ⍝.e 'nl' ∆rowmem 'm-p' nl 3
 ⍝.k programming-tools
 ⍝.t 1992.3.8.11.18.0
 ⍝.v 1.0 / 27jul89
 ⍝.v 1.1 / 02mar92 / localized ⎕IO, definition of right arg changed
 ⍝.v 1.2 / 06mar92 / replace matdown with matacross for formatting output
 ⍝.v 1.3 / 08mar92 / specify gradeup collating sequence to put blank first
 ⎕IO←1
 'nl' checksubroutine 'gradeup matacross pick range vnames wildcard'
 →(0∈vnames Nls)signalerror '/Nly/nl domain error/left arg contains invalid name specification.'
 Nly←⎕NL|Nlc
 ⍝sort after picking from objects
 Nly←(Nly pick Nls)⌿Nly
 Nly←∆db Nly[(' ',⎕AV)gradeup Nly;]
 ⍝reformat if at least one of Nlc is negative
 →(∼¯1∈×Nlc)/0
 Nly←'' matacross Nly
∇

∇y←a on b;col;⎕IO
 ⍝catenate array <a> to array <b> (maximum rank 2) on first coordinate
 ⍝.e (3 4⍴'aaaabb  bb  ') = 'aaaa' on 2 2⍴'b'
 ⍝.k catenation
 ⍝.t 1989.7.23.21.59.7
 ⍝note: (0 1⍴''),[1]2 1⍴'a'  same as  (0 1⍴'') on 2 1⍴'a'
 ⍝note: '',[1]1 0⍴'a' same as '' on 1 0⍴'a'
 ⎕IO←1
 a←(¯2↑1 1,⍴a)⍴a
 b←(¯2↑1 1,⍴b)⍴b
 col←⌈/0 1 0 1/(⍴a),⍴b
 y←(((1↑⍴a),col)↑a),[1]((1↑⍴b),col)↑b
∇

∇y←ordofmdy d;⎕IO;day;leap;md;month;year
 ⍝compute the ordinal format for dates <d> = (mm dd yyyy)
 ⍝.e 92061 = ordofmdy 3 1 1992
 ⍝.k date
 ⍝.t 1992.4.14.16.1.27
 ⍝.v 1.0
 ⍝.v 1.1 / 14apr92 / using signalerror, simplified function
 ⍝<d> can be a 3-element vector, or a matrix of dates
 ⍝ordinal date format is (yyddd). e.g. 85036 means 36th day of 1985
 ⎕IO←1
 d←(¯2↑1 1,⍴d)⍴d
 →(3≠¯1↑⍴d)signalerror '/y/ordofmdy length error/last coordinate of right arg not 3'
 ⍝md[i]+1 is first ordinal day of month[i]
 md←0 31 59 90 120 151 181 212 243 273 304 334
 month←d[;1]
 day←d[;2]
 year←d[;3]
 ⍝To compute leap year:
 ⍝   non-century years -- must be evenly divisible by 4
 ⍝       century years -- must be evenly divisible by 400
 ⍝in other words -- every 4 years, except only every 4 century years
 leap←(0=400|year)∨(0=4|year)∧(0≠100|year)
 ⍝add 1 if month[i] is in march or later and year is a leap year
 y←1000⊥(100|year),[0.5]day+md[month]+leap×month≥3
∇

∇out x;i;sink
 ⍝put text <x> to output device
 ⍝.k output
 ⍝.t 1992.4.25.21.9.3
 →g∆outf/skip
 g∆outh←g∆outf←1
 outheader
 skip:
 →g∆outh/skip01
 g∆outh←1
 outheader
 skip01:
 x←(¯2↑1 1,⍴x)⍴x
 i←0
 l0:→((1↑⍴x)<i←i+1)/0
 →(g∆outline<g∆outlimit)/ok
 ⍝too many lines. go to new page and print header
 outpage
 g∆outh←1
 outheader
 ok:
 g∆outline←g∆outline+1
 →(g∆outdevice='afptz')/a,f,p,t,z
 a:
 g∆outbuffer←g∆outbuffer on x[i;]
 →l0
 f:
 g∆outbuffer←g∆outbuffer on x[i;]
 →l0
 p:
 ⍝⎕←g∆outpagechar,(132⌊⍴x[i;])↑x[i;]
 g∆outpagechar←' '
 →l0
 t:
 ⎕←⎕PW↑x[i;]
 →l0
 z:
 ∆out x[i;]
 →l0
∇

∇outclose;sink
 ⍝close output device
 ⍝.k output
 ⍝.t 1989.7.30.15.44.8
 →(g∆outdevice='afptz')/a,f,p,t,z
 a:
 ⍝pad with blank lines if last page is partially full
 →(g∆outline=0)/a10
 g∆outbuffer←g∆outbuffer,[1]((g∆outlimit-g∆outline),¯1↑⍴g∆outbuffer)⍴' '
 a10:
 ⍝reshape buffer to rank-3 array (each plane is a page)
 g∆outbuffer←(((1↑⍴g∆outbuffer)÷g∆outlimit),g∆outlimit,¯1↑⍴g∆outbuffer)⍴g∆outbuffer
 ⍝define array.  important not to choose a name that is shadowed
 ⍎g∆outname,'←g∆outbuffer'
 →lend
 f:
 ⍝define component for text on last page (if any)
 →(g∆outline=0)/lend
 ⍎g∆outname,(⍕g∆outpageno),'←g∆outbuffer'
 →lend
 p:
 ⍝close printer as required (insert code here)
 →lend
 t:
 ⍝print ready text unless last page is empty
 →(g∆outline=0)/lend
 ⍞←g∆outreadytext
 sink←⍞
 →lend
 z:
 ⍝close as already defined for this device
 ∆outreset
 →lend
 lend:
 sink←⎕EX 'g∆outbuffer'
 ⍝if desired ⎕EX various other 'g∆out' variables here
∇

∇outheader
 ⍝print header
 ⍝.k output
 ⍎g∆outheader
∇

∇header outopen x;parms
 ⍝open output device specified by <x>. use heading function <header>
 ⍝.k output
 ⍝.t 1992.4.25.21.8.51
 ⍝note: if heading feature not used, define <header> as ''
 ⍝<x> has format:  device,parameter1,parameter2
 ⍝ the meaning depends on the device
 g∆outheader←header
 parms←',' ∆box x
 g∆outdevice←∆db parms[1;]
 g∆outline←0
 g∆outpageno←1
 g∆outlimit←⌊/⍳0
 g∆outbuffer←0 0⍴''
 →((g∆outdevice='afptz'),1)/a,f,p,t,z,err1
 a: ⍝array. <x>='a',name,limit
 g∆outname←∆db parms[2;]
 g∆outlimit←⍎parms[3;]
 g∆outbuffer←0 0⍴''
 →lend
 f: ⍝file. <x>='f',limit
 g∆outlimit←⍎parms[2;]
 ⍝initialize buffer
 g∆outbuffer←0 0⍴''
 ⍝define base name of matrix used to define components
 g∆outname←'component'
 →lend
 p: ⍝printer (skeleton). <x>='p',limit
 g∆outlimit←⍎parms[2;]
 ⍝page format character. 1=go to top of page before printing text
 g∆outpagechar←'1'
 →lend
 t: ⍝terminal. <x>='t',limit
 g∆outlimit←⍎parms[2;]
 g∆outreadytext←'press <enter> key to continue.'
 →lend
 z: ⍝z-device. <x>='z',limit
 g∆outlimit←⍎parms[2;]
 ∆outset
 →lend
 lend:
 g∆outh←g∆outf←0
 →0
 err1:
 ⎕←'out domain error'
 ⎕←'unknown device code (',g∆outdevice,')'
 ∘
∇

∇outpage;sink
 ⍝advance device to new page
 ⍝.k output
 g∆outh←0
 ⍝no page advance if already at top
 →(g∆outline=0)/0
 →(g∆outdevice='afptz')/a,f,p,t,z
 a:
 ⍝pad buffer with empty lines to end of 'page'
 g∆outbuffer←g∆outbuffer,[1]((g∆outlimit-g∆outline),¯1↑⍴g∆outbuffer)⍴' '
 →lend
 f:
 ⍝define this component (as a variable)
 ⍎g∆outname,(⍕g∆outpageno),'←g∆outbuffer'
 g∆outbuffer←0 0⍴''
 →lend
 p:
 ⍝in ibm environment simply reset page format character
 g∆outpagechar←'1'
 →lend
 t:
 ⍞←g∆outreadytext
 sink←⍞
 →lend
 z:
 ∆outpage
 →lend
 lend:
 g∆outline←0
 ⍝advance page counter to 'this page'
 g∆outpageno←g∆outpageno+1
∇

∇z←m patterng c;⎕IO
 ⍝random rearrangement of text <c> based on <m>
 ⍝.e 4 9 = ⍴ 2 3 2 3 patterng ' sun ⋆ moon '
 ⍝.k graphics
 ⍝.n roger frey
 ⍝.t 1989.7.27.23.42.49
 ⍝.v 1.0 / aug68
 ⎕IO←1
 z←((2↑m)×2↓m)⍴2 4 1 3⍉((m[3 4],⍴c)⍴c)[;;?m[1 2]⍴⍴c]
∇

∇y←payday d
 ⍝<y> is the closest Friday on or before dates <d> = (mm dd yyyy)
 ⍝.e 7 21 1989 = ,payday 7 27 1989
 ⍝.k date
 ⍝.t 1992.4.9.17.27.59
 ⍝.v 1.0 / 15apr78
 ⍝.v 1.1 / 09apr92 / left arg extended to matrix; use <days> not <julian>
 ⍝<d> can be vector (1 date), or matrix of dates, in format (mm dd yyyy)
 'payday' checksubroutine 'days cdays'
 ⍝for each date compute day counts starting from <d> and going back a week
 y←(days d)∘.-¯1+⍳7
 ⍝pick out the day count for friday (day 5) in each row and convert to dates
 y←cdays(,5=7|y)/,y
∇

∇y←m pick v;⎕IO;b;i;mv;r;tc;tf;token
 ⍝select (pick) rows from character <m> using name specification <v>
 ⍝.e 1 1 0 0 1 = ('/' ∆box 'apple/betty/cat/dog/zebra') pick 'a-b z⋆'
 ⍝.k searching
 ⍝.n rml
 ⍝.t 1988.5.12.21.11.46
 ⍝.v 1.8 / 23jan84
 ⍝.v 2.0 / 26nov85
 ⍝.v 2.1 / 06may88 (rewritten, use enhanced name specifications)
 ⍝.v 2.2 / 23apr92 / using signalerror
 ⍝<m> character matrix of names
 ⍝<v> character vector containing name specifications
 ⎕IO←1
 'pick' checksubroutine 'vnames wildcard range'
 →(∼(⍴⍴v)∈0 1)signalerror '/y/pick rank error/right arg not rank 0 or 1'
 ⍝mv is needed in one of the early error messages
 mv←'' ∆box v←∆db v
 →(2≠⍴⍴m)signalerror '/y/pick rank error/left arg not rank 2'
 y←(1↑⍴m)⍴0
 →((0∈⍴m),0∈⍴v)/0
 ⍝compute class of each name specification in <mv>
 tc←vnames v
 →(0∈tc)signalerror '/y/pick domain error/right arg has invalid items (',(∆db,' ',(tc=0)⌿mv),')'
 ⍝translate a token class into its positive equivalent
 r←(1 12 21 121 212 2 13 31 131 3,tc)[(41 412 421 4121 4212 42 413 431 4131 43,tc)⍳tc]
 ⍝for each token in <mv> remove trailing blanks, compute tilde
 ⍝flag, remove tilde, get corresponding compression vector.
 i←0
 l20:→((1↑⍴mv)<i←i+1)/0
 tf←'∼'=1↑token←∆db mv[i;]
 token←tf↓token
 →(r[i]=1 12 21 121 212 2 13 31 131 3)/(6⍴l30a),(4⍴l30b)
 l30a:b←m wildcard token
 →l30
 l30b:b←m range token
 →l30
 l30:
 ⍝treat <b> differently depending on <tf> (tilde flag)
 →(1 0=tf)/l50a,l50b
 ⍝tilde specification. turn off a subset of the items already picked.
 ⍝but if first one, start with universe.
 l50a:y←(y∨i=1)×∼b
 →l20
 ⍝no tilde. add to subset of items already picked.
 l50b:y←y∨b
 →l20
∇

∇y←v pickn n;⎕IO;b;i;mv;r;t;x
 ⍝pick ('select') numbers from <n> using positive integer specification <v>
 ⍝.e 1 1 1 1 0 0 0 0 1 1 = '1-4 9-' pickn ⍳10
 ⍝.k searching
 ⍝.t 1992.4.25.17.18.49
 ⍝.v 1.0 / 23nov83 / uses vfpi
 ⍝.v 1.1 / 13nov85 / uses vpis
 ⍝.v 1.2 / 25apr92 / uses signalerror
 ⍝<n> is vector of numbers
 ⍝<v> is positive integer specification as defined by <vpis>
 ⍝<y> is compression vector for <n>
 ⎕IO←1
 'pickn' checksubroutine 'vpis'
 →(∼(⍴⍴n)∈0 1)signalerror '/y/pickn rank error/right arg not rank 0 or 1'
 n←,n
 mv←'' ∆box v←∆db,' ',v
 y←(⍴n)⍴0
 →((0∈⍴n),0∈⍴v)/0
 ⍝find token class <r> of each specification
 r←vpis v
 t←∆db,' ',(∼r[;1])⌿mv
 →(0∈r[;1])signalerror '/y/pickn domain error/left arg contains invalid items (',t,')'
 ⍝for each token, get the compression vector
 i←0
 l20:
 →((⍴r)<i←i+1)/0
 →(r[i;2]=1 12 21 2 121)/exact,prefix,suffix,all,range
 exact: ⍝number
 b←n=⍎mv[i;]
 →endloop
 prefix: ⍝n-
 b←n≥⍎(mv[i;]≠'-')/mv[i;]
 →endloop
 suffix: ⍝-n
 b←n≤⍎(mv[i;]≠'-')/mv[i;]
 →endloop
 all: ⍝ -  all the matrix
 b←(⍴n)⍴1
 →endloop
 range: ⍝n-m
 x←⍎b\(b←mv[i;]≠'-')/mv[i;]
 b←(x[1]≤n)∧n≤x[2]
 →endloop
 endloop:
 y←y∨b
 →l20
∇

∇z←a pnrot n;i;j
 ⍝permutation vector <a> for partitioned <n>-rotate on partitions <a>
 ⍝.e 2 1 5 3 4 8 9 6 7 ∧.= 1 0 1 0 0 1 0 0 0 pnrot 1 ¯1 2
 ⍝.k uncategorized
 ⍝.t 1988.4.13.1.38.6
 ⍝returns the permutation vector to perform a partitioned <n>-rotate
 ⍝on a vector whose partitions are designated by <a>
 ⍝<n> must satisfy (⍴,n)∈1,+/a and will be scalar-extended if necessary
 i←(1⌽a)/⍳⍴a
 j←+\a
 i←i-¯1↓0,i
 z←⍋j+(i|n)[j]≥+\1-a\¯1↓0,i
∇

∇print text
 ⍝example print cover function to print <text> on printer
 ⍝.k output
 '' outopen 'z,34'
 out text
 outclose
∇

∇y←prompt msg
 ⍝simple prompt with <msg> and request input on same line
 ⍝.k input
 ⍞←msg,'  '
 y←,⍞
 y←(¯1+(y≠' ')⍳1)↓y
∇

∇Y←Text puttag Fns;⎕IO;Alpha;Code;Fn;I;J;Line;Mat;T
 ⍝put tag line <text> on functions <fns>
 ⍝.k library-utility
 ⍝.t 1989.7.24.18.17.10
 ⍝.v 1.2 / 31oct83
 ⍝<text> has the form:  c xxxxx    where c is a tag character
 ⎕IO←1
 Y←⍳0
 ⍎(2≠⍴⍴Fns)/'Fns←'' '' ∆box ∆db Fns'
 ⍝remove leading '.' if necessary
 Text←(∼∧\Text='.')/Text
 Code←1↑Text
 ⍝ensure for new tag line that space follows code
 Line←'⍝.',(2↑Code),2↓Text
 J←0
 L10:→((J←J+1)>1↑⍴Fns)/End
 Mat←⎕CR Fn←Fns[J;]
 ⍝----- make sure Mat has at least two lines with first line comment
 →((0 1=1↑⍴Mat)/L15,L20),L0
 ⍝no line. cannot get cr.
 L15:⎕←'puttag error. cannot get canonical matrix for ',Fn
 →Blend
 L20: ⍝one line. add a line for first line comment
 Mat←Mat,[1](¯1↑⍴Mat)↑'⍝'
 →L2
 L0: ⍝this Mat has at least two lines. check for first line comment
 →('⍝'=Mat[2;1])/L2
 ⍝add line for first line comment
 Mat←Mat[1;],[1]((¯1↑⍴Mat)↑'⍝'),[1]1 0↓Mat
 L2: ⍝now Mat has at least 2 lines with first line comment
 ⍝skip next part if Text is empty
 →(0=⍴Text)/L3
 ⍝----- put in new tag line
 ⍝pad mat with trailing blanks (if necessary) to accommodate Line
 Mat←((1↑⍴Mat),((¯1↑⍴Mat)⌈⍴Line))↑Mat
 ⍝now search for tag line
 I←(Mat[;⍳4]∧.='⍝.',2↑Code)/⍳1↑⍴Mat
 →(0=⍴I)/L1
 ⍝found it. so replace (first occurrence of) it.
 Mat[1↑I;]←(¯1↑⍴Mat)↑Line
 →L3
 L1: ⍝did not find it. so insert new Line after line 1
 Mat←Mat[⍳2;],[1]((¯1↑⍴Mat)↑Line),[1]2 0↓Mat
 L3:
 ⍝----- now reorder lines with ⍝.x<blank>  (where x is alphabetic)
 I←(Mat[;1 2 4]∧.='⍝. ')/⍳1↑⍴Mat
 Alpha←'abcdefghijklmnopqrstuvwxyz∆ABCDEFGHIJKLMNOPQRSTUVWXYZ⍙'
 I←(Mat[I;3]∈Alpha)/I
 Mat[I;]←Mat[I[⍋Alpha⍳Mat[I;3]];]
 →(0≠1↑0⍴T←⎕FX Mat)/Lend
 ⎕←'puttag error'
 ⎕←'error when fixing function = ',Fn,'  line = ',(⍕T),'  ',Mat[T;]
 →Blend
 Lend:
 Y←Y,1
 →L10
 Blend:
 Y←Y,0
 →L10
 End:
∇

∇Y←L qstop N
 ⍝set stop vector for functions <N> on lines <L>, but not comments
 ⍝.k programming-tools
 ⍝.t 1988.4.8.3.47.42
 ⍝example:  (⍳10) qstop 'func'  ⍝stop function 'func' at lines 1 tthrough 10
 'qstop' checksubroutine 'stoptrace'
 →((∼0∈⍴L)∧0≠1↑0⍴L)/Err1
 Y←L stoptrace 's',,' ',⍕N
 →0
 Err1:⎕←'stop domain error'
∇

∇Y←L qtrace N
 ⍝set trace for functions <N> on lines <L>, optionally avoid comments
 ⍝.k programming-tools
 ⍝.t 1988.4.8.3.47.42
 ⍝example:  (⍳10) qtrace 'func'  ⍝trace function 'func' at lines 1 tthrough 10
 'qtrace' checksubroutine 'stoptrace'
 →((∼0∈⍴L)∧0≠1↑0⍴L)/Err1
 Y←L stoptrace 't',,' ',⍕N
 →0
 Err1:⎕←'trace domain error'
∇

∇y←m range s;⎕CT;⎕IO;cs;lh;n;nn;x
 ⍝select names in matrix <m> using 'range' search specification <s>
 ⍝.e  1 1 1 0 0 = (5 5⍴'appleanniebettycat  dog  ') pick 'a-b'
 ⍝.k searching
 ⍝.t 1989.7.27.22.20.17
 ⍝.v 1.0 / 06may88
 ⍝assume <s> belongs to set of valid specifications  (a-z, a-, -z, -)
 ⍝<s> can contain ? search character
 ⎕IO←1
 ⎕CT←0
 ⍝assume collating sequence <cs> includes all characters in nn and m.
 ⍝blank will also appear as a pad character and we set it so it
 ⍝is first in collating sequence.
 cs←' abcdefghijklmnopqrstuvwxyz∆ABCDEFGHIJKLMNOPQRSTUVWXYZ⍙0123456789⎕'
 ⍝the lowest and highest characters in collating sequence
 lh←cs[1,⍴cs]
 ⍝<nn[1;]> = first part of range specification, <nn[2;]> = second part
 ⍝e.g. if <s> is 'ax-d', nn[1;]='ax' and nn[2;]='d '
 ⍝<s,'-'> ensures that nn has 2 rows if <s>='a-'
 nn←'-' ∆box s,'-'
 ⍝ensure that m has as many columns as nn
 m←((1↑⍴m),(¯1↑⍴nn)⌈¯1↑⍴m)↑m
 ⍝replace blank in low limit with lh[1].
 ⍝replace blank in high limit with lh[2].
 ⍝this also assigns defaults to empty limits.
 ⍝'?' in range specification (e.g.  a?-b, ?-, etc.) is allowed but
 ⍝essentially irrelevant.  it is replaced by low or high character in
 ⍝collating sequence, depending on if it appears in the first or second
 ⍝part of the range specification, respectively.
 nn[1;]←(lh[1 1],nn[1;])[(' ?',nn[1;])⍳nn[1;]]
 nn[2;]←(lh[2 2],nn[2;])[(' ?',nn[2;])⍳nn[2;]]
 ⍝compute numeric values up to precision of specified phrases
 x←(⍴cs)⊥⍉cs⍳nn
 n←(⍴cs)⊥⍉cs⍳m[;⍳¯1↑⍴nn]
 y←(x[1]≤n)∧n≤x[2]
∇

∇y←a reformat m;⎕IO;i;v
 ⍝reformat <m> to matrix a[1] characters wide, including a[2] initial blanks
 ⍝.e 2 35 = ⍴35 4 reformat 'the quick brown fox jumped over the lazy red hen'
 ⍝.k formatting
 ⍝.t 1988.4.27.22.14.51
 ⎕IO←1
 'reformat' checksubroutine 'jl ss expandaf split'
 ⍝<a[2]> defaults to 0
 a←2↑a
 ⍝delete redundant blanks after appending blank for words ending on last column
 v←∆db,m,' '
 ⍝<ss>       find occurrences in <v> of period or ? followed by blank
 ⍝<expandaf> put extra blank in <v> after these occurrences
 ⍝<split>    split text into several lines within specified text width
 ⍝<jl>       move any leading blanks in each row to end of row
 y←jl(a[1]-a[2])split(expandaf(⍳⍴v)∈(v ss '. '),v ss '? ')\v
 ⍝preceed text by a[2] blank columns
 y←(((1↑⍴y),a[2])⍴' '),y
∇

∇y←a reparray m;⎕IO;c;n;shape;x
 ⍝replicate array <m>.  replicate <a[1]> times along coordinate <a[2]>
 ⍝.e ((3 2 2⍴'abcd'),[1] 3 2 2⍴'1234') = 3 1 reparray 2 2 2⍴'abcd1234'
 ⍝.k reshape
 ⍝.n rml
 ⍝.t 1992.4.25.17.1.8
 ⍝.v 1.0 / 10feb84
 ⍝.v 1.1 / 25apr92 / using signalerror
 ⍝note: each 'slice' of the array along the specified coordinate
 ⍝is replicated <a[1]> times.
 ⎕IO←1
 ⍝default to last coordinate
 a←2↑a,⍴⍴m
 →(∼(1≤a[2])∧a[2]≤⍴⍴m)signalerror '/y/reparray domain error/coordinate specification (',(⍕a[2]),') outside range (1,',(⍕⍴⍴m),')'
 n←a[1]
 c←a[2]
 x←(c+1),((c+1)≠⍳1+⍴⍴m)/⍳1+⍴⍴m
 shape←(⍴m)×(c≠⍳⍴⍴m)+(c=⍳⍴⍴m)×n
 y←shape⍴x⍉(n,⍴m)⍴m
∇

∇y←a reparray1 m;c;n;⎕IO
 ⍝replicate matrix <m>. replicate <a[1]> times along coordinate <a[2]>
 ⍝.e ((3 2⍴'ab'),[1] 3 2⍴'cd') = 3 1 reparray1 2 2⍴'abcd'
 ⍝.k reshape
 ⍝.n rml
 ⍝.t 1989.7.27.22.10.15
 ⍝.v 1.0 / 10feb84
 ⍝simplified version of reparray restricted to rank 2 arrays
 ⎕IO←1
 ⍝default to last coordinate
 a←2↑a,2
 n←a[1]
 c←a[2]
 ⍝replicate coordinate 1 (rows) or coordinate 2 (columns)
 →(c=1 2)/l1,l2
 l1:
 y←((n×(⍴m)[1]),(⍴m)[2])⍴2 1 3⍉(n,⍴m)⍴m
 →0
 l2:
 y←((⍴m)[1],n×(⍴m)[2])⍴3 1 2⍉(n,⍴m)⍴m
∇

∇report parms;n
 ⍝example of using the output functions
 ⍝.k output
 ⍝.t 1992.4.25.20.38.47
 'reportheader' outopen parms
 out 'first line of sample report - using the output functions'
 ⍝here's one way to make two blank lines
 out 'two blank lines follow ...'
 out 2 1⍴' '
 out 'it is ok to output a matrix'
 out 6 6⍴'matrix'
 ⍝numerics must be in character form
 out 'to output numeric data, put in character form first ...'
 out⍕⍳3
 outpage
 out 'first line of next page'
 out 'the quick brown fox jumped over the lazy black hen'
 out 'now two successive calls to outpage (advances one page only)'
 ⍝two calls to outpage (advances one page only)
 outpage
 outpage
 out 'this should be top of next page (after quick brown fox)'
 out 'print ',(⍕n←16),' lines ...'
 out((n,5)⍴'line '),⍕(n,1)⍴⍳n
 outclose
∇

∇reportheader
 ⍝example of report header function (used in <report>)
 ⍝.k output
 ⍝.t 1992.4.25.20.39.35
 out jc 78↑'sample report page ',⍕g∆outpageno
 out 78⍴'-'
∇

∇r←x riota y;⎕IO
 ⍝in matrix <x> where is each row of matrix <y>?
 ⍝.e 2=('/' ∆box 'apple/betty/cat') riota 'betty'
 ⍝.k searching
 ⍝.n dave macklin
 ⍝.t 1992.4.16.22.20.19
 ⍝.v 1.0 / 00apr78
 ⎕IO←1
 y←(¯2↑1 1,⍴y)⍴y
 x←(¯2↑1 1,⍴x)⍴x
 r←1++/∼∨\(((0 1×⍴x)⌈⍴y)↑y)∧.=⍉((0 1×⍴y)⌈⍴x)↑x
∇

∇r←n rnd x
 ⍝round numbers <x> to <n> decimal places
 ⍝.e 45.35 10.13 2.14 = 2 rnd 45.345 10.134 2.136
 ⍝.k computation
 ⍝.t 1989.7.23.22.16.56
 r←(10⋆-n)×⌊0.5+x×10⋆n
∇

∇r←rnde x;t
 ⍝round <x> to nearest integer (.5 case goes to nearest even integer)
 ⍝.e 12 12 14 14 = rnde 11.5 12.5 13.5 14.5
 ⍝.k computation
 ⍝.t 1989.7.23.22.18.18
 t←¯1⋆⌈2|x
 r←t×⌊0.5+x×t
∇

∇y←roman x;a;⎕IO
 ⍝character roman numeral equivalent of arabic (base 10) number <x>
 ⍝.e 'xiv' = roman 14
 ⍝.k translation
 ⍝.t 1988.4.13.1.6.8
 ⎕IO←1
 x←,x
 a←,(10 4⍴3 3 3 3 1 3 3 3 1 1 3 3 1 1 1 3 1 0 3 3 0 3 3 3 0 1 3 3 0 1 1 3 0 1 1 1 1 ¯1 3 3)[1+(4⍴10)⊤x;]
 y←'mdclxvi'[(a≠3)/a+2×⌊0.25ׯ1+⍳16]
∇

∇mat←y scatter x;pos;shape;⎕IO
 ⍝simple scatter plot of vectors <y> (y-axis) against <x> (x-axis)
 ⍝.e 11 21 =  ⍴((⍳10),⌽⍳10) scatter(⍳20)
 ⍝.k plotting
 ⎕IO←1
 mat←,(shape←(⌈/y),⌈/x)⍴' '
 pos←1+shape⊥¯1+y,[0.5]x
 mat[pos]←'⋆'
 mat←⊖'+','+',[1]shape⍴mat
∇

∇Y←script Text;⎕IO;BB;C;Codes;I;J;KK;L;Scriptbuffer;Sink;Tokens;X
 ⍝compute document <Y> using script in character matrix <Text>
 ⍝.e (¯9↑'⎕←x') = 9⍴script '/' ∆box '.t ⎕←x←2 2⍴⍳4/abcdefg/.r 3 3⍴⍳4/.x x'
 ⍝.k library-utility
 ⍝.n rml
 ⍝.t 1992.4.25.18.28.6
 ⍝.v 1.0 / 15oct83
 ⍝.v 1.1 / 15may85 / various modifications
 ⍝.v 1.2 / 04apr88 / added and improved definitions of codes
 ⍝.v 1.3 / 15jul89 / ∆rowmem used, .b added
 ⍝.v 1.4 / 25apr92 / comments and algorithms improved, .p added, .s removed
 ⍝local variables start with underscore to avoid shadowed values. do not
 ⍝use these names in executable expressions in <text>.
 ⍝if <script> suspends ...
 ⍝   - to display the row index of the bad line in the script, display I
 ⍝   - to display the text of the bad line, display Text[I;]
 ⍝   - to display the result so far, display Y
 ⎕IO←1
 'script' checksubroutine 'fixuparray on ∆dlb ∆dtb ∆if ∆rowmem'
 →(∼(⍴⍴Text)∈0 1 2)signalerror '/Y/script rank error/right arg has rank > 2'
 →L02 ∆if 2=⍴⍴Text
 ⍝vector. assume delimited by 'return' characters and reshape to matrix
 Text←g∆cr ∆box Text
 L02: ⍝argument <Text> is now a matrix
 Y←Scriptbuffer←0 0⍴''
 ⍝each code is in a 3-character format <.x > (period, code, blank)
 Codes←'drpenctxb'
 Tokens←'.',Codes,[1.5]' '
 J←3
 I←0
 ⍝find indices of all lines starting with codes
 BB←(((1↑⍴Text),J)↑Text)∆rowmem Tokens
 L10:
 →Lend ∆if(1↑⍴Text)<I←I+1
 →(L15f,L15nf)∆if BB[I]
 L15f: ⍝found code on this line
 C←Text[I;2]
 ⍝use everything after code for expression
 L←J↓Text[I;]
 →L15
 L15nf: ⍝did not find code on this line. use entire line for result.
 ⍝KK is used to improve performance.  Find the next run of no-code lines and
 ⍝append to result in one operation.  Avoids looping over many lines.
 KK←¯1+(I↓BB)⍳1
 Y←Y on Text[I,I+⍳KK;]
 I←I+KK
 →L10
 L15:
 ⍝comment code .c is ignored (go to L10)
 →(Ld,Lr,Lp,Le,Ln,L10,Lt,Lx,Lb)∆if C=Codes
 Ld: ⍝display text
 Y←Y on L
 →L10
 Lr: ⍝display computed result
 Y←Y on fixuparray⍎L
 →L10
 Lp: ⍝capture statements and results
 ⍝display all statements (including comments) as on terminal
 ⍝capture and show output of all statements, including assignments
 ⍝treat like .t except show output of assignment statements
 ⍝note: there will be double output for ⎕ statements
 →Lt
 Le: ⍝execute
 Sink←⍎L
 →L10
 Ln: ⍝niladic execute
 ⍎L
 →L10
 Lt: ⍝terminal
 ⍝remove leading blanks before further processing
 L←∆dlb L
 ⍝adjust 6 spaces for typical APL terminal display
 Y←Y on(6⍴' '),L
 ⍝exit now if L is an APL comment statement
 →L10 ∆if '⍝'=1↑L
 ⍝do not special-case assignment if processing a .p code
 →Lt01 ∆if C='p'
 ⍝test if assignment symbol in line
 →Lt01 ∆if∼'←'∈L
 ⍝there is assignment symbol. get text (quad or name) preceeding symbol.
 X←(¯1+L⍳'←')↑L
 ⍝test if text before assignment is a quad
 →Lt03 ∆if∧/X∈'⎕'
 ⍝test if text is valid name (assignment statement, no terminal output)
 →(Lt02,Lt01)∆if∧/X∈'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890∆⍙'
 Lt01:
 ⍝L does not need special treatment. execute and capture result for display.
 Y←Y on fixuparray⍎L
 →L10
 Lt02:
 ⍝L has form: name←expression
 ⍝execute but do not show result in document,
 ⍎L
 →L10
 Lt03:
 ⍝assume L has form: ⎕←expression  or ⎕←name←expression
 ⍝execute script recursively using .r code with the text without the ⎕
 ⍝result of ⎕←expression will be embedded in document.
 Y←Y on script '.r ',(L⍳'←')↓L
 →L10
 Lx: ⍝expunge
 Sink←⎕EX '' ∆box ∆db L
 →L10
 Lb: ⍝build
 ⍝fix scriptbuffer if L = '∇'
 →(Lbf,Lba)∆if 1=+/'∇'=∆db L
 Lbf:
 Sink←⎕FX Scriptbuffer
 →(' '≠1↑0⍴Sink)signalerror '/Y/script error/(⎕FX Scriptbuffer)=',(⍕Sink),' on line ',⍕I
 Scriptbuffer←0 0⍴''
 →L10
 Lba:
 Scriptbuffer←Scriptbuffer on L
 →L10
 Lend:
 Y←∆dtb Y
∇

∇y←m search s;⎕IO;c;i;x
 ⍝y[i]=1 if row <m[i;]> contains the search sequence <s>
 ⍝.e  0 1 0 = (3 5⍴'appleanniecat  ') search 'nn'
 ⍝.k searching
 ⍝.t 1989.7.27.22.22.10
 ⍝.v 1.0 / 06may88
 ⎕IO←1
 s←,s
 c←(¯1↑⍴m)⌈⍴s
 x←((1↑⍴m),c)↑m
 i←(⍳1+(⍴x)[2]-⍴s)∘.+¯1+⍳⍴s
 ⍝pick rows that contain <s>
 y←∨/x[;i]∧.=s
∇

∇y←shares
 ⍝return names of shared variables
 ⍝.e 1 ∆ shares
 ⍝.k programming-tools
 y←(2=⎕SVO ⎕NL 2)/[1]⎕NL 2
∇

∇Y←C signalerror T;M;Sink
 ⍝display message <T> if condition <C> is true
 ⍝.e 0=1 signalerror '/y'
 ⍝.k programming
 ⍝.t 1992.4.27.13.54.40
 ⍝.v 1.0 / 27apr92
 Y←⍳0
 ⍝c=0: quit now (error did not occur)
 →(∼C)/0
 ⍝c=1: display message, erase variable specified in first row, return vector 0
 Y←,0
 M←(1↑T)∆box 1↓T
 Sink←⎕EX M[⎕IO;]
 M←1 0↓M
 ⍝quit if no message, otherwise display non-empty message on quad device
 →(0∈⍴M)/0
 ⎕←(((1↑⍴M),3)⍴'.'),' ',M
∇

∇plt←sixline v;a;b;ma;mi;nc;x;xd;yd;⎕IO
 ⍝return sixline plot given x and y data in <v> = n×2 matrix
 ⍝.e 6 33 = ⍴sixline (⍳11),[1.5] (.5ׯ5+⍳10),0
 ⍝.k plotting
 ⍝.n rml
 ⍝.t 1989.7.27.20.0.48
 ⍝.v 1.0 / jun75
 ⍝<v[;1]> is x-coordinate, <v[;2]> is y-coordinate
 ⎕IO←1
 →(2≠⍴⍴v)/err1
 →(0∈⍴v)/err2
 →(2≠¯1↑⍴v)/err3
 nc←30⌈(1↑⍴v)⌊60
 x←v[;1]
 v←v[;2]
 mi←⌊/x
 ma←⌈/x
 xd←⌈1+(x-mi)×(nc-1)÷ma-mi
 yd←1⌈37⌊19+(×v)×⌊1+4×|v
 a←((10⍴6),(4⍴5),(4⍴4),(5⍴3),(4⍴2),(10⍴1))[yd]
 b←'x98765432143214321012341234123456789x'[yd]
 plt←(6×nc)⍴' '
 plt[nc⊥(a-1),[0.5]xd]←b
 plt←(6 3⍴'+2|+1|+0|-0|-1|-2|'),(6,nc)⍴plt
 →0
 err1:
 ⎕←'sixline rank error'
 ⎕←'right argument does not have rank 2'
 →0
 err2:
 ⎕←'sixline domain error'
 ⎕←'right argument is empty'
 →0
 err3:
 ⎕←'sixline length error'
 ⎕←'right argument does not have 2 columns.'
 →0
∇

∇y←cs sort m;⎕IO;c;shape
 ⍝sort character vector or matrix <m> using collating sequence <cs>
 ⍝.e 'dee' = ('' sort 3 3⍴'eggdogeat')[;1] ∆ g∆sort∆columns←1
 ⍝.k sorting
 ⍝.n rml
 ⍝.t 1992.4.23.0.12.46
 ⍝.v 1.3 / 22may85
 ⍝.v 1.4 / 19jun86 / fixed bug in computing <c>
 ⍝.v 1.5 / 04may88 / minor corrections, use gradeup
 ⍝.v 2.0 / 22apr92 / better comments and arg checking, global arg now columns
 ⎕IO←1
 'sort' checksubroutine 'gradeup'
 →(∼(⍴⍴m)∈1 2)signalerror '/y/sort rank error/right arg not rank 1 or 2'
 y←m
 →(0∈⍴y)/0
 ⍝ --- right argument
 ⍝vector <m> is treated as a one-column matrix
 shape←⍴m
 m←(2↑(⍴m),1 1)⍴m
 ⍝ --- global argument
 ⍝define columns from global parameter (default is all columns)
 ⍎(0=⎕NC 'g∆sort∆columns')/'g∆sort∆columns←⍳0'
 c←g∆sort∆columns
 c←((0∈⍴c)/⍳¯1↑⍴m),(∼0∈⍴c)/c
 →(∨/(c<1),c>¯1↑⍴m)signalerror '/y/sort index error/column numbers not in domain (1,',(⍕¯1↑⍴m),')'
 ⍝ --- left argument
 ⍝defaults to implementation atomic vector
 cs←((0∈⍴cs)/⎕AV),(∼0∈⍴cs)/cs
 ⍝
 ⍝get specified columns of data, then sort and reshape to original shape
 y←shape⍴m[cs gradeup m[;c];]
∇

∇Z←sortl X;G
 ⍝sort local names in header of function <X> and fix result
 ⍝.k programming-tools
 ⍝.t 1992.4.3.13.25.24
 ⍝.v 1.0 / 05may88
 ⍝.v 1.1 / 03apr92 / signalerror used
 →(3≠⎕NC X)signalerror '/Z/sortl domain error/(',X,') not a function.'
 G←⎕CR X
 →(0∈⍴G)signalerror '/Z/sortl domain error/function (',X,') locked.'
 Z←⎕FX sortlocal G
∇

∇y←sortlocal x;⎕IO;c;header;i;t
 ⍝sort local variables in first line of <x> = canonical matrix
 ⍝.e 'y←sortlocal x;⎕IO;c;header;i;t' = ∆db (sortlocal ⎕CR 'sortlocal')[1;]
 ⍝.k formatting
 ⍝.t 1992.3.3.20.50.4
 ⍝.v 1.0 / 12jun85 / first version
 ⍝.v 1.1 / 03mar92 / ensure that special characters sort before letters
 ⎕IO←1
 'sortlocal' checksubroutine 'gradeup'
 →(2≠⍴⍴x)signalerror '/y/sortlocal rank error/left arg not rank 2'
 ⍝do nothing if empty argument
 →(0∈⍴y←x)/0
 c←¯1↑⍴y
 header←y[1;]
 ⍝do nothing if no locals (no semicolon)
 →(c<i←header⍳';')/0
 ⍝sort locals and reconstruct list of local names
 t←';' ∆box i↓header
 ⍝ensure that special characters and blank sort before letters and numbers
 t←t[(' ⎕∆⍙',⎕AV)gradeup t;]
 t←1↓,';',t
 ⍝assign new line 1 (header)
 y[1;]←c↑(i↑header),(t≠' ')/t
∇

∇y←w split line;⎕IO;g;p;t
 ⍝split text vector <line> into <w>-size pieces
 ⍝.e 'please read the cat '=(20 split 'please read the cat in the hat')[1;]
 ⍝.k formatting
 ⍝.t 1992.4.25.16.55.44
 ⍝.v 1.0 / 30oct81
 ⍝.v 1.1 / 25apr92 / using signalerror
 ⎕IO←1
 →(w<1)signalerror '/y/split domain error/left arg (',(⍕w),') should be greater than 0'
 line←,line
 y←(0,w)⍴''
 g←⍴line
 →(g=0)/0
 l2:
 →((g=0),g≤w)/0,l4
 ⍝find last blank in line. if no blanks, take whole piece
 t←(w+1)-(' '=⌽w↑line)⍳1
 p←(0 1=×t)/w,t
 ⍝t=0 if there were no blanks
 →(t=0)/l3
 ⍝all blank or partially blank. if all blank, take whole piece
 t←(p+1)-(' '≠⌽p↑line)⍳1
 p←(0 1=×t)/w,t
 l3:y←y,[1]w↑p↑line
 g←⍴line←p↓line
 →l2
 l4:y←y,[1]w↑line
 →0
∇

∇l←v sr s;⎕IO;i;n;o;r;rl;rn;ro;rr;w
 ⍝search for 'old' sequence and replace by 'new' in <v>.  <s>=/old/new
 ⍝.e 'annie had a little lamb' = 'mary had a little lamb' sr '/mary/annie'
 ⍝.k substitution
 ⍝.t 1992.3.27.20.7.30
 ⍝.v 1.0 / 15mar83
 ⍝.v 2.0 / 02may88 / order of arguments reversed to conform to <ss>
 ⍝.v 2.1 / 27mar92 / better error messages, signalerror used, renamed variables
 ⍝the first element in <s> is the delimiter.
 ⎕IO←1
 'sr' checksubroutine 'ss'
 ⍝left argument
 →(∼0 1∨.=⍴⍴v)signalerror '/l/sr rank error/left arg not rank 0 or 1.'
 l←,v
 ⍝right argument
 →(1≠⍴⍴s)signalerror '/l/sr rank error/right arg not rank 1.'
 →(2≠+/s=1↑s)signalerror '/l/sr domain error/delimiter in right arg must occur exactly twice.'
 ⍝get old and new sequences
 i←(s[1]=s)/⍳⍴s
 o←1↓(¯1+i[2])↑s
 n←i[2]↓s
 ⍝determine number and locations of 'old' string
 rr←⍴r←v ss o
 →(0=rr)/0
 ro←⍴o
 ⍝check for overlapping occurrences of 'old'
 →(∨/ro>¯1↓(1⌽r)-r)signalerror '/l/sr domain error/overlapping search sequence = ',⍕o
 ⍝replace 'old' by 'new'
 rl←⍴l
 rn←⍴n
 r←r-1
 w←,(r+(rn-ro)ׯ1+⍳rr)∘.+⍳rn
 l←(∼(⍳rl+rr×rn-ro)∈w)\(∼(⍳rl)∈r∘.+⍳ro)/l
 l[w]←(rr×rn)⍴n
∇

∇l←text srn s;⎕IO;i;n;o;r;rl;rn;ro;rr;w
 ⍝search and replace name by 'new' sequence in <text>. <s>=/name/new
 ⍝.e 'factor←a3×vara÷factor×2' = 'a←a3×vara÷a×2' srn '/a/factor'
 ⍝.k substitution
 ⍝.t 1992.4.3.14.30.8
 ⍝.v 1.0 / 05apr84
 ⍝.v 1.1 / 23oct85 / corrections made to v1.0
 ⍝.v 1.2 / 02may88 / ⎕IO added to header, ⎕-names added, ssn used
 ⍝.v 1.3 / 03apr92 / arg checking enhanced, signalerror used
 ⎕IO←1
 'srn' checksubroutine 'ss ssn'
 ⍝left argument
 →(∼0 1∨.=⍴⍴text)signalerror '/l/srn rank error/left arg not rank 0 or 1.'
 l←,text
 ⍝right argument
 →(1≠⍴⍴s)signalerror '/l/srn rank error/right arg not rank 1.'
 →(2≠+/s=1↑s)signalerror '/l/srn domain error/delimiter in right arg must occur exactly twice.'
 ⍝ --- get old and new sequences
 i←(s[1]=s)/⍳⍴s
 o←1↓(i[2]-1)↑s
 n←i[2]↓s
 →(0∈⍴o)/0
 ⍝ --- find positions of old sequence (name)
 r←l ssn o
 →(0∈⍴r)/0
 ⍝note: no need to check <r> for overlapping occurences of <o>
 ⍝      for further details see <ssn>.
 ⍝ --- replace name with new sequence
 ro←⍴o
 rl←⍴l
 rn←⍴n
 rr←⍴r
 r←r-1
 ⍝<w> is indices of all occurrences of new sequence in new line
 w←,(r+(rn-ro)ׯ1+⍳rr)∘.+⍳rn
 ⍝remove occurrences of old sequence, and expand to allow new sequence
 l←(∼(⍳rl+rr×rn-ro)∈w)\(∼(⍳rl)∈r∘.+⍳ro)/l
 ⍝insert new sequence
 l[w]←(rr×rn)⍴n
∇

∇y←v ss s;⎕IO;a;f;r
 ⍝return all locations of sequence <s> in vector <v>
 ⍝.e 1 12 ='the cat in the hat' ss 'the'
 ⍝.k searching
 ⍝.t 1992.3.28.1.36.58
 ⍝.v 1.0 / 21feb83
 ⍝.v 1.1 / 21apr88 / ⎕IO added to header, rank check added
 ⍝.v 1.2 / 28mar92 / signalerror used
 ⎕IO←1
 ⍝left argument
 →(1≠⍴⍴v)signalerror '/y/ss rank error'
 s←,s
 f←⍴s
 a←⍴v
 y←⍳0
 →(f>a)/0
 →(f=0)/0
 →(1 0=f=1)/l1,l2
 l1:
 y←(s=v)/⍳a
 →0
 l2:
 r←s∧.=(0,1-f)↓(¯1+⍳f)⌽(f,a)⍴v
 y←r/⍳⍴r
 →0
∇

∇y←text ssn s;⎕IO;b;vc
 ⍝return locations of occurrences of the name <s> in vector <text>
 ⍝.e 1 11 = 'a←a3×vara÷a×2' ssn 'a'
 ⍝.k searching
 ⍝.n rml
 ⍝.t 1992.3.28.1.39.29
 ⍝.v 1.2 / 02may88 / change name to ssn; use subroutine <ss>
 ⍝.v 1.3 / 28mar92 / clarify comments, sequence <s> checked, signalerror used
 ⎕IO←1
 'ssn' checksubroutine 'ss'
 ⍝special check for invalid character=blank. (difficult error to notice)
 →(' '∈s)signalerror '/y/ssn domain error/blanks in name specified in right arg.'
 ⍝check for invalid characters. <vc> is valid characters allowed in a name
 vc←'⎕abcdefghijklmnopqrstuvwxyz∆ABCDEFGHIJKLMNOPQRSTUVWXYZ⍙0123456789'
 →(∼∧/s∈vc)signalerror '/y/ssn domain error/invalid characters in name specified in right arg.'
 y←⍳0
 →(0∈⍴s)/0
 b←text∈vc
 ⍝ note on overlapping occurrences when using <ss>:
 ⍝ <ss> returns locations of overlapping occurrences. a name by
 ⍝ definition will not overlap itself.
 ⍝ ' ',s,' ' may overlap itself (e.g. <s>='x' with ' x x ' in text)
 ⍝ but s will not because s does not contain blanks.
 y←(' ',(b\b/text),' ')ss ' ',s,' '
∇

∇sl←stemleaf z;i;leaf;leafn;maxl;n;nleaf;stem;stemn;zn;zp;⎕IO
 ⍝stem and leaf plot of data <z>
 ⍝.e 12 17 = ⍴stemleaf ¯2 ¯23 23 34, (⍳10), (4×⍳10), 45 86 44
 ⍝.k plotting
 ⍝.t 1989.7.27.20.8.29
 ⎕IO←1
 z←,z
 z←z[⍋z]
 n←⍴z
 zp←⌊(0≤z)/z
 zn←⌊-(0>z)/z
 stemn←⌊(zn,zp)÷10
 leafn←⌊(zn,zp)-10×stemn
 stemn←(⌊-(zn+1)÷10),⌊zp÷10
 stem←stemn[1]+¯1+⍳1+stemn[n]-stemn[1]
 nleaf←+/stem∘.=stemn
 maxl←⌈/nleaf
 leaf←((⍴stem),maxl)⍴' '
 i←⍴stem
 l:leaf[i;⍳nleaf[i]]←'0123456789'[1+(-nleaf[i])↑leafn]
 leafn←(-nleaf[i])↓leafn
 →(0≠i←i-1)/l
 stem←(stem<0)+stem
 sl←(5 0⍕((⍴stem),1)⍴stem),(((⍴stem),1)⍴'|'),leaf
 →(0=⍴zn)/0
 n←stem⍳¯1
 →(n<⍴stem)/l1
 →(n=⍴stem)/0
 →(0=stem[i])/l2
 →0
 l1:sl[n+1;sl[n;]⍳'¯']←'¯'
 →0
 l2:sl[1;¯1+sl[1;]⍳'0']←'¯'
∇

∇Y←L stoptrace Names;Code;Fname;I;Ll;Mat;N;⎕IO
 ⍝subroutine for qstop and qtrace
 ⍝.k programming-tools
 ⍝.n rml
 ⍝.t 1988.4.23.14.36.24
 ⍝.v 1.2 / 28dec83
 ⍝.v 2.0 / 08apr88 / left arg changed: negative means no comment trace
 ⍝ L[I] positive means to trace line L[I]
 ⍝ L[I] negative means to trace if line L[I] is not a comment
 ⍝ L    0 means to remove trace
 ⍝ L    empty defaults to negative numbers for all lines
 ⍝ 1↑Names is Code -- 't' or 's', for trace or stop
 ⍝ 1↓Names is namelist of functions
 ⎕IO←1
 ⍝function is trace or stop?
 Code←1↑Names
 Fname←(((Code='t')/'trace'),(Code='s')/'stop')
 ⍝right argument
 Names←'' ∆box ∆db 1↓Names
 →(0∈⍴Names)/0
 →(∼3∧.=⎕NC Names)/Err1
 ⍝left argument
 L←,L
 I←0
 L10:→((1↑⍴Names)<I←I+1)/0
 Mat←⎕CR Names[I;]
 N←1↑⍴Mat
 ⍝L is empty? default to all negative lines
 Ll←((0=⍴L)/-⍳N-1),(0≠⍴L)/L
 ⍝if Ll[I] is negative and |Ll[I] is comment line, don't trace it. i.e. remove from list
 ⍝note that line 0 (header) never is a comment line
 Ll←(∼(¯1=×Ll)∧(|Ll)∈('⍝'=Mat[;1])/¯1+⍳N)/Ll
 ⍝any other negative numbers are non-comment lines, so trace anyway
 Y←Ll←|Ll
 ⍝duplicate line numbers don't matter.
 ⍝next line becomes something like:  t∆xxxx←1 2 3
 ⍎Code,'∆',Names[I;],'←',⍕Ll
 →L10
 Err1:
 ⎕←Fname,' domain error'
 ⎕←'cannot find function(s) = ',∆db,' ',(3≠⎕NC Names)⌿Names
 →
∇

∇r←p subtotal m;⎕IO
 ⍝compute and merge subtotals of <m> determined by positions <p>
 ⍝.e (7 2⍴1 2 1 2 2 4 10 20 10 20 20 40 22 44) = (3 2⍴1 2 3 4 1 4) subtotal 4 2⍴1 2 1 2 10 20 10 20
 ⍝.k computation
 ⍝.t 1989.7.23.23.49.42
 ⍝.v 1.0 jan82
 ⍝<p> is n×2 matrix
 ⍝ n is number of subtotal rows
 ⍝ p[;1] is subtotal row start positions, p[;2] is end positions
 ⎕IO←1
 r←(m,[1]-/[2](+\[1]0,[1]m)[⌽p+(⍴p)⍴0 1;])[⍋(⍳1↑⍴m),p[;2];]
∇

∇p←d suppress v;b;level;mask;shape;x;⎕IO
 ⍝suppress characters in matrix <v> delimited by delimiters <d>
 ⍝.e 'abc     def' = '()' suppress 'abc(xxx)def'
 ⍝.k delete-elements
 ⍝.t 1988.4.18.20.55.29
 ⍝ d[1] = d[2]  no nesting of delimiters is allowed
 ⍝ d[1] ≠ d[2]  nesting level is arbitrarily set to 1
 ⎕IO←1
 shape←⍴v
 v←(¯2↑1 1,⍴v)⍴v
 ⍝ensure that <d> has exactly 2 elements
 d←2⍴d
 →(0 1==/d)/different,same
 different:
 ⍝set level of nesting arbitrarily for this part
 level←1
 x←+\(v=d[1])-0 ¯1↓0,v=d[2]
 mask←level≤x
 →l10
 same:
 b←d[1]=v
 mask←b≥0 1↓≠\1,b
 →l10
 l10:
 p←mask⌽[1]v,[0.5]' '
 p←shape⍴p[1;;]
∇

∇r←f thru tb;⎕IO;b
 ⍝generate equal-interval vector from <f> to <1↑tb>, increment=¯1↑tb
 ⍝.e 1 1.5 2 2.5 3 3.5 4 4.5 5 = 1 thru 5 .5
 ⍝.k computation
 ⍝.n dave macklin
 ⍝.t 1992.4.22.22.28.22
 ⍝.v 1.0 / 06may88
 ⍝the interval is <1↓tb>
 ⎕IO←0
 b←|tb[1]
 r←(tb[0]-f)÷b
 r←f+(×r)×b×⍳1+⌊|r
∇

∇y←time
 ⍝return current time of day in format  hh:mm:ss (am/pm)
 ⍝.e 1 ∆ time
 ⍝.k time
 ⍝.t 1992.4.22.22.13.52
 ⍝.v 1.0 / 00oct80
 ⍝.v 1.1 / 00apr88
 ⍝.v 1.2 / 22apr92 / replaced all code with call to <ftime>
 'time' checksubroutine 'ftime'
 y←ftime ⎕TS[4 5 6]
∇

∇y←timer n;tt
 ⍝time <n> executions of an expression for cpu and connect time
 ⍝.k timing
 ⍝.t 1992.3.28.15.34.56
 ⍝.v 1.0 / 12apl82
 ⍝.v 1.1 / 28mar92 / clarified comments
 ⍝this function uses ⎕AI
 ⍝when using <timer> compute overhead first and ignore first timing test.
 ⍝ tt starts with current accumulated cpu and connect time
 tt←2↑1↓⎕AI
 l1:→(0>n←n-1)/l2
 ⍝put code here
 →l1
 l2:
 ⍝ result y is elapsed cpu and connect time
 y←(2↑1↓⎕AI)-tt
∇

∇interval timetrace msg;cp;now
 ⍝print <msg> after <interval> milliseconds of cpu time
 ⍝.k timing
 ⍝example:   2000 timetrace 'another 2 seconds has elapsed'
 now←1↑2↓⎕AI
 ⍝check for checkpoint time (cp)
 ⍎(0=⎕NC 'g∆timetrace∆cp')/'g∆timetrace∆cp←',⍕now
 cp←g∆timetrace∆cp
 →(interval>now-cp)/0
 ⎕←msg
 g∆timetrace∆cp←now
∇

∇y←timing
 ⍝cover function to call and format elapsed cpu and connect time
 ⍝.e 1 ∆ timing
 ⍝.k timing
 ⍝.t 1992.3.28.13.51.56
 ⍝.v 1.0 / 25may88
 y←fcpucon cpucon
∇

∇z←tower x;i;j;m;n;xx;y;z1;z2;z3;⎕IO
 ⍝tower chart (skyscraper diagram) for contingency table <x>
 ⍝.e 29 72 = ⍴tower 3 3⍴29 16 5 26 12 20 28 30 17
 ⍝.k plotting
 ⍝.n carina heiselbetz
 ⍝.t 1989.7.27.20.10.30
 ⎕IO←1
 'tower' checksubroutine 'field'
 z←(n←¯1↓⍴x)field m←1↓⍴x
 xx←100×x÷⌈/,x
 z1←¯4+⌈0.0999999999999999778×⌈/,xx
 z1←0⌈z1
 z←((z1,1↓⍴z)⍴' '),[1]z
 j←i←1
 loop:
 →(xx[i;j]<0)/l1
 z2←z1+¯1+7×i
 z3←(7×n-i+1)+17×j
 →(xx[i;j]<5)/l2
 y←1+⌊0.0999999999999999778ׯ5+xx[i;j]
 z[z2-y;z3+¯1+⍳4]←1 4⍴'/¯¯/'
 z[z2;z3+3]←'/'
 z[z2-⍳y;z3+4]←'|'
 z[z2-⍳y-1;z3+3]←' '
 z[z2+1-⍳y;z3+¯2+⍳4]←(y,4)⍴'|⋆⋆|'
 l1:
 →(m≥j←j+1)/loop
 →(n≥i←i+j←1)/loop
 →end
 l2:
 z[z2;z3+¯1+⍳5]←'/___/'
 z[z2-1;z3+⍳5]←'/¯¯¯/'
 →l1
 end:
 z←z,[1]' '
 z[¯1↓⍴z;9+⍳17×m]←(17×m)↑,(⍉1 6⍴'abcdef'),6 16⍴' '
 i←1
 l5:
 z[z1+5+7×i-1;1+7×n-i]←⍕i
 →(n≥i←i+1)/l5
∇

∇y←triangle n;i;z
 ⍝print a pretty triangle using ≠\ where <n> is a power of 2
 ⍝.e 16 16 = ⍴triangle 16
 ⍝.k graphics
 ⍝.n larry smith
 ⍝note: if n is not a power of 2, the triangle is not pretty
 i←0
 y←''
 z←n⍴1
 l1:→(n<i←i+1)/end
 y←y,z\'⋆'
 z←≠\z
 →l1
 end:y←(n,n)⍴y
∇

∇r←c unbox x;b;chars;fill;sep;⎕IO
 ⍝unbox matrix <x>. remove trailing <c[2]>, delimit vector <x> by <c[1]>
 ⍝.e 'apple/betty/cat/' = '/' unbox 3 5⍴'applebettycat  '
 ⍝.k reshape
 ⍝.t 1988.4.6.1.25.34
 ⍝.v 1.0 / jul83
 ⍝c[1]=separator character (default is blank/zero)
 ⍝c[2]=fill character (default is blank/zero)
 ⍝remove trailing character c[2] from the end of each line of matrix
 ⍝then delimit end of each line with c[1] and return a vector
 ⎕IO←1
 r←0⍴x
 →(0=⍴,x)/0
 ⍝assign defaults to special characters
 chars←c,(⍴,c)↓2↑0⍴x
 ⍝get separator (to be put at end of each row)
 sep←(⍳0)⍴1↑chars
 ⍝get fill character (to be removed from end of each row)
 fill←1↑1↓chars
 r←x
 ⍝compute 0 for trailing fill in each row and append 1 for sep
 b←(⌽∨\⌽r≠fill),1
 ⍝append line separator to end of each row
 r←r,sep
 ⍝remove trailing fill (but not separator)
 r←(,b)/,r
∇

∇y←a union b;c
 ⍝set union <a> and <b> leaving order of result as in <a>
 ⍝.e (4 5⍴'applebettycat  peach') = (3 5⍴'applebettycat  ') union 3 5⍴'cat  bettypeach'
 ⍝.k uncategorized
 ⍝.t 1988.4.6.1.28.16
 c←⌈/0 1 0 1/(⍴a),⍴b
 a←((1↑⍴a),c)↑a
 b←((1↑⍴b),c)↑b
 ⍝get elements of b but not in a and put them after a
 y←a,[1](∼b ∆rowmem a)⌿b
∇

∇line←ved text;a
 ⍝vector edit.  edit vector <text> in a simple fashion
 ⍝.k text-editing
 ⍝.n jarry apsit
 ⍝.t 1992.4.16.22.37.59
 ⍝.v 1.0 / 23mar83
 line←⍞,0⍴⍞←('/'≠text)/a\(a←'\'≠text←(⍴text)↑⍞)/⍞←text←,text
∇

∇N vedit Name;Prompt;T;Text;Y
 ⍝vector edit. screen edit variable <name> from <n[1]> to <n[2]>
 ⍝.k text-editing
 ⍝.n rml
 ⍝.t 1985.8.8.11.21.40
 ⍝.v 1.1 / 8aug85
 ⍝this function can be used on a terminal with screen editing features
 Text←Y←⍎Name
 ⍝assign defaults (1,end of text) to N
 N←2↑N,(×/⍴N)↓1,×/⍴Text
 ⍝ensure N is between 1 and ⍴Text
 N←1⌈(⍴Text)⌊N
 ⍞←Prompt←(¯1+N[1])↓N[2]↑Text
 T←,⍞
 →(0≠⍴T)/L2
 →End,0⍴⎕←'empty result. no change'
 ⍝if first part of T is all blank, do not →L1
 L2:→(∼∧/' '=(1+N[2]-N[1])↑T)/L1
 ⍝all blank. assume prompt text was unchanged and must be kept
 ⍝reinsert Prompt into returned Text <T>
 T←Prompt,(⍴Prompt)↓T
 L1:Y←((N[1]-1)↑Text),T,N[2]↓Text
 End:⍎Name,'←Y'
∇

∇r←x veq y;c
 ⍝r←1 if vectors <x> and <y> are equal. trailing blanks ignored
 ⍝.e 1 = 'apple' veq 'apple     '
 ⍝.k programming
 ⍝scalar <x> or <y> treated as 1-element vector
 c←(⍴,x)⌈⍴,y
 r←(c↑x)∧.=c↑y
∇

∇r←vi a;t
 ⍝validate numeric input <a>
 ⍝.e 1 1 0 0 1 = vi '1 2 1a 3.3.3 123.35'
 ⍝.k validation
 ⍝.n gerald bamberger, apl quote-quad, mar 80
 ⍝.t 1989.7.27.23.11.44
 ⍝.v 1.0 / mar 80
 t←' 11111111112345'[' 0123456789.¯e'⍳'0 ',a]
 r←1↓⍎((t∈'234')∨t≠' ',¯1↓t)/t
 r←r∈(8 3⍴0 41 431)+1 12 121 21 31 312 3121 321∘.×1 100 1000
∇

∇y←vnames v;an;r;t;⎕IO
 ⍝validate name specifications in <v>
 ⍝.e 1 12 131 412 4131 0 = vnames 'a d?⋆ a-d ∼∆⋆ ∼d-e ⋆a⋆a'
 ⍝.k validation
 ⍝.n rml
 ⍝.t 1988.4.24.21.39.7
 ⍝.v 1.2 23jan84
 ⍝.v 2.0 26nov85 / add ? facility and remove escape chars
 ⍝.v 2.1 22apr88 / add valid specifications, allow general ?, add ∼
 ⍝valid name specifications:
 ⍝   x    x⋆    ⋆x    x⋆y   ⋆x⋆   ⋆   x-y     x-     -x     -
 ⍝   1    12    21    121   212   2   131     13     31     3
 ⍝also any of above prefaced by <∼>
 ⍝<an> contains characters allowed to form x and y
 ⎕IO←1
 an←'?⎕abcdefghijklmnopqrstuvwxyz∆ABCDEFGHIJKLMNOPQRSTUVWXYZ⍙0123456789'
 v←∆db v
 →(0∈⍴y←v)/0
 ⍝compute class of specifications in v
 t←(' ',((⍴an)⍴'1'),'2345')[(' ',an,'⋆-∼')⍳v]
 r←,⍎((t∈'234')∨t≠' ',¯1↓t)/t
 ⍝return invalid codes as 0
 y←r×r∈1 12 21 121 212 2 13 31 131 3 41 412 421 4121 4212 42 413 431 4131 43
∇

∇y←vpis v;a;cs;r;t
 ⍝validate positive integer specification <v>
 ⍝.e (2 2⍴1 12 1 121) = vpis '5- 1-10'
 ⍝.k validation
 ⍝.n rml
 ⍝.t 1992.4.25.22.43.44
 ⍝.v 1.0 / 23nov83
 ⍝.v 1.1 / 13nov85
 ⍝positive integer specification: sequence of integers and ranges
 ⍝integer  n to n   n to end   start to n   all
 ⍝  n       n-n       n-          -n         -
 ⍝  1       121       12          21         2
 y←⍳0
 a←∆db v
 →(0∈⍴a)/0
 ⍝character set for valid positive integer
 cs←'0123456789'
 t←(' ',((⍴cs)⍴'1'),'23')[(' ',cs,'-')⍳a]
 r←,⍎((t∈'2')∨t≠' ',¯1↓t)/t
 y←(r∈1 121 12 21 2),[1.5]r
∇

∇e←v vrepl a;i;j;l;m;v1;⎕IO
 ⍝replace in <v> single-character abbreviations defined in <a>
 ⍝.e 'dear bob how are you?' = '⎕ ○ how are ∆?' vrepl(3 5 ⍴'⎕dear○bob ∆you ')
 ⍝.k substitution
 ⍝.n k.h. glatting and g. osterburg
 ⍝.t 1989.7.27.22.54.26
 ⍝.v 1.0 / dec80
 ⎕IO←1
 v1←v∈a[;⎕IO]
 i←v1/⍳⍴v
 j←a[;⎕IO]⍳v[i]
 ⍝determine the length of the string to replace each code
 l←∼⌽∧\(1↑0⍴v)=⌽0 1↓a
 l←l[j;]
 m←0 1↓×\(i+0.5),l
 v1←(∼v1)/⍳⍴v
 e←(v[v1],(,l)/,0 1↓a[j;])[⍋v1,(,l)/,m]
∇

∇r←vtype x
 ⍝return <r> = 'type' of variable <x> (logical,character,integer,real)
 ⍝.e 4=vtype 10.456
 ⍝.k programming-tools
 ⍝.t 1983.10.31.17.40.29
 ⍝.v 1.0 / 12feb82
 ⍝warning: this is an implementation-dependent function
 ⍝ <r> -- 1=logical,2=char,3=integer,4=real
 x←64↑0⍴x
 r←70000
 r←⎕WA+70000
 x←128↑x
 r←0.125×r-⎕WA+70000
 r←(1 2 3 4 4)[1 8 32 64⍳r]
∇

∇b←m wildcard s;⎕IO;c;i;j;name;wp;x
 ⍝select names in matrix <m> using 'wildcard' search specification <s>
 ⍝.e  0 0 1 1 0 = (5 5⍴'appleanniebettybattydog  ') pick '⋆tt⋆'
 ⍝.k searching
 ⍝.t 1988.5.7.19.23.17
 ⍝.v 1.0 / 06may88
 ⍝<s> can contain ? search character
 ⎕IO←1
 s←,s
 ⍝assume <s> is one of the following --- ⋆  ⋆a⋆  ⋆a  a⋆  a⋆a  a
 →(('⋆'∧.=s),(2=+/'⋆'=s),('⋆'=1↑s),('⋆'=¯1↑s),('⋆'∈s),1)/all,mid,suff,pref,lr,exact
 all: ⍝everything phrase: s=⋆
 b←(1↑⍴m)⍴1
 →0
 mid: ⍝somewhere in between phrase: s=⋆name⋆
 name←1↓¯1↓s
 x←((1↑⍴m),(¯1↑⍴m)⌈⍴name)↑m
 i←(⍳1+(⍴x)[2]-⍴name)∘.+¯1+⍳⍴name
 →l50
 suff: ⍝suffix phrase: s=⋆name
 name←1↓s
 ⍝right justify, then take last (⍴name) columns
 x←((1↑⍴m),-⍴name)↑(-+/∧\⌽' '=m)⌽m
 i←(1,⍴name)⍴⍳⍴name
 →l50
 pref: ⍝prefix phrase: s=name⋆
 name←¯1↓s
 x←((1↑⍴m),⍴name)↑m
 i←(1,⍴name)⍴⍳⍴name
 →l50
 exact: ⍝exact phrase: s=name
 c←(¯1↑⍴m)⌈⍴s
 name←c↑s
 x←((1↑⍴m),c)↑m
 i←(1,c)⍴⍳c
 →l50
 l50:
 ⍝if question mark in <name>, replace all non-blanks in corresponding
 ⍝columns with '?'.  algorithm works fine even if no '?' present.  note
 ⍝that <name> and <x> are conformable in length at this point.  x is
 ⍝always a rank-4 array after the next line.
 x←x[;i],[0.5]'?'
 wp←'?'=name
 j←wp/⍳⍴wp
 x[;;;j]←(x[1;;;j]≠' ')⌽[1]x[;;;j]
 ⍝find rows that contain search string in specified columns
 b←∨/x[1;;;]∧.=name
 →0
 lr: ⍝left - right phrase: s=name⋆name
 b←(m wildcard(s⍳'⋆')↑s)∧m wildcard(¯1+s⍳'⋆')↓s
∇

∇r←s xfade c;c1;c2;⎕IO
 ⍝transform text in <c> using a 'fading' algorithm controlled by <s>
 ⍝.e 16 64 = ⍴16 64 xfade '/apple betty /is a dessert '
 ⍝.k graphics
 ⍝.n phil last
 ⍝.t 1989.7.27.23.42.49
 ⍝s[1] number of rows in result; s[2] number of columns
 ⍝<c> is /first text/second text
 ⍝.v 1.0 / 23jul82
 ⎕IO←1
 c2←,s⍴(1↓s←2⍴,s)⍴c2←(1⌈⍴c2)↑c2←1↓(2=c1←+\c∈1↑c)/c←(1⌈⍴c)↑c←,c
 c1←,s⍴(1↓s)⍴c1←(1⌈⍴c1)↑c1←1↓(1=c1)/c
 c2←,⊖s⍴c\(c,0⍴c[??⍳⍴c←,(×/s)⍴0]←1)/c2
 c2[c/⍳⍴c]←(c,0⍴c[??⍳⍴c,⍴c[]←0]←1)/c1
 r←s⍴c2
∇

∇y←l ∆ r
 ⍝glue function. return left argument <l>
 ⍝.e 101 = 101 ∆ 1+1 ∆ 2+2
 ⍝.k programming
 y←l
∇

∇y←chars ∆box x;fill;len;m;of;pos;s;sep;⎕IO
 ⍝'box' vector <x> using separator and fill character <chars>
 ⍝.e (3 5⍴'applebettycat  ') = '/' ∆box 'apple/betty/cat'
 ⍝.k reshape
 ⍝.t 1988.4.28.1.20.21
 ⍝.v 2.0 / 8jul83
 ⍝chars[1]=separator; chars[2]=fill; defaults are blank/zero
 ⍝<y>  matrix corresponding to a vector delimited into logical fields
 ⎕IO←1
 y←0 0⍴x
 →(0∈⍴x)/0
 chars←chars,(×/⍴chars)↓2↑0⍴x
 ⍝separator
 sep←chars[1]
 ⍝filler
 fill←chars[2]
 ⍝add sep to end if necessary
 x←x,(sep≠¯1↑x)/sep
 ⍝lengths
 pos←(x=sep)/⍳⍴x
 m←⌈/len←¯1+pos-0,¯1↓pos
 ⍝offsets
 of←(len+1)∘.⌊⍳m
 ⍝starting indices
 s←⍉(m,⍴len)⍴0,¯1↓pos
 ⍝replace separator with fill character
 x[(x=sep)/⍳⍴x]←fill
 ⍝return matrix
 y←x[s+of]
∇

∇y←fld ∆centh label;⎕IO;c;i;m;n
 ⍝centre column headings <label> within fields specified by <fld>
 ⍝.e '   a    bb    cc     d' = 4 ¯1 2 ∆centh '/a/bb/cc/d'
 ⍝.k formatting
 ⍝.n rml
 ⍝.t 1988.5.3.0.38.19
 ⍝.v 1.0 / nov83
 ⍝<fld>  vector of triplets
 ⍝[1] width;  [2] 1=lj, 0=centre, ¯1=rj;  [3] inter-column spacing
 ⎕IO←1
 y←''
 ⍝box labels and left justify
 m←(1↑label)∆box 1↓label
 m←(+/∧\' '=m)⌽m
 →(0=n←1↑⍴m)/0
 fld←,fld
 →((⍴fld)=1 3,3×n)/l1,l2,l2
 →1 signalerror '/y/∆centh length error/left arg must have 1, 3, or 3×n elements.'
 l1: ⍝1 number. extend to all fields, centred(0), 1 space
 fld←⍉(3,n)⍴(n⍴fld),(n⍴0),n↑(n-1)⍴1
 →l4
 l2: ⍝3 or 3n numbers. extend width, positioning, spacing to all fields
 fld←(n,3)⍴((¯1+3×n)⍴fld),0
 →l4
 l4:
 ⍝arguments have now been defined and shaped
 i←0
 l05:→((1↑⍴fld)<i←i+1)/0
 ⍝take as many columns as specified by fld[i]
 c←fld[i;1]↑m[i;]
 →(¯1 0 1=×fld[i;2])/l10,l20,l30
 l10: ⍝right justify (¯1⌽x)
 c←(-+/∧\' '=⌽c)⌽c
 →l40
 l20: ⍝centre
 c←(-⌊0.5×+/∧\' '=⌽c)⌽c
 →l40
 l30: ⍝it is already left-justified
 →l40
 l40: ⍝catenate to full header
 y←y,c,fld[i;3]⍴' '
 →l05
∇

∇y←w ∆centt text;d;f;l;mid;p;v;⎕IO
 ⍝centre <text> with left, middle, and right phrases in <w> spaces
 ⍝.e 'date      title    page 1' = 25 ∆centt '/date/title/page 1'
 ⍝.k formatting
 ⍝.n rml
 ⍝.t 1989.7.23.23.55.10
 ⍝.v 1.0 / 2nov83
 ⍝.v 2.0 / 23apr88 / remove 'feature' that specially handled one phrase
 ⍝<text> has the form /left/middle/right
 ⎕IO←1
 d←1↑text
 ⍝ensure 3 ending delimiters so there are three fields (phrases)
 v←text,3⍴d
 ⍝find positions p
 p←(v=d)/⍳⍴v
 ⍝lengths l
 l←¯1+1↓p-¯1⌽p
 ⍝we only want the first, second, and third phrases
 ⍝get second phrase and centre within w spaces
 mid←¯1↓p[2]↓p[3]↑v
 mid←w↑((⌈0.5×w-⍴mid)⍴' '),mid
 ⍝put them all together.  w↑ ensures exactly w spaces
 y←w↑(¯1↓1↓p[2]↑v),(l[1]↓(-l[3])↓mid),¯1↓p[3]↓p[4]↑v
∇

∇y←∆db v;b
 ⍝delete blanks (leading, trailing and multiple) from v (rank 0 - 2)
 ⍝.e 'apple betty cat' = ∆db '  apple  betty  cat  '
 ⍝.k delete-characters
 ⍝.v 1.1
 →((0 1 2=⍴⍴v),1)/l1,l1,l2,err1
 l1:
 b←' '≠v←' ',v
 y←1↓(b∨1⌽b)/v
 →0
 l2:
 b←∨⌿' '≠v←' ',v
 y←0 1↓(b∨1⌽b)/v
 →0
 err1:⎕←'∆db rank error'
∇

∇y←c ∆dc v;b
 ⍝delete characters (leading, trailing and multiple) from v (rank 0 - 2)
 ⍝.e 'apple.betty.cat' =  '.' ∆dc '...apple...betty...cat...'
 ⍝.k delete-characters
 ⍝.v 1.1
 ⍝note: same algortihm as ∆db (delete blanks)
 c←(⍳0)⍴1↑c
 →((0 1 2=⍴⍴v),1)/l1,l1,l2,err1
 l1:
 b←c≠v←c,v
 y←1↓(b∨1⌽b)/v
 →0
 l2:
 b←∨⌿c≠v←c,v
 y←0 1↓(b∨1⌽b)/v
 →0
 err1:⎕←'∆dc rank error'
∇

∇y←∆dlb v
 ⍝delete leading blanks from v (rank 0 - 2)
 ⍝.e 'apple betty cat' = ∆dlb '    apple betty cat'
 ⍝.k delete-characters
 ⍝.v 1.1
 →((0 1 2=⍴⍴v),1)/l1,l1,l2,err1
 l1:y←(¯1+(v≠' ')⍳1)↓v
 →0
 l2:y←(∨\∨⌿v≠' ')/v
 →0
 err1:⎕←'∆dlb rank error'
∇

∇y←c ∆dlc v
 ⍝delete leading character c from v (rank 0 - 2)
 ⍝.e 'apple betty cat' = '.' ∆dlc '.....apple betty cat'
 ⍝.k delete-characters
 ⍝.v 1.1
 ⍝note: same code as ∆dlb (delete leading blanks)
 c←1↑c
 →((0 1 2=⍴⍴v),1)/l1,l1,l2,err1
 l1:y←(¯1+(v≠c)⍳1)↓v
 →0
 l2:y←(∨\∨⌿v≠c)/v
 →0
 err1:⎕←'∆dlc rank error'
∇

∇y←∆dtb v
 ⍝delete trailing blanks from <v> (rank 0 - 2)
 ⍝.e 'a b c' = ∆dtb 'a b c     '
 ⍝.k delete-characters
 ⍝.v 1.1
 →((0 1 2=⍴⍴v),1)/l1,l1,l2,err1
 l1:y←(1-(⌽v≠' ')⍳1)↓v
 →0
 l2:y←(∨⌿⌽∨\⌽v≠' ')/v
 →0
 err1:⎕←'∆dtb rank error'
∇

∇y←c ∆dtc v
 ⍝delete trailing character c from v (rank 0 - 2)
 ⍝.e 'a b c' = '.' ∆dtc 'a b c.....'
 ⍝.k delete-characters
 ⍝.v 1.1
 ⍝note: same code as dtb (delete trailing blanks)
 c←1↑c
 →((0 1 2=⍴⍴v),1)/l1,l1,l2,err1
 l1:y←(1-(⌽v≠c)⍳1)↓v
 →0
 l2:y←(∨⌿⌽∨\⌽v≠c)/v
 →0
 err1:⎕←'∆dtc rank error'
∇

∇y←label ∆if condition
 ⍝if statement.  return <label[i]> if <condition[i]> = 1
 ⍝.e 20 = 10 20 ∆if 3 4 = 2+2
 ⍝.k programming
 ⍝.t 1992.4.27.14.39.33
 ⍝.v 1.0 / 00sep85
 ⍝.v 1.1 / 27apr92 / clarified comments, empty result if empty right arg
 y←⍳0
 ⍝if <condition> is empty, return ⍳o
 →(0∈⍴condition)/0
 ⍝if condition is boolean, return corresponding label vector or ⍳o
 ⍝note: if <label> is one element longer than <condition>, the last label
 ⍝ may be considered the label of an 'else' statement.
 y←((⍴,label)⍴condition,1)/label
∇

∇r←x ∆rowmem y;c
 ⍝r[i]=1 if <x[i;]> is a row in <y> (trailing blanks ignored)
 ⍝.e 1 0 = (2 5⍴'applezebra') ∆rowmem 4 5⍴'applebettycat  dog  '
 ⍝.k searching
 ⍝.t 1992.4.22.23.42.16
 ⍝.v 1.0 / 22sep85
 ⍝.v 1.1 / 13mar88 / revised error messages
 ⍝.v 1.2 / 22apr92 / using signalerror
 →(2<⍴⍴x)signalerror '/r/∆rowmem rank error/left arg has rank greater than 2'
 →(2<⍴⍴y)signalerror '/r/∆rowmem rank error/right arg has rank greater than 2'
 ⍝make x and y matrices
 x←(¯2↑1 1,⍴x)⍴x
 y←(¯2↑1 1,⍴y)⍴y
 ⍝c is maximum number of columns
 c←(¯1↑⍴x)⌈¯1↑⍴y
 ⍝pad with blank columns on right to make columns conformable
 r←∨/(((1↑⍴x),c)↑x)∧.=⍉((1↑⍴y),c)↑y
∇