```ratsum←{⎕IO ⎕ML←0 1                         ⍝ ⍺⍺-rational sum of ⍺ and ⍵.

⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ Sum

sum←{lrus mans rrus←⍵                   ⍝ reduction of sum struct ⍵.
cr rru←⍺ rrusum rrus                ⍝ sum of rrus and carry-out.
cm man_←cr rsum mans                ⍝   ..   mans   ..  ..  ..
lru man←cm lrusum lrus man_         ⍝   ..   lrus   ..  ..  ..
lru man rru                         ⍝ sum of struct.
}                                       ⍝ :: ∇ lrus mans rrus → lru man rru

rrusum←{                                ⍝ sum of rrus.
co rru←⍺ rsum ⍵                     ⍝ carry-out and sum.
co=⍺:co rru                         ⍝ carry-out = carry-in: done.
co rsum ⍵                           ⍝ re-input carry-out as carry-in.
}                                       ⍝ :: ci ∇ rrus → co rru

lrusum←{lrus man←⍵                      ⍝ sum of lrus.
co lru←⍺ rsum lrus                  ⍝ carry-out and tentative lru.
co=⍺:lru man                        ⍝ carry-out = carry-in: done.
cc dd←⍺ rsum 2 ¯1↑lrus              ⍝ carry-out, next digit of mantissa.
cc ∇(¯1⌽lrus)(dd,man)               ⍝ carry-in to rhs of lru.
}                                       ⍝ :: ci ∇ lrus → lru man

atab←{                                  ⍝ addition table for digits ⍵.
min←⍵⍳'0'                           ⍝ - minimum value.
vals←-min-⍳⍴⍵                       ⍝ numeric values of digits.
ntab←vals∘.+vals                    ⍝ all sums larg vs. rarg.
base←2/⍴⍵                           ⍝ 2-digit encode/decode vector.
vtab←-min-base⊤base⊥min+base⊤ntab   ⍝ base-⍵:  2-digit addition values.
ptab←↓(min+(¯1⌽⍳3)⍉vtab)⊃¨⊂⍵        ⍝ array of (carry_out result) pairs,
{(ptab,⍵)⍪⍵,⊂'0.'}⍵,¨'.'            ⍝ with additional rows/cols for '.'.
}                                       ⍝ :: ∇ [digits] → [[carry sum];]

rsum←(atab ⍺⍺~'{}'){                    ⍝ row sum of matrix ⍵, carry_in ⍺.
cov itot←↓⍉↑⍺⍺[↓⍉digs⍳⍵]            ⍝ carry vector and initial total.
'0'∧.=cov,⍺:'0'itot                 ⍝ all-zero carry: done.
co tot←'0'∇↑(1↓cov,⍺)itot           ⍝ total with shifted carry vector.
(⊃⊃⌽'0'∇↑co,⊂1↑cov)tot              ⍝ aggregate carry and total.
}                                       ⍝ :: ∇ [d;] → d [d]

⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ Compilation

compile←{                               ⍝ compilation of sum structure.
lmrs wids reps←↓⍉↑trans¨⍺ ⍵         ⍝ numbers and digit counts.
}                                       ⍝ :: rexp ∇ rexp → lmrs

trans←{                                 ⍝ translation of rexp → lmr.
~∧/⍵∊digs,'<|.>':err'bad char'      ⍝ unacceptable character: <0|50%6>
~'<>'≡ext ⍵:err'bad <>s'            ⍝ missing angle-brackets: <99
~'<>'≡⍵∩'<>':err'bad <>s'           ⍝ surplus angle-brackets: <1<2>
~'||'≡⍵∩'||':err'bad ||s'           ⍝ wrong number of bars:   <3|4>
lru man rru←'|'sepr ⍵~'<>'          ⍝ ⍵ split at |-bars.
1∊lru man rru∊⊂'':err'null field'   ⍝ missing field:          <|5|6>
'.'∊lru,rru:err'bad number'         ⍝ unacceptable RU:        <1.2|3|4>
ml←man⍳'.'                          ⍝ no of digits to left of point.
mr←(⍴man)-ml+'.'∊man                ⍝   ..      ..    right     ..
(lru man rru)(ml,mr)(,↑⍴¨lru rru)   ⍝ number and sequence widths.
}                                       ⍝ :: ∇ rexp → (lmr)(n m)(n m)

(l m r)(ml mr)(lr rr)←⍵             ⍝ number struct and paddings.
dot←'.'~m,mr↓'.'                    ⍝ dot separator.
man←(⌽ml⍴⌽l),m,dot,mr⍴r             ⍝ external emission pads mantissa.
rru←rr⍴mr⌽r                         ⍝ internal replication pads RRU.
lru←⌽lr⍴⌽(-ml)⌽l                    ⍝   ..      ..      ..      LRU.
lru man rru                         ⍝ padded structure.
}                                       ⍝ :: ∇ lmr(w w)(w w) → lmr

⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ Normalisation

norm←{crru xabs icon clru ⍵}            ⍝ canonical form of number.

clru←{lru man rru←⍵                     ⍝ try to clear lru to <0|.
∨/∧/optl∘.=lru:⍵                    ⍝ ..00 or ..22 {012}, can't improve.
lw rw←⌈\⍴¨lru rru                   ⍝ lru and rru widths (no of digits).
mw←⍴man~'.'                         ⍝ number of mantissa digits.
_lru←cdigs[digs⍳lru]                ⍝ clearing digits for lru.
_man←'. 'repl(man≠'.')\mw⍴_lru      ⍝ .. replicated through mantissa,
_rru←rw⍴mw⌽_lru                     ⍝ ..    ..  ..  ..  ..  rru.
_lmr←_lru _man _rru                 ⍝ aligned "zero" to add.
lmrr←lru man,⊂rw⍴rru                ⍝ original number with extended rru.
∇'0'sum↑¨↓⍉↑_lmr lmrr               ⍝ sum with ~lru "zero" clears lru.
}                                       ⍝ :: ∇ lmr → lmr

icon←{lru man rru←⍵                     ⍝ internal contraction of RUs.
(⌽minrep⌽lru)man(minrep rru)        ⍝ lru and rru are mirror-symmetric.
}                                       ⍝ :: ∇ lmr → lmr

minrep←{                                ⍝ minimum replicator  010101 → 01
facs←{(0=⍵|⍴⍵)/⍵}1+⍳⍴⍵              ⍝ factors of ⍴rru.
reps←facs⍴¨⊂⍵                       ⍝ 0 01 010 1010 ...
seqs←(⍴⍵)⍴¨reps                     ⍝ 000000 01010101 010010 ...
(seqs⍳⊂⍵)⊃reps                      ⍝ shortest rru.
}                                       ⍝ rru ← ∇ rru

xabs←{lru man rru←⍵                     ⍝ external absorption.
1=⍴man:⍵                            ⍝ <ab|n|pq>: done.
'.'=⊃⌽man:∇ lru(¯1↓man)rru          ⍝ <l|m.|r> → <l|m|r>
('.'∊man)∧(⊃⌽man)=⊃⌽rru:∇ ¯1 amd ⍵  ⍝ <l|nn.ffr|pqr> → <l|nn.ff|rpq>
(~'.'∊2↑man)∧(⊃lru)≡⊃man:∇ 1 amd ⍵  ⍝ <abc|ann.ff|r> → <bca|nn.ff|r>
⍵                                   ⍝ mantissa digits absorbed.
}                                       ⍝ :: ∇ lmr → lmr

amd←{lru man rru←⍵                      ⍝ absorb mantissa digit.
lru←(⍺⌈0)⌽lru                       ⍝ <abc| → <bca|
rru←(⍺⌊0)⌽rru                       ⍝ |pqr> → |rpq>
lru(⍺↓man)rru                       ⍝ mantissa digit absorbed.
}                                       ⍝ :: dirn ∇ lmr → lmr

crru←{lru man rru←⍵                     ⍝ nudge <0|4|9> → <0|5|0> → 5
~rru≡,comp'0':⍵                     ⍝ rru ≠ ~0: give up.
sig←×-/digs⍳rru,'0'                 ⍝ posn of ~0 wrt 0.
inc←(digs⍳'0')⊃sig⌽digs             ⍝ carry-in to rru.
zero←'0'⊣¨¨⍵                        ⍝ conformable zero: <0|000|0>
inc sum↑¨↓⍉↑⍵ zero                  ⍝ alternative representation.
}                                       ⍝ :: ∇ lmr → lmr

⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝⍝ General utility and top-level call

sepr←{⍺{(≢⍺)↓¨(⍺⍷⍵)⊂⍵}⍺,⍵}              ⍝ ⍵ split at separator ⍺.
join←{↑⍺{⍺,⍺⍺,⍵}/⍵}                     ⍝ ⍵ joined with separator ⍺.
repl←{↑⍵{⍺ join ⍵ sepr ⍺⍺}/⍺}           ⍝ subs [⍺0/⍺1]⍵:: str ← to fm ∇ str
comp←{((⌽digs),⍵)[(digs,⍵)⍳⍵]}          ⍝ complement.
fmt←{'|' '.|'repl('|'join ⍵)join'<>'}   ⍝ format of number.
ext←{⌽2↑¯1⌽⍵}                           ⍝ extremal digits.
err←⎕SIGNAL∘11                          ⍝ complain and give up.

digs←↑↓/(1 ¯1×'{}'≡ext ⍺⍺),⊂⍺⍺          ⍝ digits without surrounding {}s.
optl←'0',('0'∊ext digs)/comp'0'         ⍝ optimum lru: 0 or 0,~0

cdigs←{                                 ⍝ lru-clearing digits.
'0'∊ext ⍵:comp ⍵                    ⍝ {012345} → {543210}
(¯1-2×⍵⍳'0')⌽⌽⍵                     ⍝ {≡=-0+#} → {≡#+0-=}
}digs                                   ⍝ :: [d]

xchars←' {}[]()<>\|/,:.'                ⍝ chars excluded from digs.
~'0'∊digs:err'missing zero'             ⍝ bad base: {123)
~digs≡∪digs:err'duplicate digits'       ⍝ bad base: {101}

0=⎕NC'⍺':fmt norm⊃trans comp ⍵          ⍝ monadic: -⍵  complement of number.
fmt norm'0'sum ⍺ compile ⍵              ⍝ dyadic: ⍺+⍵  sum of numbers.
}
code_colours

test script

Back to: notes

Back to: Workspaces
```