HPHP48-P,*šĆASSEMBLE
=aFIXHOOK	EQU #16735
=xNEG		EQU #1A995
=xi		EQU #1AB45
=x+		EQU #1AB67
=x*		EQU #1ADEE
=xSQRT		EQU #1B374
=TestSysClr	EQU #1C4EC
=XEQARRAY>	EQU #1D0AB
=XEQC%V>	EQU #1DD29
=aFLOOR		EQU #2B767
=SPLITC		EQU #2BCAC
=putop:		EQU #5E51C
=putop2:	EQU #5E530
=verysyminner	EQU #5F2A3
=veryunsymin	EQU #5F2EE
RPL

xROMID 905
xTITLE QPI  v4.2'Fin
xCONFIG CfgPi

LABEL CfgPi
:: 905 TOSRRP ;

*********************************
ASSEMBLE
	CON(1)	8
RPL
xNAME QPI
::
 CK1&Dispatch
 ONE	Qpi%
 TWO	Qpi
 EIGHT	NOP
 TEN
 ::
  verysyminner
  DUP ZERO_DO
    DUP #1+ROLL Qpi
    syminner top& #1-
  LOOP
  veryunsymin
 ;
 FOUR
 ::
   XEQARRAY> INNERCOMP
   #1= IT :: %1 SWAP ;
   COERCE2
   {{ Y X }}
   Y #1+_ONE_DO
     X #1+_ONE_DO
       Qpi X UNROLL
     LOOP
     X {}N
     X Y INDEX@#- #*
     INDEX@ #+UNROLL
  LOOP
  Y DUP ONE#> ITE {}N DROP
  ABND
 ;
 FIVE
 ::
  RESOROMP xQPI
  ZEROZERO 4ROLLSWAP
  BEGIN
    NEXTCOMPOB
  WHILE
  ::
   5PICK EvalNoCK 5UNROLL
   ROT#1+UNROT
  ;
  REPEAT
  DROPSWAPDROP {}N
 ;
;
*********************************
NULLNAME Qpi
::
  DTYPEREAL? case Qpi%
  DUPTYPECMP? NOT?SEMI
  THREE TestSysClr SWAP
  XEQC%V>
  Qpi% SWAP Qpi% SWAP
  xi x* x+
  SWAP NOT?SEMI
  CLRSYMB
;

*--------------------------------
NULLNAME Qpi%
::
  %0=case NOP

  DUP Approx
  DUP %100 %< case
  :: ROTDROP Qout/ ;
  ZERO

  4PICK DUPDUP %* DUP % 500000 %>
  :: case2DROP Approx
     ROT %SGN ROT %* SWAP
     ONE COLA Qpimin
  ;

  4PICK %PI %/ DUP %ABS %100 %>
  :: caseDROP
     Approx TWO COLA Qpimin
  ;

  4PICK %EXP DUP % 1000 %>
  :: caseDROP Approx
     2DUP %* %1 %= case2DROP
     THREE COLA Qpimin1
  ;

  4PICK DUP %0<
  ::
    caseDROP %LN Approx
    FOUR COLA Qpimin1
  ;
  4ROLLDROP Qout  
;
*--------------------------------
NULLNAME Qpimin1
::
  OVER % 50 %< NOTcase 3DROP
  COLA Qpimin
;
*--------------------------------
NULLNAME Qpimin
::
  OVER % 1000 %< NOTcase 3DROP
  5PICK 3PICK %<= case 3DROP
  4ROLLDROP 4ROLLDROP 4ROLLDROP
  OVER %9 %> ?SEMI
  4ROLLDROP RDROP Qout 
;

*--------------------------------
NULLNAME Qout
::
  DUP#0=csedrp Qout/
  ONE   #=casedrop Qoutsqrt
  TWO   #=casedrop Qoutpi
  THREE #=casedrop Qoutln
  DROP Qoutexp
;

NULLNAME Qout/
::
  %1=case DROP
  ' x/ THREE SYMBN
;

NULLNAME Qoutpi
::
  Qout/ %1=case
   :: DROP SYMBOL xPI ; ;
  DUPEQ: %-1 casedrop
   SYMBOL xPI xNEG ;
  syminner
  putop2: xPI x* SYMBN
;

NULLNAME Qoutexp
::
  Qout/ syminner
  putop: xEXP SYMBN 
;

NULLNAME Qoutln
::
  Qout/ syminner
  putop: xLN SYMBN 
;

NULLNAME Qoutsqrt
::
  SWAPDUP %0< UNROT %ABS SWAP
  GetRoot ROT GetRoot
  ROT Qout/
  syminner putop: xSQRT SYMBN
  UNROTSWAP Qout/
  DUPEQ: %1 ITE
   :: DROP syminner ;
   :: syminner get1 syminner
      top& onlyputop*
   ;
  get1 IT onlyputopCHS
  SYMBN
;

*--------------------------------
NULLNAME GetRoot
::
  %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 Approx
CODE
	ABASE	#80100
