Wiley Greiner. ARUN source code. APL source code, 14 June 1974. Implementation of APL operators not implemented in microcode. Transcribed by Academia.edu Co-scientist and hand-checked by Paul McJones, October 2026.
[handwriting, upper right: 10/21/74; WG: Don't throw out; WG] ∇ ⎕WIDTH (//) ⎕DIGITS : ∇ ∇ ⎕IO_BOXES ← (ϵ) GLOBAL: ∇ ∇ (→) A : ⊃ 204 ∇ ∇ A ← NOP B : ⊃ 210 ∇ ∇ ATTN A : ⊃ 212 ∇ ∇ αA αATN αB : ⊃ 212 ∇ ∇ (↓) A : ∇ ∇ A ← (↑): ∇ ∇ OUTCHARSC A : ⊃ 212 ∇ ∇ A ← INCHARSC : ⊃ 211 ∇ ∇ RETURN : ⊃ 208 ∇ ∇ X ← A (←) B : ⊃ 112 ∇ ∇ αA αASNO αB: ⊃ 113 ∇ ∇ X ← (+) A : ⊃ 128 ∇ ∇ X ← (-) A : ⊃ 129 ∇ ∇ X ← (⌊) A : ⊃ 130 ∇ ∇ X ← (⌈) A : ⊃ 131 ∇ ∇ X ← (|) A : ⊃ 132 ∇ ∇ X ← (~) A: ⊃ 133 ∇ ∇ X ← (∪) : ⊃ 192 ∇ ∇ (//) A: ⊃ 193 ∇ ∇ X ← A INTCH B : ⊃ 194 ∇ ∇ X ← A TYPECONV B : ⊃ 143 ∇ ∇ X ← (⊥) A : ¯1 INTCH TYPECONV ∇ ∇ X ← (⊤) A : 0 INTCH TYPECONV ∇ ∇ X ← A COEFBEXP B : ⊃ 134 ∇ ∇ X ← COEF B : ¯1 INTCH COEFBEXP ∇ ∇ X ← BEXP A : 0 INTCH COEFBEXP ∇ ∇ X ← (⍴) A : ⊃ 197 ∇ ∇ X ← A (⍴) B : ⊃ 198 ∇ ∇ X ← (,) A : ⊃ 199 ∇ ∇ X ← A COMAαINST B : ⊃ 200 ∇ ∇ X ← (⍳)A : ⊃ 201 ∇ ∇ X ← A (=) B , 1 : ⊃ 142 ∇ ∇ X ← A (≠) B , 2 : = ~: ∇ ∇ X ← A (+) B , 3 : ⊃ 135 ∇ ∇ X ← A (-) B , 4 : ⊃ 136 ∇ ∇ X ← A (×) B , 5 : ⊃ 137 ∇ ∇ X ← A (÷) B , 6 : ⊃ 138 ∇ ∇ X ← αA (|) αB , 9 : αASNO αA αASNO αB 0 αA = αA + αB ÷ ⌊: αA × αB - ∪: ← αA αASNO αB ∇ ∇ X ← A (<) B , 14 : ⊃ 141 ∇ ∇ X ← A (≤) B , 15 : INTCH < ~: ∇ ∇ X ← A (≥) B , 16 : < ~: ∇ ∇ X ← A (>) B , 17 : INTCH < ∇ ∇ X ← A (∨) B , 18 : ⊃ 140 ∇ ∇ X ← A (∧) B , 19 : ⊃ 139 ∇ ∇ X ← A NOR B , 20 : ∨ ~: ∇ ∇ X ← A NAND B , 21 : ∧ ~: ∇ ∇ X ← (÷) A : 1.0 ÷ ∇ ∇ X ← (×) αA : ← αA 0 INTCH < αA 0 < - ∪: αASNO αA ∇ ∇ X ← PI : 3.14159265389793 ∇
∇ X ← (○) A : PI: × ∇ ∇ X ← MINNUMBER : ⊃ 202 ⊃ 255 ⊃ 255 ⊃ 255 ⊃ 255 ∇ ∇ X ← MAXNUMBER : ⊃ 202 ⊃ 127 ⊃ 255 ⊃ 255 ⊃ 255 ∇ ∇ X ← αA (⌈) αB , 7 : αASNO αA ← αB αA - αA αB < × αB + ∪: ← αA αASNO αB ∇ ∇ X ← αA (⌊) αB , 8 : αASNO αA ← αB αA - αB αA < × αB + ∪: ← αA αASNO αB ∇ ∇ X ← A IF B : INTCH ⍴ ∇ ∇ X ← A UL B : INTCH ~: ⍴ ∇ ∇ X ← A UNLESS B : UL ∇ ∇ A ← ANDREDUCE B : 1 INTCH ⍴ ,: ⍴: ∇ ∇ A ← CRLF: 106 109 COMAαINST ⊤: ∇ ∇ ⎕DE_PROC αA : ← αA 2 αATN ∪: αASNO αA ∇ ∇ αB ← ⎕CR_BOX αA: ← αA 3 αATN ∪: αASNO αA ∇ ∇ ⎕DE_BOX αA: ← αA 4 αATN ∪: αASNO αA ∇ ∇ ⎕CR_FILE αA: ← αA 5 αATN ∪: αASNO αA ∇ ∇ ⎕DE_FILE αA: ← αA 6 αATN ∪: αASNO αA ∇ ∇ αB ⎕SEND αA: αASNO αB ← αA αB 10 αATN ∪: ← αA αASNO αB ∇ ∇ αB ⎕DELIVER αA: αASNO αB ← αA αB 11 αATN ∪: ← αA αASNO αB ∇ ∇ ⎕DETACH αB : ← αB 13 αATN ∪: αASNO αB ∇ ∇ ⎕RW_FILE αA: ← αA 14 αATN ∪: αASNO αA ∇
∇ A ← REDUCE[SWITCH;DIM] SRC;RHOS;RANK;INCR;I;I2;TARGET;LEN;N
→ VECTORSCAL IF (RANK←'' ⍴ ⍴ RHOS← ⍴ SRC) < 2
→ DEFINEDIM+ϵDIM ⍝ SKIP NEXT LINE IFF DIM ALREADY SPECIFIED.
DEFINEDIM: DIM←RANK ⍝ NEXT LINE YIELDS ERROR IF ⍴,DIM ISN'T 1.
LEN←RHOS[I←DIM←(⍳ DIM<DIM) ⍴ DIM]
INCR←1
→ LASTDIM IF I=RANK
GENERATEINCR: INCR←INCR × RHOS[I]←RHOS[I2←I+1]
→ GENERATEINCR IF (I←I2) < RANK
LASTDIM: I←'' ⍴ ⍴ SRC←,SRC
TARGET←1+'' ⍴ ⍴ A←,(RHOS←(RANK-1) ⍴ RHOS) ⍴ 0
→ DONE IF INCR=LEN // → DZERO IF 0=LEN←INCR × LEN
⍝ MAIN LOOP (NONSTANDARD)
SKIP: N←0
VECTOR: ↓SRC[I2←I-N]
RANK←I2+INCR-LEN
ELEMENT: ↓SRC[I2←I2-INCR] DYSCFNS[SWITCH] ↑ ⍝ USE STACK, SAVE MEMREFS
→ ELEMENT IF RANK<I2
A[TARGET←TARGET-1]←↑
→ VECTOR IF (N←N+1)<INCR
→ SKIP IF 0<I←I-LEN
⍝ END OF MAIN LOOP (NONSTANDARD)
RETURN // A←RHOS ⍴ A // → 0 IF 1=⍴ RHOS ⍝ SHORTCUT OP/MATRIX
DONE: RETURN // A←RHOS ⍴ SRC
VECTORSCAL: A←SRC
→ 0 UL RANK ⍝ EXIT NOW IF OP/SCALAR.
→ DZERO IF 0=I←(RHOS←'') ⍴ RHOS ⍝ PORNOGRAPHIC
→ DONE IF 1=I
↓SRC[I]
→V2+SWITCH=3 ⍝ CONDITIONALLY GOTO SPEEDY +/VECTOR SECTION
V2: RETURN // A←↑ // →V2 IF 1<I // ↓SRC[I←I-1] DYSCFNS[SWITCH] ↑
VPL:RETURN // A←↑ // →VPL IF 1<I // ↓SRC[I←I-1] + ↑
DZERO: A←RHOS IDELEM SWITCH ∇
∇ A ← ECUDER[SWITCH;DIM] SRC;RHOS;RANK;INCR;I;I2;LEN
→ VECTORSCAL IF (RANK←'' ⍴ ⍴ RHOS← ⍴ SRC)<2
→ DEFINEDIM+ϵDIM
DEFINEDIM: DIM←RANK
LEN←RHOS[I←DIM←(⍳DIM<DIM) ⍴ DIM]
INCR←1
→ GENERINCR+I=RANK
GENERINCR: → GENERINCR+I=RANK // INCR←INCR × RHOS[I←I+1]
→ DONE IF (0=I←'' ⍴ ⍴ SRC←,SRC) ∨ INCR=LEN←INCR × LEN
SKIP: A←0
VECTOR: RANK←(I2←I-A)+INCR-LEN
ELEMENT: SRC[I2]←SRC[I2←I2-INCR] DYSCFNS[SWITCH] SRC[I2]
→ ELEMENT IF RANK<I2
→ VECTOR IF (A←A+1)<INCR
→ SKIP IF 0<I←I-LEN
DONE: RETURN // A←RHOS ⍴ SRC
VECTORSCAL: → DONE UL RANK
→ 0 IF (I←'' ⍴ ⍴ A←SRC)<2
V2: → V2+1=I // A[I]←A[I←I-1] DYSCFNS[SWITCH] A[I] ∇
∇ A ← B OUTER[SWITCH] C;RHOA;RB;RC;I;AI;CI;L
RHOA←(⍴ B), ⍴ C
→ END IF (A←0)=(RB←'' ⍴ ⍴ B←,B) × RC←'' ⍴ ⍴ C←,C
⍝ SHOULD THE VECTOR CONCATENATION APPROACH BE USED?
→ ELEM IF 15<RB ⍝ MAXIMUM OF 15 CONCATENATIONS MAY BE PERFORMED
⍝ YES. IT IS MOST EFFICIENT WHEN (⍴,B) <<< ⍴,C
VFNS: → VFNS+SWITCH // A←⍳I←0
VEQ: → END//→ VEQ UL I=RB//A←A,B[I←I+1]=C
VNE: → END//→ VNE UL I=RB//A←A,~ B[I←I+1]=C
VPL: → END//→ VPL UL I=RB//A←A,B[I←I+1]+C
VMS: → END//→ VMS UL I=RB//A←A,B[I←I+1]-C
VTI: → END//→ VTI UL I=RB//A←A,B[I←I+1] × C
VDI: → END//→ VDI UL I=RB//A←A,B[I←I+1]÷C
VMA: → END//→ VMA UL I=RB//A←A,L+(L<C) × C-L←B[I←I+1]
VMI: → END//→ VMI UL I=RB//A←A,L+(C<L) × C-L←B[I←I+1]
VMO: → END//→ VMO UL I=RB//A←A,C-L+⌊C÷L+0=L←B[I←I+1]
VEX: → END//→ VEX UL I=RB//A←A,B[I←I+1] * C
VLO: → END//→ VLO UL I=RB//A←A,B[I←I+1] LN C
VCI: → END//→ VCI UL I=RB//A←A,B[I←I+1] CIRCLESC C
VGA: → END//→ VGA UL I=RB//A←A,B[I←I+1] EXCLAMATION C
VLT: → END//→ VLT UL I=RB//A←A,B[I←I+1]<C
VLE: → END//→ VLE UL I=RB//A←A,~ C<B[I←I+1]
VGE: → END//→ VGE UL I=RB//A←A,~ B[I←I+1]<C
VGT: → END//→ VGT UL I=RB//A←A,C<B[I←I+1]
VOR: → END//→ VOR UL I=RB//A←A,C ∨ B[I←I+1]
VAN: → END//→ VAN UL I=RB//A←A,C ∧ B[I←I+1]
VNO: → END//→ VNO UL I=RB//A←A,~ C ∨ B[I←I+1]
VNA: → END//→ VNA UL I=RB//A←A,~ C ∧ B[I←I+1]
ELEM: AI←1+'' ⍴ ⍴ A←, RHOA ⍴ 0
NEWROW: I←RC // L←B[RB]
→ NEWROW+⍳0<I←I-1 // A[AI←AI-1]←L DYSCFNS[SWITCH] C[I]
→ NEWROW IF 0<RB←RB-1
END: RETURN // A←RHOA ⍴ A ∇
∇ A ← B INNER[SW1;SW2] C;B1;B2;C1;C2;RHOA;RHOB;RHOC;I;J;K
RHOA ←⍳B1+C1-(0<B1← ⍴ RHOB← ⍴ B)+0<C1← ⍴ RHOC← ⍴ C
B1←B2←C1←C2←1
→ 1+DIMB-(K←I←0)<J←¯1+'' ⍴ ⍴ RHOB
DIMB: → DIMB IF I<J // B1←B1 × RHOA[K←K+1]←RHOB[I←I+1]
→ DIMB+2+J=¯1
B2←RHOB[J+1]
→ 1+DIMC-(I←1)<J←'' ⍴ ⍴ RHOC
DIMC: → DIMC IF I<J // C2←C2 × RHOA[K←K+1]←RHOC[I←I+1]
→ DIMC+2+J=0
C1←'' ⍴ RHOC
→ PROPOGATE UL (1=B2) < B2=C1
→ END IF (B1=0) ∨ C2=0 // A←(B1,C2) ⍴ 0
→ FORMED IF (2=⍴ RHOB) ∧ 2=⍴ RHOC
B←(B1,B2) ⍴ B // C←(C1,C2) ⍴ C
FORMED: → FILLIN IF 0=B2
THIRD: J←C2
SECOND: K←B[B1;I] DYSCFNS[SW2] C[I←B2;J]
FIRST: K←(B[B1;I] DYSCFNS[SW2] C[I←I-1;J]) DYSCFNS[SW1] K
→ FIRST IF 1<I
A[B1;J]←K
→ SECOND IF 0<J←J-1
→ THIRD IF 0<B1←B1-1
END: → 0 IF 2=⍴ RHOA
RETURN // A←RHOA ⍴ A
FILLIN: RETURN // A←RHOA IDELEM SW1
PROPOGATE: → LENERR UL (C1=1) ∨ I←B2=1
RETURN//A←RHOA ⍴ REDUCE[SW1;2+I]((B1,B2) ⍴ B)OUTER[SW2](C1,C2) ⍴ C
LENERR: 1 2 = 1 2 3 ⍝LENGTH ERROR
∇
∇ A ← B DYSCFNS[SWITCH] C
→1+SWITCH
RETURN // A ← B = C
RETURN // A ← ~ B = C
RETURN // A ← B + C
RETURN // A ← B - C
RETURN // A ← B × C
RETURN // A ← B÷C
RETURN // A ← (B × A) + C × ~ A ← C < B
RETURN // A ← (C × A) + B × ~ A ← C < B
RETURN // A←C-B×⌊C÷B+B=0 ⍝APLSV DYADIC |
RETURN // A ← B * C
RETURN // A ← B LN C
RETURN // A ← B CIRCLESC C
RETURN // A ← B COMSC C
RETURN // A ← B < C
RETURN // A ← ~ C < B
RETURN // A ← ~ B < C
RETURN // A ← C < B
RETURN // A ← B ∨ C
RETURN // A ← B ∧ C
RETURN // A ← ~ B ∨ C
RETURN // A ← ~ B ∧ C
⍝ ORDER: = ≠ + - × ÷ ⌈ ⌊ |
⍝ * LN ○ GAMMA < ≤ ≥ > ∨
⍝ ∧ NOR NAND
∇
∇ A ← RHOA IDELEM I
I ← 1 ∨ 1+2=A←(1 0 0 0 1 1,MINNUMBER,MAXNUMBER,0 1 2 2 1 0 1 1 0 0 1 2 2)[I]
⍝ THIS FUNCTION COMPUTES THE IDENTITY ELEMENT FOR THE ITH PRIMITIVE
⍝ FUNCTION. P-FNS WITH NO SUCH ELEMENT, SUCH AS NAND, INVOKE A
⍝ DOMAIN ERROR.
A ← RHOA ⍴ A ∇
∇ A ← B (∊) C
→OR_IT+0=A←'' ⍴ ⍴ C←,C // ↓(⍴B)⍴0
OR_IT: →OR_IT+0=A←A-1 // ↓(B=C[A]) ∨ ↑
A←↑
∇
∇ A ← B (⍳) C;D;E;I;J
→ 6 IF (⍴ A←,C)=J←0 // E←'' ⍴ ⍴ B←B,0 // D← ⍴ C
C ← B = B[E]←A[J←J+~ I←0] ⍝C[E] IS FORCED TO BE ONE
→ 3+C[I←I+1] ⍝C[I] IS ALWAYS ONE ∨ ZERO
A[J]←I ⍝C[I] WAS ONE
→ 2 IF J < ⍴ A
A←D ⍴ A
⍝ERROR UNLESS 1 GE ⍴ ⍴ B
⍝360 ENHANCEMENT: B MAY BE A SCALAR, IF SO, TREATED LIKE A VECTOR
∇
∇ A ← ROTATE[○DIM] SRC;I;I2;INCR;LEN;N;RANK;RHOS;START
→ VECTORSCAL IF (RANK←'' ⍴ ⍴ RHOS← ⍴ SRC)<2
→ DEFINEDIM+ϵDIM
DEFINEDIM: DIM←RANK
LEN←RHOS[I←DIM←(⍳DIM<DIM) ⍴ DIM]
INCR←1
→ GENINCR+I=RANK
GENINCR: → GENINCR+I=RANK // INCR←INCR × RHOS[I←I+1]
→ DONE IF 0=I←'' ⍴ ⍴ A←SRC←,SRC // LEN←LEN × INCR
SKIP: N←0
VECTOR: START←-INCR-RANK←(I2←I+INCR-N)-LEN
ELEM: A[I2←I2-INCR]←SRC[START←START+INCR]
→ ELEM IF RANK<I2
→ VECTOR IF (N←N+1)<INCR
→ SKIP IF 0<I←I-LEN
DONE: RETURN // A←RHOS ⍴ A
VECTORSCAL: → 0 UL RANK // A←SRC
→ 0 IF (I←1+'' ⍴ ⍴ A)<3 // START←0
V2: → V2+1=I // A[I←I-1]←SRC[START←START+1]
∇
∇ A ← B ROTATE[○DIM] SRC;AI;BI;SI;BASE;I;INCR;LEN;N;RHOS
→ VECTORSCAL IF (BASE←'' ⍴ ⍴ RHOS← ⍴ SRC)<2
→ DEFINEDIM+ϵDIM
DEFINEDIM: DIM←BASE
LEN←RHOS[AI←(⍳DIM<DIM) ⍴ DIM]
→ DONE+0<I←'' ⍴ ⍴ A←SRC←,SRC
DONE: RETURN // A←RHOS ⍴ SRC←A ⍝ EXTRANEOUS ASSIGNMENT SAVES WORKSPACE
B←B-LEN×⌊B÷LEN ⍝ B←LEN | B
→ MULTI IF 2<BI←1+'' ⍴ ⍴ B←,B // N← ⍴ B
→ MULTI+1 // BI←1+'' ⍴ ⍴ B←,((~AI=⍳BASE)/RHOS) ⍴ B
MULTI: N αCOMPAT (~AI=⍳BASE)/RHOS
INCR←1
→ GENINCR+AI=BASE
GENINCR: → GENINCR+AI=BASE // INCR←INCR × RHOS[AI←AI+1]
LEN←LEN × INCR
SKIP: → DONE IF (I←I-LEN)<N←0
→ ELEM2 IF (AI←0)=SI←B[BI←BI-1] × INCR // BASE←I-N
ELEM1: A[BASE+AI←AI+INCR]←SRC[BASE+SI←SI+INCR]
→ ELEM1 IF SI<LEN
SI←0
ELEM2: A[BASE+AI←AI+INCR]←SRC[BASE+SI←SI+INCR]
→ ELEM2 IF AI<LEN
→ SKIP+(N←N+1)<INCR
VECTORSCAL: → 0 UL BASE // A←SRC
B←(⍳B<B) ⍴ B ⍝ → LERR IF 1< ⍴ ,B
→ 0 IF 0=RHOS←'' ⍴ RHOS
→ E2 IF (AI←0)=SI←B-RHOS×⌊B÷RHOS
E1: A[AI←AI+1]←SRC[SI←SI+1]
→ E1 IF SI<RHOS
SI←0
E2: A[AI←AI+1]←SRC[SI←SI+1]
→ E2 IF AI<RHOS
∇
∇ A ← B (↑) C;AS1;AS2;CS1;CS2;I;J
→ RERR IF 1< ⍴ ⍴ B
→ SCAC + 0<I←'' ⍴ ⍴ J← ⍴ C
SCAC: I←'' ⍴ ⍴ J // C←(J←B=,B) ⍴ C
→ LERR UL I= ⍴ B←,B
→ NULL UL ANDREDUCE 0<J
→ 0 UL ANDREDUCE 0< ⍴ A←(|B) ⍴ ' ' 0[1+⍳ ''⍴C]
→ 0 IF I=0 ⍝C IS SCALAR
CS2←0 ⌈ (B<0) × B+J
B←J ⌊ | B // AS2←0 ⌈ -B+J
AS2←AS2[I] // AS1←AS2[1]
CS2←CS2[I] // CS1←CS2[1]
J←B[1]
→ VECT IF I=1 ⍝C IS VECTOR
→ RERR UL I=2 ⍝C ~ MATRIX
I←B[2]
MAT: A[AS1+J;AS2+I]←C[CS1+J;CS2+I]
→ MAT IF 0<I←I-1
→ MAT-⍳0<J←J-1
RETURN
VECT: → VECT-0=J←J-1 // A[AS1+J]←C[CS1+J]
RERR: I=I ⍴ I←⍳2
LERR: 1 2 = 1 2 3
NULL: A←(|B) ⍴ 0
∇
∇ A ← B (↓) C;I;J;II;JJ;STARTCOL;STARTROW
→ SCALAR IF 0=⍴ J←⍴ C
⍝ NEXT STATEMENT INDUCES A LENGTH ERROR WHEN APPROPRIATE
→ RERR UL ((I←'' ⍴ ⍴ J←J-|B)<3) ∧ (1=⍴ ,B) ∨ 1=⍴ ⍴ B
→ MAT IF I=2
→ NULLVEC UL 0<J
A ← J ⍴ C
→ 0 UL (I←0)<B←'' ⍴ B
VEC: → VEC+J=I // A[I]←C[B+I←I+1]
RETURN
NULLMAT: RETURN // A←(J × 0<J) ⍴ ''
NULLVEC: RETURN // A←''
SCALAR: RETURN // A←(B=0) ⍴ C
RERR: I=I ⍴ I←⍳2 ⍝GENERATES A RANK ERROR
MAT: → NULLMAT UL (0<JJ←J[2])∧0<II←'' ⍴ J
A ← J ⍴ C
STARTCOL←J[2] // STARTROW←'' ⍴ J←2 ⍴ B × (I←0)<B
MATROW: I←I+1 // STARTROW←STARTROW+1 // J←0
MATCOL: A[I;J]←C[STARTROW;STARTCOL+J←J+1]
→ MATCOL IF J<JJ
→ MATROW IF I<II
⍝ DROP IS IMPLEMENTED ONLY FOR SCALAR, VECTOR, ∨ MATRICE
⍝ RIGHT ARGUMENTS.
⍝ SCALAR DROP MATRICE EXECUTES LIKE (SCALAR,SCALAR) DROP MATRICE
⍝ RANK ERROR OCCURS
⍝ IF RIGHT ARGUMENT RANK > 2, OR
⍝ IF LEFT ARGUMENT HAS AN INVALID RANK.
∇
∇ A ← UPGRADE VECT;I;INDEX;REMEMBER;RHOV;V;VAL
→ 0 IF 0=RHOV←(,INDEX = 0 0 ⍴ I←0) ⍴ INDEX← ⍴ A←VECT
SEARCH: INDEX←0
⍝ REMEMBER ← SMALLEST INDEX OF THE SMALLEST NUMBER ENCOUNTERED.
→ REMEM - 'M' = VECT[INDEX←INDEX+1]
REMEM: VAL←VECT[REMEMBER←INDEX]
CHECK: → (INDEX = RHOV) ⍴ THRU
→ ('M'=V←VECT[INDEX←INDEX+1]) ⍴ CHECK
→ CHECK - V < VAL
THRU: VECT[A[I←I+1]←REMEMBER]←'M'
→ SEARCH IF I<RHOV
⍝ E R R O R T R A P S
⍝ RANK ERROR (5,0): 1 ≠ ⍴⍴VECT
⍝ TYPE ERROR (7,0): OR/VECT ELEMENT ANY CHAR EXCEPT 'M'
∇
∇ A ← DOWNGRADE VECT
A←UPGRADE -VECT ∇
∇ A ← B αCαOαMαAα C
⍝ *********** MICROPROGRAM ASSUMES 20B ↔×[2]COMA ***********
A←B,[] C ⍝ INVOKE THE CRMS-APL , INSTRUCTION
∇
∇ A ← INDEX1[VAR;I1];RHOA;RHO1;J1
→ IERR UL 1=⍴⍴VAR
→ DEFI1+ϵI1
DEFI1: I1←⍳(⍴VAR)[1]
RHO1←'' ⍴ ⍴ A←I1←,I1 // RHOA← ⍴ I1 // J1←0
→6+RHO1=J1
→5 // A[J1]←VAR[I1[J1←J1+1]]
→ 0 ∧ I1=⍴ RHOA
RETURN // A←RHOA⍴A
IERR: 1 2[1;1]
∇
∇ A ← INDEX2[VAR;I1;I2];I1R1;R1;R2;RA;RHOA
→ IERR UL 2=⍴⍴VAR
→ DEFI1+ϵI1
DEFI1: I1←⍳(⍴VAR)[1]
→ DEFI2+ϵI2
DEFI2: I2←⍳(⍴VAR)[2]
RHOA←(⍴I1),⍴I2
A←(RA←(R1←'' ⍴ ⍴ I1←,I1) × '' ⍴ ⍴ I2←,I2) ⍴ VAR
→ END IF 1=RA←RA+1 ⍝ INITIALIZE PRE-DECREMENTING POINTER
I1R1←I1[R1] // R2←'' ⍴ ⍴ I2
AI1: →AI1+0=R2←R2-1 // A[RA←RA-1]←VAR[I1R1;I2[R2]]
→AI1-⍳0<R1←R1-1
END: RETURN // A←RHOA⍴A
IERR: 1 2[1;1]
∇
∇ A ← INDEX3[VAR;I1;I2;I3];I1R1;I2R2;R1;R2;RA;RHOA
→ IERR UL 3=⍴⍴VAR
→ DEFI1+ϵI1
DEFI1: I1←⍳(⍴VAR)[1]
→ DEFI2+ϵI2
DEFI2: I2←⍳(⍴VAR)[2]
→ DEFI3+ϵI3
DEFI3: I3←⍳(⍴VAR)[3]
RHOA←(⍴I1),(⍴I2),⍴I3
A←(RA←(R1←'' ⍴ ⍴ I1←,I1) × ('' ⍴ ⍴ I2←,I2) × '' ⍴ ⍴ I3←,I3) ⍴ VAR
→ END IF 1=RA←RA+1
I1R1←I1[R1] // R2←'' ⍴ ⍴ I2
AI1: I2R2←I2[R2] // R3←'' ⍴ ⍴ I3
AI2: →AI2+0=R3←R3-1 // A[RA←RA-1]←VAR[I1R1;I2R2;I3[R3]]
→AI2-⍳0<R2←R2-1
→AI1-⍳0<R1←R1-1
END: RETURN // A←RHOA⍴A
IERR: 1 2[1;1]
∇
∇ A ← TRANSPOSE B;RHOA;RANK;IX;X;Y
→ TWOD IF 2=RANK←'' ⍴ ⍴ RHOA←⍴ A←B
→0 IF RANK<2
RETURN // A←((1+RANK)-⍳RANK) TRANSPOSE B ⍝ APLSV TREATMENT OF MONADIC TRANSPOSE
⍝
⍝ ~ WASTEFUL SINCE MOST MONADIC TRANSPOSES INVOLVE
⍝ TWO-D MATRICES.
TWOD: A←((Y←RHOA[2]),IX←'' ⍴ RHOA) ⍴ B
→ 0 IF 0=IX × Y ⍝ IS MATRIX 0 BY N OR N BY 0 ??
X←IX ⍝NO SUCH LUCK.
MOVE2: A[Y;X]←B[X;Y] ⍝MOST REGRETTABLY, SUBSCR × TAKES TIME.
→MOVE2 IF 0<X←X-1
→ MOVE2-⍳0<Y←Y-1
⍝ NO ERRORS ARE EXPLICITLY GENERATED.
∇
∇ Z ← A TRANSPOSE B;RB;RZ;I;J;W1;W2;CZ
→RERR IF 1<⍴⍴A
→LERR IF (J←'' ⍴ ⍴ RB←⍴ Z←B) ≠ ⍴ A←,A
→0 IF J<2
W1←J⍴CZ←'' ⍴ (2-ANDREDUCE(A=⌊A)∧A>0) ∧ 2-ANDREDUCE(⍳I←⌈/A)∊A ⍝CHECK DOMAIN
INITΔW1: W1[J←J-1]←W1[J]×RB[J]
→INITΔW1 IF 1<J
RZ←W2←I⍴0
LOOP: CZ←CZ×RZ[J]←⌊/(Z←J=A)/RB
W2[J]←+/Z/W1
→LOOP UL I<J←J+1
B←,B // Z←CZ⍴0
→SHAPE IF CZ=0
VECT: A←CZ←J←1
I←'' ⍴ ⍴ RZ
ELEM: J←J+W2[I]×W1-RZ[I]×A←⌊(W1←A)÷RZ[I]
→ELEM IF 0<I←I-1
Z[CZ]←B[J]
→VECT IF 0<CZ←CZ-1
SHAPE: →0 // Z←RZ⍴Z
RERR: I=I⍴I←⍳2
LERR: 1 2 = 1 2 3
∇
∇ A←B (,) [○DIM] C;RA;RB;RC;RRB;RRC;RANK;I;M;N;NB;NC;COMPERAND
⍝ LOCALS DEFINED IN THE NEXT STATEMENT ARE CHANGED IFF B ∨ C CHANGED
RANK←(RRB,RRC)[1+(RRB←'' ⍴ ⍴ RB←⍴ B)<RRC←'' ⍴ ⍴ RC←⍴ C]
→ DEFINEDIM+ϵDIM
DEFINEDIM: DIM←RANK ⍝GENERATE ERR IF DIM HAS MORE THAN ONE ELEMENT.
→ LAMINATE IF DIM<I←⌈DIM
→ EASY IF RANK<2
→ SCLRB IF RRB=0
→ SCLRC IF RRC=0
→ RERR IF 1<|RRB-RRC
⍝ M←M=N 2 LINES DOWN IS LEN ERR IF RANK ERR ~ CAUGHT HERE.
NC←(M←RC,⍳RRC<RRB)[DIM←(⍳I←0)⍴DIM]
M←M=N // N[DIM]←1+NC+NB←(N←RB,⍳RRB<RRC)[DIM]
⍝ NB ∧ NC ARE LENS OF THE INTERESTING DIMENSIONS OF B ∧ C.
CHECKONE: → CHECKONE IF M[I←I+1]
→ LASTDIM IF N←I=RANK
M←((⍳RRB<RRC),RB)=RA←(⍳RRC<RRB),RC
→ LERR IF (~ N←I=DIM) ∨ (M[RANK]←0) = M[RANK]
CHECKTWO: → CHECKTWO IF M[I] // N←N × RA[I←I+1]
→ LERR UL I=RANK
LASTDIM: → RELATIONAL+(RRC<RRB)-RRB<RRC // RA←RC
SCLRB: M←((RANK-1) ⍴ RB[DIM]←N←1),0 // NC←(RA←RB←RC)[I←DIM]
→ (CHECKTWO,LASTDIM)[1+I=RANK] // B←RB⍴B
SCLRC: M←((RANK-1) ⍴ RC[DIM]←N←1),0 // NB←(RA←RC←RB)[I←DIM]
→ (CHECKTWO,LASTDIM)[1+I=RANK] // C←RC⍴C
⍝
⍝⍝⍝⍝⍝ LAMINATION SEGMENT ⍝⍝⍝⍝⍝
⍝
LAMINATE: → LAMSCA IF (M←RRB=0) ∨ N←RRC=0
→ RERR UL ((RANK←RANK+I←1)=RRB←'' ⍴ ⍴ RB←(DIM←I),RB) ∧ RANK=RRC
PRESQUEEZE: → LERR UL RC[I]=RB[I]←RB[N←I+1]
→ PRESQUEEZE IF (I←N)<DIM
→ LASTDIM IF NB←N←I=RANK
→ CHECKTWO IF (M[RANK]←0)<(M←RB=RA←(NB←N←1),RC)[RANK]
LERR: 1 2 + 1 2 3
RERR: I+I⍴I←⍳2
LAMSCA: → EASY+N-M
→ LAMINATE+1 // RRB←RRC // B←(RB←RC)⍴B
EASY: RETURN // A←B,C
→ LAMINATE+1 // RRC←RRB // C←(RC←RB)⍴C
⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝
NB←1
RELATIONAL: → CONTINUE ⍝CALLING PROCEDURE: → RELATIONAL+/-1
RA←RB // NC←1
CONTINUE: NB←NB × N // NC←NC × N // RA[DIM]←NB+NC
I←M←N←COMPERAND←0 // RANK←'' ⍴ ⍴ A←(B←,B),C←,C
⍝⍝⍝⍝⍝ CATENATION ∧ LAMINATION COMMON LOOP (RANK RE-DEFINED) ⍝⍝⍝⍝⍝
→ FINI IF (I=DIM) ∨ I=RANK
CATENLOOP: COMPERAND←NB+COMPERAND
L1: A[I←I+1]←B[M←M+1]
→ L1 IF I<COMPERAND
COMPERAND←NC+COMPERAND
R1: A[I←I+1]←C[N←N+1]
→ R1 IF I<COMPERAND
Source page ends mid-function; continuation on PDF p.25 follows below.
→ CATENLOOP IF I<RANK FINI: A←RA ⍴ A ∇
∇ A ← B (/)[○DIM] C;AI;BI;CI;CMAX;N;NI;RHOB;RHOC
→ DEFINEDIM-⍳0<⍴RHOC←⍴C ⍝BRANCH IF C IS AN ARRAY
→0∧⍳1=⍴N // A←(N←,B∨0)⍴C ⍝256<⍴,B FOR B/SCALAR ASSUMED
RHOC←⍴C←,C ⍝VECTOR/SCALAR IS TREATED LIKE VECTOR/1 ⍴ SCALAR
→ DEFINEDIM+ϵDIM
DEFINEDIM: DIM←'' ⍴ ⍴ RHOC ⍝ASSIGN DEFAULT DIMENSION INDEX.
→ QUICK1 IF 1=⍴,B
→ RERR UL 1=⍴RHOB←⍴B ∨ 0 ⍝B MUST BE A BINARY VECTOR
→ NOT1TO1 UL RHOC[DIM]=RHOB←'' ⍴ RHOB
→ NULL IF (0=CMAX←'' ⍴ ⍴ C←,C) ∨ RHOB=AI←CI←0
→ LASTDIM IF DIM=⍴RHOC // B←B,2 // A←CMAX⍴C
→ NDONE IF BI=⍴RHOC // N←RHOC[BI←DIM+1]
→ NDONE-⍳BI<⍴RHOC // N←N × RHOC[BI←BI+1]
NDONE: BI←0 // CI←CI-N
FINDNL: → FINDNL+B[BI←BI+1] // CI←CI+N // NI←0
→ FINDNL+NI<N // A[AI←AI+1]←C[CI+NI←NI+1] ⍝ASSIGN A[AI+⍳N]
→ LGO // → FINDNL-⍳CI<CMAX
LASTDIM: BI←0
FINDL: → FINDL+B[BI←BI+1]
→ FINDL // A[AI←AI+1]←C[CI+BI]
→ FINDL-⍳(CI←CI+RHOB)<CMAX
LGO: RHOC[DIM]←(RHOC[DIM]×AI)÷CI ⍝COMPUTE RHOC[DIM]←+/B
RETURN // A←RHOC⍴A
QUICK1: → QUICK1F UL B ⍝TRAP IF B ~ BINARY
RETURN // A←C
QUICK1F: RETURN // A←RHOC⍴RHOC[DIM]←0
NOT1TO1: → LERR UL (1=⍴,C) ∧ 1=⍴⍴C ⍝LENGTH ONE VECTOR
RETURN // A←(+/B)⍴C
NULL: RETURN // A←RHOC⍴RHOC[DIM]←+/B ⍝''/ARRAY ∨ B/NULLARRAY
LERR: 1 2 = 1 2 3 ⍝LENGTH ERROR
RERR: N=N⍴N←⍳2 ⍝RANK ERROR
∇
∇ A ← B (\)[○DIM] C;RA;RC;I;IA;IC;N;NN
→ SCLR+0<I←'' ⍴ ⍴ RA←⍴C
SCLR: I←1 // RA←⍴C←,C
→ DEFINEDIM+ϵDIM
DEFINEDIM: DIM←I
→ RERR IF 1<⍴⍴B ∨ IA←IC←0 ⍝B BETTER BE BIN SCA ∨ VECT
→ REDUCEEXPAND+0=N←'' ⍴ ⍴ B←,B
REDUCEEXPAND: → REDUCEEXPAND+IC=N // IA←IA+B[IC←IC+1]
→ NOMATCH UL IA=RA[DIM]
REMATCH: RA[DIM]←N
→ NULL IF 0=RC←'' ⍴ ⍴ C←,C
A←,RA ⍴ ' ' 0[1+⊥ ''⍴C] // B←B,2 // AI←CI←0
→ LAST-⍳I=DIM
→ INCR+I=NN // N←RA[NN←1+DIM]
INCR: → INCR+I=NN // N←N × RA[NN←NN+1]
I←0 // AI←AI-N
NLAST: → NLAST+B[I←I+1] // AI←AI+N // NN←0
→ NLAST+NN<N // A[AI+NN←NN+1]←C[CI←CI+1]
→ NLAST-⍳CI<RC
RETURN // A←RA⍴A
I←0
LAST: → LAST+B[I←I+1]
→ LAST // A[AI+I]←C[CI←CI+1]
→ LAST-⍳CI<RC // AI←AI+I-1
RETURN // A←RA⍴A
NULL: RETURN // A←RA⍴0
FILL: RETURN // A←N⍴' ' 0[1+⊥ ''⍴C]
NOMATCH: → LERR UL (I=1) ∨ 1=RA[1]
→ FILL IF IA=0
→ REMATCH // C←IA⍴C ⍝DIM=1
LERR: 1 2 = 1 2 3
RERR: I=I⍴I←⍳2 ∇
∇ Z←OUTONE[○QQ] A;B;I;NOBLANK
→IPIO IF (ϵ⎕IO_BOXES) // Z←A ⍝ SAVE RETURN VALUE
A←,A // NOBLANK←1+I←0
DECIDE: →LAST IF (⍴A)<I←I+1
→ (CH,NUMERIC)[1+⊥ B←A[I]]
CH: OUTCHARSC B // NOBLANK←1
→ DECIDE
NUMERIC: → PBL IF NOBLANK
OUTCHARSC ' '
PBL: OUTNUMSC B
→ DECIDE // NOBLANK←0
IPIO: ⎕IO_BOXES[2] ⎕DELIVER A
LAST: →0∧⍳QQ // →0∧⍳~ϵQQ ⍝ EXIT NOW IF QQUAD OUTPUT
⊢←CRLF
∇
∇ OUTNUMSC A;B;C;TEXP
// OUTONE (A<0) ⍴ '-'
→ INT IF (B<1000000) ∧ (99999<B) ∨ B=⌊ B←| A // C←''
→ FLLT1 IF B<1 // TEXP←0
→ FLLT100000 IF B<100000
DOWN: → DOWN+(B←B÷10)<10 // TEXP←TEXP+1
OUTNUMSC B
OUTCHARSC 'E'
OUTNUMSC TEXP
RETURN
FLLT100000: OUTNUMSC ⌊ B
OUTCHARSC '.'
FRACTPART B
RETURN
FLLT1: → FLLT1 IF (B←B × 10)<1 // TEXP←TEXP-1
→ DOWN+1
INT: → INT+0=B←A // C←'0123456789'[1+⌊ B-10×A←⌊ B÷10],C
// OUTONE C
RETURN ∇
∇ FRACTPART A;B;SCALE
SCALE←1 // B←6 ⍝ MAX SIGNIFICANT DIGITS
GETSC: → GETSC+A<SCALE←SCALE × 10 // B←B-1
DIGIT: OUTCHARSC '0123456789'[1+⌊ A←10 × A-⌊ A]
→ DIGIT IF (A>⌊ A) ∧ 0<B←B-1
∇
∇ A←(⊣)
// OUTONE '*'
⎕IO_BOXES[1] ⎕SETCONV 1
A←⎕RECEIVE αA←⎕IO_BOXES[1]
A←,A ⍝ NO FUNNY STUFF ALLOWED.
∇
∇ A←INONE B;C;D
// OUTONE B // A←''
→IPIO IF ϵ⎕IO_BOXES
READ: → BSP IF '↑'=C←INCHARSC
→ NEWL IF '\'=C
→ DONE IF 109=⊤C ⍝CARRIER RETURN ENCOUNTERED.
→ READ // A←A,C
BSP: → READ // A←((0<D)×D←¯1+⍴A)⍴A
NEWL: → 1 // OUTONE '←<',CRLF
DONE: // OUTONE CRLF
RETURN
IPIO: ⎕IO_BOXES[1] ⎕SETCONV 0
A←⎕RECEIVE αA←⎕IO_BOXES[1]
∇
∇ A←(⊢)
A←INONE '' ∇
∇ A←⎕INNUM;B;D;I;SIGN
→IPIO IF ϵ⎕IO_BOXES
→BADIS IF (A←0)=⍴B←INONE '⎕: ',⊤106
I←SIGN←'-' = ''⍴B
MORE: → NOMORE IF (⍴B)<I←I+1
→ BADIS IF (D<0) ∨ 9<D←(TBL[I])-⊤'0'
→ MORE // A←D+A × 10
BADIS: 'MALFORMED INTEGRAL SCALAR INPUT.'
→ 1
NOMORE: A←A × 1-SIGN+SIGN
RETURN
NOGOOD: 'TRY AGAIN'
IPIO: // OUTONE '--> ',T106
⎕IO_BOXES[1] ⎕SETCONV 1
A←⎕RECEIVE αA←⎕IO_BOXES[1]
→NOGOOD IF 0=⍴A←(⊥A)/A
∇
∇ B αCOMPAT C;A;I
→ SQUEEZE1B-(⍴B)=⍴C ⍝B ∧ C ARE VECTORS
→ 0 IF ANDREDUCE B=C
SQUEEZE1B: → SQUEEZE1C IF 0=I←'' ⍴ ⍴ B // A←''
→ SQUEEZE1B+⍳0<I←I-1 // A←A,B[I]+⍳1 ≠ B[I]
SQUEEZE1C: → TESTEQ IF 0=I←'' ⍴ ⍴ C // B←''
→ SQUEEZE1C+⍳0<I←I-1 // B←B,C[I]+⍳1 ≠ C[I]
TESTEQ: → LERR UL (⍴A)=⍴B
→ 0 IF ANDREDUCE A=B
LERR: 1 2 = 1 2 3 ∇
∇ A←ASINDEX1[⍴B;I1] C;RC
→ IERR UL 1=⍴⍴B
→ DEFI1+ϵI1
DEFI1: I1←1 ⍴ B
→ SINGLE IF 1=RC←'' ⍴ ⍴ C←,A←C
I1←,I1 // (⍴A) αCOMPAT ⍴I1
→ 0 IF 0=RC
AI1: → AI1+0=RC←RC-1 // B[I1[RC]]←C[RC]
RETURN
SINGLE: → AI1-1 // C←(RC←'' ⍴ ⍴ I1←,I1) ⍴ C
IERR: 1 2[1;1] ∇
∇ A←ASINDEX2[⍴B;I1;I2] C;I1R1;RC;R1;R2
→ IERR UL 2=⍴⍴B ⍝ CHECK RANK
→ DEFI1+ϵI1
DEFI1: I1←⍳(⍴B)[1]
→ DEFI2+ϵI2
DEFI2: I2←⍳(⍴B)[2]
→ SINGLE IF 2=RC←1+'' ⍴ ⍴ C←,A←C
I1←,I1 // I2←,I2 // (⍴A) αCOMPAT (⍴I1),⍴I2
→ 0 IF 1=RC // R1←'' ⍴ ⍴ I1
R2←'' ⍴ ⍴ I2 // I1R1←I1[R1]
AI1: → AI1+0=R2←R2-1 // B[I1R1;I2[R2]]←C[RC←RC-1]
→ AI1-⍳0<R1←R1-1
RETURN
SINGLE: RC←1+'' ⍴ (⍴I1←,I1) × ⍴I2←,I2
→ AI1-2 // C←(RC-1) ⍴ C
IERR: 1 2[1;1] ∇
∇ A←ASINDEX3[⍴B;I1;I2;I3] C;I1R1;I2R2;RC;R1;R2;R3
→ IERR UL 3=⍴⍴B ⍝ CHECK RANK
→ DEFI1+ϵI1
DEFI1: I1←⍳(⍴B)[1]
→ DEFI2+ϵI2
DEFI2: I2←⍳(⍴B)[2]
→ DEFI3+ϵI3
DEFI3: I3←⍳(⍴B)[3]
→ SINGLE IF 2=RC←1+'' ⍴ ⍴ C←,A←C
(⍴A) αCOMPAT (⍴I1),(⍴I2),⍴I3
I1←,I1 // I2←,I2 // I3←,I3
LASTCHK: R1←'' ⍴ ⍴ I1 // →0∧⍳1=RC
R2←'' ⍴ ⍴ I2 // I1R1←I1[R1]
AI1: R3←'' ⍴ ⍴ I3 // I2R2←I2[R2]
AI2: → AI2+0=R3←R3-1 // B[I1R1;I2R2;I3[R3]]←C[RC←RC-1]
→ AI2-⍳0<R2←R2-1
→ AI1-⍳0<R1←R1-1
RETURN
SINGLE: RC←1+'' ⍴ (⍴I1←,I1) × (⍴I2←,I2) × ⍴I3←,I3
→ LASTCHK // C←(RC-1) ⍴ C
IERR: 1 2[1;1]
∇
∇ Z←SQRT X;D;E;Y
E←X÷0.5 COEFBEXP ⌊129+D+D←⌈0.5×(BEXP X+X=0)-128
Y←2.185183-3.028991÷1.5451577+E+0∧1+E<0
Z←0.5×Z+E÷Z←0.5×Y+E÷Y
Z←Z × 0.5+0.5 × E←Z<1
Z←(0<X) × Z COEFBEXP ⌊ 129+D-E ∇
∇ P←QSC N;Q → 2+ϵRAND RAND←1⌈⌊|''⍴⎕INNUM // OUT[CRLF,' ENTER PSEUDO-RANDOM INTEGER BETWEEN 1 AND 1 MILLION'] RAND←(1000×RAND-1000×⌊(RAND←(389×Q)+17×P)÷1000.)+17×Q←RAND-1000×P←⌊RAND÷1000. ⍝RAND←1E6|RAND×73*3 P←1+⌊N×.99999⌊RAND÷1E6 ∇ ∇ AN←(*) U;F;G;H;I;J;L J←|U÷0.69314718 G←⌊J+0.5 H←J-G I←H × 0.69314718 J←I × I F←2+J×(2520+28×J)÷15120+(420×J)+J×J L←(F+I)÷F-I H←L<1 L←L × H+0.5 × ~ H F←L COEFBEXP ⌊ 129+G-H AN←((U<0)÷F)+F×U>0 ∇ ∇ ABB←A (*) B,10 ⍝A TO THE B = EXP OF B TIMES NATURAL LOG OF A ABB←*B×LN A ∇ ∇ AS←LN X;A;B;G0;A1;A2 A←1 ∧ 1+X ≤ 0 A←A+A←COEF X B←0.5 × 1+A A1←0.5 × B+G0←SQRT A A2←(0.5 × A1+SQRT A1 × G0)-0.25 × A1 G0←0.69314718 × (BEXP X)-129 AS←G0+0.703125×(A-1)÷A2-0.0625×A1-0.25×B ∇
∇ C←A LN B,11 C←(LN B) ÷ LN A ∇ ∇ A ← B (⊤) C;RHOA → DONE IF 0=(I←(A←'')⍴⍴B←,B) × ⍴C←,C // RHOA←(⍴B),⍴C LOOP: A←((-B[I]×C←⌊C÷B[I])+C),A ⍝PORNO → LOOP UL 0=I←I-1 DONE: A←RHOA ⍴ A ⍝ THIS DECODE DIFFERS FROM APL/360 IN THE TREATMENT OF: ⍝ NEGATIVE LEFT ARGUMENTS ⍝ ∧ NONCONFORMING DIMENSIONS ∇ ∇ A ← B (⊥) C;COUNT;I;LASTI;RHOB → SCALAR IF 0=A←'' ⍴ ⍴ RHOB←⍴B → MAKEONE IF 1=COUNT←RHOB[A] → MATMULT IF 1=I←1+'' ⍴ ⍴ B←,B LASTI←I-COUNT // A←1 ITER: → ITER+LASTI=I // A←(B[I]+A) × B[I←I-1] → ITER-⍳1<LASTI MATMULT: RETURN // A←(RHOB ⍴ B)+.× C SCALAR: A←1 // RHOB←⍴B←,B MAKEONE: A←(RHOB ⍴ B∘.*A-⍳A←RHOB[A]←'' ⍴ (⍴C),1)+.× C ∇
∇ ANNS←A CIRCLESC B;Z;Z2;K;L;M;N;P;Q;R
⍝ BRANCH TO THE APPROPRIATE PORTION OF CIRCLE
→ (ATH,ACH,ASH,M4,AT,AC,AS,ZER,SS,CS,TA,P4,SH,CSH,TH)[8+A]
⍝
⍝ ARCTANGENT HYPERBOLIC
⍝
ATH: ANNS←0.5×LN (1+B)÷1-B
RETURN
⍝
⍝ ARCCOSINE HYPERBOLIC
⍝
ACH: ANNS←LN B+SQRT ¯1+B×B
RETURN
⍝
⍝ ARCSINE HYPERBOLIC
⍝
ASH: ANNS←LN B+SQRT 1+B × B
RETURN
M4: ANNS←SQRT (B+1) × B-1
RETURN
ZER: ANNS←SQRT (1+B) × 1-B
RETURN
P4: ANNS←SQRT 1+B × B
RETURN
⍝
⍝ ARC TANGENT
⍝
AT: K←| B
L←(0 ≤ K) ∧ (K ≤ 1)
M←1<K
N←(L×K)+M÷K+K=0 ⍝ ELSE ÷0 ERROR
K← M × 1.5707963
P←1-M+M
L←(0 ≤ N) ∧ N ≤ 0.414213562373095
M←(N ≤ 1) ∧ 0.414213562373095<N
Q←(L × 0.198912367)+M × 0.668178637
R←(L × 0.1963495408493621)+M × 0.5890486225480862
L←(N-Q)÷1+Q×N
Z←L × L
Z2← Z × Z
M←135135+(171962.4603936874 × Z)+52490.48316373623 × Z2
M←M+2218.098888446071 × Z2 × Z
N←135135+(217007.463936857 × Z)+97799.30329541391 × Z2
N←N+10721.37452059297 × Z2 × Z
ANNS←(×B)×K+P×R+L×M÷N
RETURN
⍝
⍝ ARCCOSINE
⍝
AC: ANNS←1.5707963-¯1 CIRCLESC B
RETURN
⍝
⍝ ARC SINE
⍝
AS: K← | B L←(0 ≤ K) ∧ (K ≤ 0.5) M←(0.5 < K) ∧ (K ≤ 0.8660254037844387) N←(0.8660254037844387<K) ∧ (K ≤ 1) P←(M × 0.7853981633974485)+N × 1.5707963 Q←L+(0.5 × M)-N+N R←(L×K)+(Mׯ1+2×K×K)+N×SQRT 0.5×1-K Z←R × R K←0.01731276426+Z×0.0223750091+Z×0.00934280551+Z×0.01433124507+Z×0.0183566709+Zׯ0.0118622397+Z×0.03162712225 K←0.999999999+Z×0.166666666+Z×0.074999999+Z×0.0446428605+Z×0.0303818164+Z×K ANNS←(× B) × P+Q × K × R RETURN SH: K← * B ANNS←0.5 × K-÷K RETURN CSH: K← * B ANNS←0.5×K+÷K RETURN TH: K← * B L←÷K ANNS←(K-L)÷K+L RETURN TA: K←⌊ B÷PI L←PI × K+1.5707963<B-K × PI M← | B-L N←⌊M÷0.3926990816987241 P←M-N × 0.3926990816987241 R←(N=2)+(0.414213562373095 × N=1)+(2.414213562373095 × N=3) Z←P × P K←2027025+Zׯ270270+Z×6930+Zׯ36 M←2027025+Zׯ945945+Z×51975+Zׯ630 Q←P×K÷M ANNS←(×B-L)×(R+Q)÷1-R×Q RETURN CS: P←Q-⌊Q←(|B)×0.15915494 Q←((P-0.75)×(0.5≤P)∧P<1)+(0.25-P)×(0≤P)∧P<0.5 R←Q×Q ANNS←Q×6.283185+Rׯ41.34168+R×81.60248+Rׯ76.58128+R×39.76072 RETURN SS: P←Q-⌊Q←(|B)×0.15915494 Q←(P×(0≤P)∧P<0.25)+((P-1)×(0.75≤P)∧P<1)+(0.5-P)×(P≥0.25)∧P<0.75 R←Q×Q ANNS←Q×6.283185+Rׯ41.34168+R×81.60248+Rׯ76.58128+R×39.76072 ∇
∇ A ← B (○) C,12;RA;I → ONEB IF ANDREDUCE 1=⍴B ⍝ VERRY VERRY LIKELY RA←⍴ A←B=C → DONE IF 0=I←'' ⍴ ⍴ C←(⍴ B←(⍴ A←,A) ⍴ B) ⍴ C LOOP: A[I]←B[I] CIRCLESC C[I] → LOOP IF 0<I←I-1 DONE: RETURN // A←RA ⍴ A ONEB: → 0 UL ANDREDUCE 1=⍴A←(''⍴B) CIRCLESC C A←(⍴B=C)⍴A ⍝ FORMAT ONE ELEMENT ANSWER ∇ ∇ G←FACSC X;K → L14 IF X<0 K←X-⌊ X G←Kׯ5.100461+Kׯ1.850729 G←¯195.6928+Kׯ66.46644+Kׯ36.83094+G G←G÷¯195.6928+K×16.2694+K×36.8849+K×K-11.43218 → 0 IF (1≤X) ∧ X<2 → L11 IF X<1 K←K+2 L8: G←G × K → L8 IF X≥K←K+1 RETURN L11: G←G÷1+K RETURN K←1+X-⌈ X L14: G←Kׯ5.100461-K×1.850729 G←¯195.6928+Kׯ66.46644+Kׯ36.83094+G G←G÷¯195.6928+K×16.2694+K×36.8849+K×K-11.43218 G←G÷K+1 L16: G←G÷K → L16 IF X<K←K-1 ∇ ∇ A ← EXCLAMATION B,13;I →LOOP+1=I←1+''⍴⍴A←,B LOOP: → LOOP+1=I // A[I]←FACSC A[I←I-1] A←(⍴B)⍴A ∇
∇ COM ← B COMSC A →0 UL COM←B<A COM←(FACSC A) ÷ (FACSC B) × FACSC A-B ∇ ∇ CUT←B EXCLAMATION A CUT←(EXCLAMATION A) ÷ (EXCLAMATION B) × EXCLAMATION A-B ∇ ∇ A ← (?) B;I →LOOP+1=I←1+''⍴⍴A←,B LOOP: → LOOP+1=I // A[I]←QSC A[I←I-1] A←(⍴B)⍴A ∇ ∇ A←B (?) C;I;I2 →DERR UL ((B<I←0)=C<B) ∧ B=⍴B →SAVEΔSP IF 300<C A←⍳C ⍝ ASSUME ENOUGH SPACE TO USE QUICKIE DYADIC ? ALGORITHM. →DONE IF C<2 AGAIN: ↓ A[I2←I+?C-I←I+1] A[I2]←A[I] ⍝ EXCHANGE A[I] WITH A[I2] A[I]←↑ →AGAIN IF I<C-1 DONE: RETURN // A←B⍴A DERR: A←2∧2 SAVEΔSP: A←?C ⍝ PERFORM THE MORE EXPENSIVE DYADIC ? ALGORITHM. →DONE IF B<2 NEW: →NEW+B<⍴A←A,I // →NEW IF (I←?C)ϵA →DONE ∇
∇ OUT[○A;○B;○C;○D;○E;○F;○G;○H;○I;○J;○K;○L] ⊢←A // →2 UL ϵA ⊢←B // →3 UL ϵB ⊢←C // →4 UL ϵC ⊢←D // →5 UL ϵD ⊢←E // →6 UL ϵE ⊢←F // →7 UL ϵF ⊢←G // →8 UL ϵG ⊢←H // →9 UL ϵH ⊢←I // →10 UL ϵI ⊢←J // →11 UL ϵJ ⊢←K // →12 UL ϵK ⊢←L // →13 UL ϵL ∇ ∇ αSTART DUMMY ⎕START 20 2 ⍝ 20 ↔↔24B ↔↔ LOGGING TERMINAL 'ALL UP AND RUNNING (BELIEVE IT OR NOT)' →1 ∇ ∇ ⎕START TM_FN;A;B;C ⎕IO_BOXES←⎕BOXES_TERM TM_FN[1] // →2 IF ϵ⎕IO_BOXES ⎕SLAVES←0 6⍴0 // →3 IF ϵ⎕SLAVES CRLF, 'TYPE SUBJECT TERMINALS' →0∧⍳0ϵA // ⎕←'YOU ENTERED: ',A←⎕INNUM AG: B←(⎕BOXES_TERM A[1]),(⎕CR_BOX 1),⎕CR_BOX 1 OUT[C←'FROM ⎕START' ⎕CR_PROC [130 6,B,⎕CR_BOX 1;3] TM_FN[2] ] ⎕SLAVES←⎕SLAVES,[1] C,A[1],B →AG IF 0<⍴A←1↓A ∇
∇ ⎕KILL ID;A;B →0 UL 6=⍴B←,(A←⎕SLAVES[;1]=ID)/⎕SLAVES // →0 UL ϵ⎕SLAVES ⎕SLAVES←(~A)/⎕SLAVES ⎕DE_PROC B[1] ⎕DETACH B[3 4] ⍝ ⎕IO_BOXES ⎕DE_BOX B[3] // ⎕DE_BOX B[4] ⎕DE_BOX B[5] // ⎕DE_BOX B[6] ⍝ ⎕IPC_BOXES ∇ ∇ ID αINIT STATE ⎕ID←ID →0∧⍳~ϵSTATE ⍝ HEADER ACTS LIKE ID αINIT[○STATE] ⎕WIDTH←STATE[1] ⎕DIGITS←STATE[2] ⎕IO_BOXES←STATE[3],STATE[4] ⎕IPC_BOXES←STATE[5],STATE[6] ⎕ALARM←STATE[7] CRLF ∇ ∇ R ← P ⎕CR_PROC[○STATE;○N] FNUM →INIT_N + ϵN ⍝ SHOULD DEFAULT BE USED? INIT_N: N←4 ⍝ YES. ↓ P // ↓ N // ↓STATE // ↓ FNUM R←↑ // ATTN 1 ∇ ∇ BOXES←⎕BOXES_FILE FILE ↓BOXES←(⎕CR_BOX 1), ⎕CR_BOX 1 // ↓FILE 7 αATN ↑ ⍝ ATTACHFILE ATTENTION TRAP ∇
∇ BOXES←⎕BOXES_TERM TERM ↓BOXES←(⎕CR_BOX 1), ⎕CR_BOX 1 // ↓TERM ATTN 8 ⍝ ATTACHTERMINAL TRAP ∇ ∇ M←⎕RECEIVE ⍴B ATTN 9 // ↓ B B←↑ // M←↑ ∇ ∇ B ⎕SETCONV L ATTN 12 // ↓ B // ↓ L ∇ ∇ STAMP←⎕TS STAMP←↑ ∇
∇ ⎕S_AL[○ALARM] →DEFΔALARM+ϵALARM DEFΔALARM: ALARM←⎕ALARM ∇ ∇ T←⎕R_AL[○ALARM] →DEFΔALARM+ϵALARM DEFΔALARM: ALARM←⎕ALARM ∇