HPHP48-P,*0TASSEMBLE
=xPI EQU #1AABD
=x+ EQU #1AB67
=x* EQU #1ADEE
=x/ EQU #1AF05
=xSQRT EQU #1B374
=xSIN EQU #1B4AC
=ELEMENTTYPE EQU #0358F
='EvalNoCK: EQU #18F6A
=putop: EQU #5E51C
=onlyputopCHS EQU #5CD2A
=%%PI EQU #2A458
=%%1 EQU #2A4E0
=%%2 EQU #2A4FA
=%%3 EQU #2A514
=%%4 EQU #2A52E
=%%5 EQU #2A548
=POP2%SPLTAC EQU #29FF8
=NoXcpEND% EQU #2AEDB
=SQRF EQU #2BA0F
=PUTAB1 EQU #2C066
=GPPushR0Lp EQU #307D2
=aATTNFLG EQU #4226C
RPL
xROMID 904
xTITLE QFRAC v0.0'Fin
xCONFIG CfgMe
LABEL CfgMe
:: 904 TOSRRP ;
*********************************
ASSEMBLE
CON(1) 8
RPL
xNAME QFI
::
CK1&Dispatch
ONE Qfi
FIVE
::
RESOROMP xQFI
ZEROZERO 4ROLLSWAP
BEGIN
NEXTCOMPOB
WHILE
::
5PICK EvalNoCK 5UNROLL
ROT#1+UNROT
;
REPEAT
DROPSWAPDROP {}N
;
;
*********************************
ASSEMBLE
CON(1) 8
RPL
xNAME PSLQ
::
CK1&Dispatch
FOUR
::
DUP ELEMENTTYPE
TYPEREAL #= NcaseTYPEERR
DUP DIMLIMITS
INNERCOMP #1= NcaseTYPEERR
ONE #> NcaseTYPEERR
PSLQ
DUPTYPEREAL? ?SEMI
MAT>%
;
;
*********************************
NULLNAME Qfi
::
%0=case ONE{}N
DUP %>%%
NULL{}
{{ X XX LS }}
* A*X^2+B*X+C=0
::
XX DUP %%* XX %%1 THREE
>ARRY PSLQ
DUPTYPEREAL? caseDROP
NORM % 1E6 %< NOTcaseDROP
VEC>STK ( a b c )
DUP%0= IT UNROT
ROT %0=case
::
DROP %CHS SWAP >RAT
LS SWAP >TCOMP LS!
;
UNROT ( a b c )
%4 %* 3PICK %*
OVERDUP %* SWAP %- ( a b d )
ROT %2 %* ( b d 2a )
OVER %SQRT ( b d 2a sqrt )
DUP 5PICK %-
3PICK %/ X %- %ABS ( b d 2a sqrt df+ )
SWAP 5PICK %+ %CHS
3PICK %/ X %- %ABS ( b d 2a df+ df- )
%< ( b d 2a flag+ )
ROT ROOT ( b 2a flag+ n r )
5ROLL %CHS
5PICK >RAT ( 2a flag+ n r '-b/2a' )
ROT
4ROLL ?SKIP %CHS
4ROLL >RAT ( r '-b/2a' 's*n/2a' )
ROT ' xSQRT TWO SYMBN
'EvalNoCK: x*
'EvalNoCK: x+
LS SWAP >TCOMP LS!
;
ATTN? case :: LS ABND ;
* A*PI+B
* X = SIN(------)
* C
::
XX %%ABS %%1 %%< NOT?SEMI
XX %%ASINRAD %%PI %%1 THREE
>ARRY PSLQ
DUPTYPEREAL? caseDROP
NORM % 1E6 %< NOTcaseDROP
VEC>STK ( a b c )
UNROTOVER %CHS >RAT
SYMBOL xPI ;
'EvalNoCK: x*
UNROT %CHS >RAT
'EvalNoCK: x+
syminner putop: xSIN SYMBN
LS SWAP >TCOMP LS!
;
ATTN? case :: LS ABND ;
* X^2 = A+B*SQRT(2)+C*SQRT(3)+D*SQRT(5)
::
%%1 %%2 %%SQRT %%3 %%SQRT %%5 %%SQRT
XX DUP %%* FIVE
>ARRY PSLQ
DUPTYPEREAL? caseDROP
NORM % 1E6 %< NOTcaseDROP
VEC>STK %CHS ( a b c d e )
5ROLL OVER >RAT
5ROLL 3PICK >RAT
SYMBOL %2 xSQRT ;
'EvalNoCK: x* 'EvalNoCK: x+
4ROLL 3PICK >RAT
SYMBOL %3 xSQRT ;
'EvalNoCK: x* 'EvalNoCK: x+
UNROT >RAT
SYMBOL %5 xSQRT ;
'EvalNoCK: x* 'EvalNoCK: x+
syminner putop: xSQRT
X %0< IT onlyputopCHS
SYMBN
LS SWAP >TCOMP LS!
;
ATTN? case :: LS ABND ;
* A*PI^2+B*PI+C*SQRT(PI)+D
* X=------------------------
* E
::
%%PI DUP %%* %%PI DUP %%SQRT
%%1 XX FIVE
>ARRY PSLQ
DUPTYPEREAL? caseDROP
NORM % 1E6 %< NOTcaseDROP
VEC>STK %CHS ( 2 1 .5 0 d )
5ROLL OVER >RAT
SYMBOL xPI %2 x^ ;
'EvalNoCK: x*
5ROLL 3PICK >RAT
SYMBOL xPI ;
'EvalNoCK: x* 'EvalNoCK: x+
4ROLL 3PICK >RAT
SYMBOL xPI xSQRT ;
'EvalNoCK: x* 'EvalNoCK: x+
UNROT >RAT
'EvalNoCK: x+
LS SWAP >TCOMP LS!
;
* ATTN? case :: LS ABND ;
LS ABND
;
*********************************
NULLNAME PSLQ
::
DUPTYPELIST? IT LIST>VEC
DUP ELEMENTTYPE TYPEREAL
#=ITE M>%% TOTEMPOB
DUP DIMLIMITS CARCOMP
DUPDUP TWO{}N %0 MAKEARRY PTR 35D71
M>%% DUP TOTEMPOB
3PICK DUP#1- TWO{}N %%0 MAKEARRY
5PICK TOTEMPOB
DUP TOTEMPOB
6ROLL
* 6 5 4 3 2 1
* x A B H s y n
CODE
My EQU 1 n*1
Ms EQU 2 n*1
MH EQU 3 n*(n-1)
MB EQU 4 n*n
MA EQU 5 n*n
Mx EQU 6 n*1
ABASE #100
N ALLOC 5
I ALLOC 5
J ALLOC 5
K ALLOC 5
M ALLOC 5
t1 ALLOC 21
t2 ALLOC 21
t3 ALLOC 21
t4 ALLOC 21
GOSBVL =POP# A[A]=n
GOSBVL =SAVPTR
D0=(5) (=IRAM@)-4
C=DAT0 A
D0=C
D0=(4) N
DAT0=A A
******* Initializations *********
* For k=1 to n
* s.k=Sqrt(Sum(j=k,n,x.j^2))
* Next
D0=(2) K
A=0 A
A=A+1 A
DAT0=A A
-- A=0 W s=0
R0=A
R1=A
D0=(2) K
A=DAT0 A
D0=(2) J
DAT0=A A
- D0=(2) J
C=DAT0 A
P= Mx
GOSUB GETEL
GOSUB sqf
GOSUB addr
SETHEX
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A<=C A
GOYES -
GOSUB rcab0
GOSUB sqrt
GOSUB stab0
D0=(2) K
C=DAT0 A
P= Ms
GOSUB STOEL
SETHEX
D0=(2) K
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A<=C A
GOYES --
* For k=1 to n
* y.k=x.k/s.1
* s.k=s.k/s.1
* Next
D0=(2) K
C=0 A
C=C+1 A
DAT0=C A
P= Ms
GOSUB GETEL
GOSUB stab2
-- D0=(2) K
C=DAT0 A K
P= My
GOSUB GETEL
GOSUB rccd2
GOSUB divf
D1=D1- 21
GOSUB putab1
C=DAT0 A K
P= Ms
GOSUB GETEL
GOSUB rccd2
GOSUB divf
D1=D1- 21
GOSUB putab1
SETHEX
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A<=C A
GOYES --
*********** Compute H ***********
* For i=1 to n
* For j=i+1 to n-1
* H.ij=0
* Next
* If i<=n-1
* H.ii=s.i+1/s.i
* For j=1 to i-1
* H.ij=-y.i*y*j/(s.j*s.j+1)
* Next
* Next
D0=(2) I
A=0 A
A=A+1 A
DAT0=A A
-- D0=(2) I
A=DAT0 A
D0=(2) J
DAT0=A A
* Test first to exclude corner!
A=0 W
R0=A W
R1=A W
SETHEX
- D0=(2) J
C=DAT0 A
C=C+1 A
DAT0=C A
D0=(2) N
A=DAT0 A
?C>=A A Allow n-1
GOYES +
D0=(2) I
A=DAT0 A
P= MH
GOSUB STOEL
GOTO -
+ D0=(2) N
A=DAT0 A
D0=(2) I
C=DAT0 A
?C>=A A
GOYES +
P= Ms
GOSUB GETEL s.i
GOSUB getcd1 s.i+1
GOSBVL =XYEX
GOSUB divf
GOSUB stab0
* D0=(2) I
A=DAT0 A
C=A A
P= MH
GOSUB STOEL
+ SETHEX
D0=(2) I
A=DAT0 A
A=A-1 A
?A=0 A
GOYES +
D0=(2) J
A=0 A
A=A+1 A
DAT0=A A
- D0=(2) J
C=DAT0 A
P= Ms
GOSUB GETEL
GOSUB getcd1
GOSUB multf
GOSUB stab2
C=DAT0 A
P= My
GOSUB GETEL
GOSUB stab0
D0=(2) I
C=DAT0 A
P= My
GOSUB GETEL
GOSUB rccd0
GOSUB multf
A=-A-1 S
GOSUB rccd2
GOSUB divf
GOSUB stab0
* D0=(2) I
A=DAT0 A
D0=(2) J
C=DAT0 A
P= MH
GOSUB STOEL
SETHEX
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) I
C=DAT0 A
?A<C A
GOYES -
+
* D0=(2) I
C=DAT0 A
C=C+1 A
DAT0=C A
D0=(2) N
A=DAT0 A
?C>A A
GOYES +
GOTO --
+
*********** Reduct H ***********
* For i=2 to n
* For j=i-1 to 1 step -1
* Reduct
* Next
* Next
D0=(2) I
C=0 A
C=C+1 A
C=C+1 A
DAT0=C A
reduct1 D0=(2) I
A=DAT0 A
A=A-1 A
D0=(2) J
DAT0=A A
reduct2 GOSUB Reduct
D0=(2) J
A=DAT0 A
A=A-1 A
DAT0=A A
?A#0 A
GOYES reduct2
D0=(2) I
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A<=C A
GOYES reduct1
************* MAIN **************
* Select m such that
* Gamma^i*Abs(H.ii)
* is maximal when i=m
MAIN D0=(2) M
A=0 W
DAT0=A A M=0
R0=A W
R1=A W MAX=0
D0=(2) I
A=A+1 A
DAT0=A A I=1
GOSUB Gamma
GOSUB stcd2 COEF=Gamma
- D0=(2) I
A=DAT0 A
C=A A
P= MH
GOSUB GETEL H.ii
A=0 S
GOSUB rccd2
GOSUB multf COEF*H.ii
GOSUB rccd0 MAX
GOSUB tst>
GONC +
GOSUB stab0
* D0=(2) I
A=DAT0 A
D0=(2) M
DAT0=A A
+ GOSUB Gamma
GOSUB rcab2
GOSUB multf
GOSUB stab2
SETHEX
D0=(2) I
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A<C A n(n-1)
GOYES -
* Exchange entries m and m+1 of y
* corresponding rows of A and H
* corresponding columns of B
D0=(2) M
A=DAT0 A M
C=A A
C=C+1 A M+1
P= My
GOSUB COLSWAP
A=DAT0 A M
C=A A
C=C+1 A M+1
P= MA
GOSUB ROWSWAP
A=DAT0 A M
C=A A
C=C+1 A M+1
P= MH
GOSUB ROWSWAP
D0=(2) M
A=DAT0 A M
C=A A
C=C+1 A M+1
P= MB
GOSUB COLSWAP
* If m<=n-2 then update H
* t0=sqrt(H[m,m]^2+H[m,m+1]^2)
* t1=H[m,m]/t0
* t2=H[m,m+1]/t0
* For i=m to n
* t3=H[i,m]
* t4=H[i,m+1]
* H[i,m]=t1*t2+t2*t4
* H[i,m+1]=-t2*t3+t1*t4
* Next
SETHEX
D0=(2) M
A=DAT0 A
D0=(2) N
C=DAT0 A
C=C-1 A
?A<C A
GOYES +
GOTO BREDUCT
+ C=A A
P= MH
GOSUB GETEL H[m,m]
GOSUB stab0
GOSUB sqf
GOSUB stab2
GOSUB getab1 H[m,m+1]
GOSUB sqf
GOSUB rccd2
GOSUB addf
GOSUB sqrt
GOSUB stab2 t0
GOSUB rcab0
GOSUB rccd2
GOSUB divf
D0=(2) t1
GOSUB putab0 t1
D1=D1- 21
GOSUB getab1 H[m,m+1]
GOSUB rccd2
GOSUB divf
D0=(2) t2
GOSUB putab0 t2
D0=(2) M
A=DAT0 A
D0=(2) I
DAT0=A A
-- D0=(2) I
A=DAT0 A
D0=(2) M
C=DAT0 A
P= MH
GOSUB GETEL H[i,m]
D0=(2) t3
GOSUB putab0
GOSUB getab1 H[i,m+1]
D0=(2) t4
GOSUB putab0
D0=(2) t1
GOSUB getab0
D0=(2) t3
GOSUB getcd0
GOSUB multf
GOSUB stab0 t1*t3
D0=(2) t2
GOSUB getab0
D0=(2) t4
GOSUB getcd0
GOSUB multf t2*t4
GOSUB rccd0
GOSUB addf t1*t3+t2*t4
GOSUB stab0
D0=(2) I
A=DAT0 A
D0=(2) M
C=DAT0 A
P= MH
GOSUB STOEL
D0=(2) t2
GOSUB getab0
* D0=(2) t3
GOSUB getcd0
GOSUB multf t2*t3
GOSUB stab0
* D0=(2) t4
GOSUB getcd0
D0=(2) t1
GOSUB getab0
GOSUB multf t1*t4
GOSUB rccd0
GOSUB subf t1*t4-t2*t3
GOSUB putab1
SETHEX
D0=(2) I
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A>C A
GOYES +
GOTO --
+
* Perform block reduction on H,
* simultaneously updating y,A,B
BREDUCT
* For i=m+1 to n
* For j=min(i-1,m+1) to 1 step -1
* Reduct
* Next
* Next
SETHEX
D0=(2) M
A=DAT0 A
A=A+1 A
D0=(2) I
DAT0=A A
REDUCT1 SETHEX
D0=(2) I
A=DAT0 A
A=A-1 A i-1
D0=(2) M
C=DAT0 A
C=C+1 A m+1
?A<=C A
GOYES +
A=C A min
+ D0=(2) J
DAT0=A A
REDUCT2 GOSUB Reduct
SETHEX
D0=(2) J
A=DAT0 A
A=A-1 A
DAT0=A A
?A#0 A
GOYES REDUCT2
D0=(2) I
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A<=C A
GOYES REDUCT1
* Norm bound:
* Compute M=1/max.j(abs(H.j))
* where H.j denotes the j-th row
* of H. Then there can exist no
* relation vector whose Euclidean
* norm is less than M.
* No need for M?
* Termination test:
* If the largest entry of A
* exceeds the level of numeric
* precision used, then precision
* is exhausted. If the smallest
* entry of the y vector is less
* than the detection threshold,
* a relation has been detected
* and is given in the
* corresponding column of B.
* Own note:
* Exhaust A and take
* last column of B
GOSUB TESTA
GOC DONE
D1=(5) =aATTNFLG
A=DAT1 A
D1=A
A=DAT1 A
?A#0 A
GOYES FAIL
GOTO MAIN
FAIL GOVLNG =GPPushFLoop
*********************************
* Copy last column of B to s
DONE D0=(2) N
A=DAT0 A
R4=A N
- R3=A y
C=R4 A
P= MB
GOSUB GETEL
GOSUB stab0
C=R3 A
P= Ms
GOSUB STOEL
A=R3 A
A=A-1 A
?A#0 A
GOYES -
GOVLNG =GPPushTLoop
*********************************
TESTA P= MA
GOSUB STACKP
D1=C
D1=D1+ 5
A=DAT1 A
A=A+C A
B=A A
D1=D1+ 25
- A=DAT1 A
SETDEC
A=A+A A
SETHEX
GOC +
A=DAT1 A
LC(5) #00010 1E10
?A>C A
RTNYES
+ D1=D1+ 21
AD1EX
D1=A
?A<B A
GOYES -
RTNCC
*********************************
putab0 GOVLNG =PUTAB0
getab0 GOVLNG =GETAB0
getcd0 GOVLNG =GETCD0
getcd1 GOVLNG =GETCD1
addr SETDEC
GOSUB rccd0
GOSUB addf
stab0 GOVLNG =STAB0
stab2 GOVLNG =STAB2
stcd2 GOVLNG =STCD2
rcab0 GOVLNG =RCAB0
rcab2 GOVLNG =RCAB2
rccd0 GOVLNG =RCCD0
rccd2 GOVLNG =RCCD2
sqrt SETDEC
GOVLNG =SQRF
sqf SETDEC
C=B W
D=C W
C=A W
multf SETDEC
GOVLNG =MULTF
divf SETDEC
GOVLNG =DIVF
subf SETDEC
C=-C-1 S
addf SETDEC
CD0EX
RSTK=C
CD0EX
GOSBVL =ADDF
C=RSTK
D0=C
RTN
tst> SETDEC
P= 4
GOVLNG =TST15
nint SETDEC
ST=0 1
ST=1 2
C=0 A
C=C+1 A
HS=0 3
GOSBVL =CCSB1
GOVLNG =RNDC[B]
*********************************
* SQRT(4/3)=1.15470053837924
*********************************
Gamma P= 0
LC(N) 16
NIBHEX 4297383500745110
D=C W
C=0 W
RTN
*********************************
* In: P stack pos
* A[A] I
* C[A] J
* R0:R1 M[J] / M[I,J]
* Out:
* Alt: A[W] B[W] C[A] D1 P
*********************************
STOEL GOSUB ELPOS
GOSBVL =RCAB0
putab1 GOVLNG =PUTAB1
*********************************
* In: P stack pos
* A[A] I
* C[A] J
* Out: A:B M[J] / M[I,J]
* Alt: A[W] B[W] C[A] D1 P
*********************************
GETEL GOSUB ELPOS
getab1 GOVLNG =GETAB1
*********************************
* In: P stack pos
* A[A] I
* C[A] J
* Out: D1 ->M[J] / ->M[I,J]
* A[A] X
* C[A] Y (1 if 1DIM)
* Alt: A[A] B[A] C[A] D1 P
*********************************
ELPOS B=C A
GOSUB STACKP
D1=C
D1=D1+ 15
C=DAT1 A dims
D1=D1+ 10
C=C-1 A
C=C-1 A
GONC +
D1=D1- 10
C=DAT1 A Y=1
D1=D1+ 5
A=DAT1 A X
D1=D1+ 5
GONC elposn
+ C=DAT1 A
A=A-1 A
- SB=0
ASRB.F A
?SB=0
GOYES +
B=B+C A
+ C=C+C A
?A#0 A
GOYES -
A=DAT1 A X
D1=D1- 5
C=DAT1 A Y
D1=D1+ 10
elposn B=B-1 A
CD1EX
C=C+B A
B=B+B A
B=B+B A
C=C+B A
B=B+B A
B=B+B A
C=C+B A
CD1EX
RTN
STACKP SETHEX
GOSBVL =D1=DSKTOP
C+P+1
C+P+1
C+P+1
C+P+1
C+P+1
P= 0
D1=C
D1=D1- 10
C=DAT1 A ->M
RTN
*********************************
ROWSWAP C=P 15
R0=C A Y2
C=0 A
C=C+1 A
GOSUB ELPOS ->M[Y1,1]
CD1EX
CR0EX
A=C A
C=0 A
C=C+1 A
P=C 15
GOSUB ELPOS ->M[Y2,1]
C=A A
D=C A X
B=0 A
GOTO SWAPELS
*********************************
COLSWAP C=P 15
R0=C W X2
C=A A
A=0 A
A=A+1 A
GOSUB ELPOS ->M[1,X1]
CD1EX
CR0EX
A=0 A
A=A+1 A
P=C 15
GOSUB ELPOS ->M[1,X2]
A=A-1 A X-1
B=A A
A=A+A A
A=A+A A
B=B+A A 5(X-1)
A=A+A A
A=A+A A
B=B+A A 21(X-1)
D=C A Y
SWAPELS AD0EX
AR0EX
D0=A
- A=DAT0 W
C=DAT1 W
DAT0=C W
DAT1=A W
D0=D0+ 16
D1=D1+ 16
A=DAT0 A
C=DAT1 A
DAT0=C A
DAT1=A A
D0=D0+ 5
D1=D1+ 5
AD0EX
A=A+B A
AD1EX
A=A+B A
AD0EX
D=D-1 A
?D#0 A
GOYES -
A=R0 A
D0=A
RTN
*********************************
* Reduction step
*********************************
* t=nint(H.ij/H.jj)
* y.j=y.j+t*y.i
* For k=1 to j
* H.ik=H.ik-t*H.jk
* Next
* For k=1 to n
* A.ik=A.ik=t*A.jk
* B.kj=B.kj+t*B.ki
* Next
Reduct D0=(2) J
A=DAT0 A
C=A A
P= MH
GOSUB GETEL
GOSUB stab0
C=DAT0 A
D0=(2) I
A=DAT0 A
P= MH
GOSUB GETEL
GOSUB rccd0
GOSUB divf
GOSUB nint
GOSUB stab2 R2:R3=t
D0=(2) I
C=DAT0 A
P= My
GOSUB GETEL
GOSUB rccd2
GOSUB multf
GOSUB stab0
D0=(2) J
C=DAT0 A
P= My
GOSUB GETEL
GOSUB rccd0
GOSUB addf
D1=D1- 21
GOSUB putab1
D0=(2) K
A=0 A
A=A+1 A
DAT0=A A
- D0=(2) J
A=DAT0 A
D0=(2) K
C=DAT0 A
P= MH
GOSUB GETEL
GOSUB rccd2
GOSUB multf
GOSUB stab0
* D0=(2) K
C=DAT0 A
D0=(2) I
A=DAT0 A
P= MH
GOSUB GETEL
GOSUB rccd0
GOSUB subf
D1=D1- 21
GOSUB putab1
SETHEX
D0=(2) K
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) J
C=DAT0 A
?A<=C A
GOYES -
D0=(2) K
A=0 A
A=A+1 A
DAT0=A A
- D0=(2) J
A=DAT0 A
D0=(2) K
C=DAT0 A
P= MA
GOSUB GETEL
GOSUB rccd2
GOSUB multf
GOSUB stab0
* D0=(2) K
C=DAT0 A
D0=(2) I
A=DAT0 A
P= MA
GOSUB GETEL
GOSUB rccd0
GOSUB subf
D1=D1- 21
GOSUB putab1
* D0=(2) I
C=DAT0 A
D0=(2) K
A=DAT0 A
P= MB
GOSUB GETEL
GOSUB rccd2
GOSUB multf
GOSUB stab0
* D0=(2) K
A=DAT0 A
D0=(2) J
C=DAT0 A
P= MB
GOSUB GETEL
GOSUB rccd0
GOSUB addf
D1=D1- 21
GOSUB putab1
SETHEX
D0=(2) K
A=DAT0 A
A=A+1 A
DAT0=A A
D0=(2) N
C=DAT0 A
?A>C A
RTNYES
GOTO -
ENDCODE
NOTcase :: 6DROP %0 ;
DROP 5UNROLL 4DROP
;
*********************************
NULLNAME LIST>VEC
::
INNERCOMP ONE{}N >ARRY
;
*********************************
NULLNAME VEC>STK
::
DUP ARSIZE #1+_ONE_DO
INDEX@ OVER GETATELN DROP
DUPTYPEREAL? ?SKIP %%>%
SWAP
LOOP
DROP
;
*********************************
NULLNAME >ARRY
::
DUPTYPEBINT? ITE
:: ONE{}N DUP CARCOMP ;
:: DUPINCOMP #1=?SKIP #*OVF ;
3PICK TYPEREAL? ITE %0 %%0
ROTSWAP MAKEARRY
CODE
A=DAT1 A
D1=D1+ 5
D=D+1 A
R0=A
GOSBVL =POP#
R4=A
GOSBVL =SAVPTR
A=R0
D0=A
GOSBVL =SKIPOB
-- A=R4 A
A=A-1 A
R4=A A
GOC ++
AD0EX
R1=A A
GOSBVL =GETPTR
GOSBVL =PopASavptr
D1=A
A=R1 A
D0=A
A=DAT1 A
D1=D1+ 5
LC(5) =DOREAL
?A#C A
GOYES +
A=DAT1 W
D0=D0- 16
DAT0=A W
GONC --
+ C=DAT1 A
D1=D1+ 5
A=DAT1 W
D0=D0- 16
DAT0=A W
D0=D0- 5
DAT0=C A
GONC --
++ GOVLNG =GPPushR0Lp
ENDCODE
;
*********************************
NULLNAME M>%%
::
DUP DIMLIMITS %%0 MAKEARRY
CODE
GOSBVL =PopASavptr
C=DAT1 A
DAT1=A A
D0=C
D1=A
D0=D0+ 15
D1=D1+ 5
C=DAT1 A
C=C+A A
D=C A
D1=D1+ 10
A=DAT0 A dims
A=A+1 A
C=A A
C=C+C A
C=C+C A
A=A+C A 5*dims+5
CD0EX
C=C+A A
CD1EX
C=C+A A
- D0=C
A=DAT1 W
D1=D1+ 16
GOSBVL =SPLITA
SETHEX
GOSBVL =PUTAB0
CD0EX
?C<D A
GOYES -
GOVLNG =GETPTRLOOP
ENDCODE
;
*********************************
NULLNAME MAT>%
::
DUP ARSIZE #1+_ONE_DO
INDEX@ OVER GETATELN DROP
%%>% SWAP
LOOP
DIMLIMITS >ARRY
;
*********************************
NULLNAME >RAT
::
OVER %0= caseDROP
2DUP
CODE
GOSBVL =POP2%SPLTAC
A=0 S
ST=0 10
?C=0 S
GOYES +
ST=1 10
+ C=0 S
GOSBVL =STCD2
- GOSBVL =RCCD2
GOSBVL =aMODF
GOSBVL =EXAB2
?B#0 W
GOYES -
GOSBVL =RCAB2
?ST=0 10
GOYES +
A=-A-1 S
+ GOVLNG =NoXcpEND%
ENDCODE
ROTOVER %/ UNROT %/
%1=case DROP
' x/ THREE
4PICK %0< NOTcase SYMBN
4ROLL %ABS 4UNROLL
onlyputopCHS SYMBN
;
*********************************
NULLNAME ROOT
::
%1=case DUP
DUP % 1048575 %>
case :: %1 SWAP ;
COERCE
CODE
GOSBVL =POP#
R1=A
GOSBVL =SAVPTR
C=0 A
C=C+1 A
R0=C
LC(1) 4
R2=C
C=C+1 A
R3=C A
-- A=R1
C=R2
GOSBVL =IntDiv
?C=0 A
GOYES sqrdone
?A=0 A
GOYES +
A=R2 A
C=R3 A
A=A+C A
R2=A A
C=C+1 A
C=C+1 A
R3=C A
GONC --
+ R1=C
A=R0
C=R3
CSRB.F A
GOSBVL =MUL#
A=B A
R0=A
GOTO --
sqrdone GOVLNG =Push2#Loop
ENDCODE
UNCOERCE2
;
*********************************
NULLNAME NORM
::
%0 OVER ARSIZE #1+_ONE_DO
INDEX@ 3PICK GETATELN DROP
DUPTYPEREAL? ?SKIP %%>%
DUP %* %+
LOOP
%SQRT
;
*********************************