nu	ALLOC	16
inu	ALLOC	16
de	ALLOC	16
ide	ALLOC	16
p0	ALLOC	16
q1	ALLOC	16
p1	ALLOC	16
q0	ALLOC	16
p2	ALLOC	16
q2	ALLOC	16
r	ALLOC	16
c	ALLOC	16

	GOSBVL	=POP1%
	C=A	S	C[S]=sign
	A=0	S
	?A#0	W
	GOYES	+
	GOSBVL	=GETPTR
	SETHEX
	D1=D1-	5
	D=D-1	A
	LC(5)	=%1
	A=C	A
	PC=(A)
+	D1=(5)	=aFIXHOOK
	C=DAT1	A
	D1=C
	C=0	A
	C=DAT1	1
	?C#0	A
	GOYES	+
	LCHEX	9
+	?CBIT=0	3
	GOYES	+
	?CBIT=0	1
	GOYES	+
	SETHEX
	C=C+CON	B,6
+	SETDEC
	R4=C	W
	D1=(5)	(=IRAM@)-4
	C=DAT1	A
	D1=C
	D1=(4)	#100
	C=0	W
	C=C+1	S
	CSR	W
	LCHEX	12
	P=	3-1
-	C=C-1	X
	P=P+1
	?A=0	P
	GOYES	-
	ACEX	X
	C=C-A	X
	C=-C	X

	DAT1=A	W	nu
	D1=D1+	16	inu=nu
	DAT1=A	W
	D1=D1+	16	de
	DAT1=C	W
	D1=D1+	16	ide=de
	DAT1=C	W
	A=0	W
	D1=D1+	16	p0=0
	DAT1=A	W
	D1=D1+	16	q1=0
	DAT1=A	W
	A=A+1	S
	ASR	W
	D1=D1+	16	p1=1
	DAT1=A	W
	D1=D1+	16	q0=1
	DAT1=A	W	

MAIN

* c = nu div de

	D1=(2)	nu
	GOSUB	GETA
	D1=(2)	de
	GOSUB	GETC
	GOSBVL	=DIVF
	GOSBVL	=aFLOOR
	D1=(2)	c
	GOSUB	PUTA

* r = nu mod de

	D1=(2)	nu
	GOSUB	GETA
	D1=(2)	de
	GOSUB	GETC
	GOSBVL	=aMODF	R0,R1!
	D1=(2)	r
	GOSUB	PUTA
		
* p2 = c*p1+p0

	D1=(2)	c
	GOSUB	GETA
	D1=(2)	p1
	GOSUB	MULC
	D1=(2)	p0
	GOSUB	ADDC
	D1=(2)	p2
	GOSUB	PUTA

* q2 = c*q1+q0

	D1=(2)	c
	GOSUB	GETA
	D1=(2)	q1
	GOSUB	MULC
	D1=(2)	q0
	GOSUB	ADDC
	D1=(2)	q2
	GOSUB	PUTA

* If r=0 then return(p2/q2)

	D1=(2)	r
	GOSUB	GETA
	?B=0	W
	GOYES	EXIT

* If 10^(digits-1)*abs(inu*q2-ide*p2)
*    < ide*p2
* Then return (p2/q2)

	D1=(2)	ide
	GOSUB	GETA
	D1=(2)	p2
	GOSUB	MULC
	GOSBVL	=STAB0
	D1=(2)	inu
	GOSUB	GETA
	D1=(2)	q2
	GOSUB	MULC
	GOSBVL	=RCCD0
	C=-C-1	S
	GOSUB	addf
	A=0	S
	C=R4.F	A	*10^(digits-1)
	A=A+C	A
	GOSBVL	=RCCD0
	P=	1
	GOSBVL	=TST15		
	GONC	CONT

* return(p2/q2)

EXIT	D1=(2)	q2
	A=DAT1	W
	AR4EX	W	A[S]=sign
	D1=(2)	p2
	A=DAT1	15
	R3=A	W
* No PUSH2% in ROM
	GOSUB	+
	A=R3	W
	GOSBVL	=PUSH%
	GOSBVL	=SAVPTR
	A=R4	W
	GOVLNG	=PUSH%LOOP
+	A=PC
	C=RSTK
	D0=C
	SETHEX
	C=A-C	A
	CD1EX
	RSTK=C
	CD1EX
	GOVLNG	=MOVEDOWN	

* p0=p1 p1=p2 q0=q1 q1=q2

CONT	D1=(2)	p2
	A=DAT1	W
	D1=(2)	p1
	C=DAT1	W
	DAT1=A	W
	D1=(2)	p0
	DAT1=C	W

	D1=(2)	q2
	A=DAT1	W
	D1=(2)	q1
	C=DAT1	W
	DAT1=A	W
	D1=(2)	q0
	DAT1=C	W

* nu=de de=r
	D1=(2)	r
	A=DAT1	W
	D1=(2)	de
	C=DAT1	W
	DAT1=A	W
	D1=(2)	nu
	DAT1=C	W
	GOTO	MAIN


MULC	GOSUB	GETC
	GOVLNG	=MULTF
ADDC	GOSUB	GETC
addf	GOVLNG	=ADDF
GETA	A=DAT1	W
	GOVLNG	=SPLITA
GETC	C=DAT1	W
	GOVLNG	=SPLITC
PUTA	GOSBVL	=PACK
	DAT1=A	W
	RTN
ENDCODE
*--------------------------------
