; extensions for float.ipl
; last mod 1/15/06(B)
"Loading float extensions..." $PRINT CRLF
"DFLT DFIX PWR10 $>FP FP>$ FSGN FSQR" $PRINT CRLF
;
; DFLT - convert double signed int to float
; Req. float words plus D2CPL
;
OCTAL DEFINE DFLT
OVER IF<0 D2CPL #0 S>Y ELSE #1 S>Y ENDIF ;2cpl if neg
DUP 377 AND FLT S>Z S>Z ;convert bits 0,7, save to Z
177400 AND ASR FLT 40000 4 FP* ;convert bits 8-15
;to avoid sign shift right, mul by 2 (40000 4 in fp)
Z>S Z>S FP+ S>Z S>Z ;add result to Z
FLT 40000 42 FP* Z>S Z>S FP+ ;conv 16-30, add to Z
;40000 42 is 65536 in FP
Y>S IFZ 100000 #0 FP* ENDIF ;make neg if int was neg
END
;
; DFIX - convert float to double signed int
; 077777 indicates overflow (pos or neg)
; Req. float words plus DSWAP D2CPL
;
OCTAL DEFINE DFIX
OVER OVER FIX IF<0 ;if number is negative
 100000 #0 FP* ;make fp number positive
 #0 S>Y ;zero flag on Y to indicate negative
ELSE #1 S>Y ENDIF ;else push one flag on Y
OVER OVER S>Z S>Z ;save fp number to Z
40000 42 FP/ FIX ;divide by 65536 for high word
DUP FLT 40000 42 FP* ;mul by 65536 and
Z>S Z>S DSWAP FP-    ;sub from fp val on Z
OVER OVER S>Z S>Z ;save remainder to Z
40000 4 FP/ ;divide by 2 to avoid sign when fixing
FIX ;top 7 bits of low word in bottom 7 bits
DUP ASL SWAP ;dup as-is, adjust low word
FLT 40000 4 FP* ;mult by 2
Z>S Z>S DSWAP FP- ;subtract from fp val
FIX OR ;fix bit 0 and combine with low word
OVER 77777 SUB IFZ ;if overflow
 Y>S DROP ;don't sign convert, let it pass
ELSE
 Y>S IFZ D2CPL ENDIF ;make neg if neg
ENDIF
END
;
; fp n PWR10 - raises fp to n power of 10
; if n=0 no action taken, leaves fp as-is
; otherwise multiplies by 1.0E(+/-)n
; no error-checking, gigo if out of range
; Req. float words
;
OCTAL DEFINE PWR10
DUP CASE
= 0 DROP 
> 0 #1 SWAP +DO 50000 10 FP* +LOOP
< 0 2CPL #1 SWAP +DO 50000 10 FP/ +LOOP
ENDCASE
END
;
; "string" $>FP - parses string and pushes fp
; valid string is [+ or -]1.23456[E[+ or -]12]
; example.. .001 123.45 1.5E3 -2.7E-7 etc
; Requires float words, PWR10, $DVAL.
;
OCTAL DEFINE $>FP
#0 FLT ;start with fp value 0
#0 S>Y ;start with sign positive
#0 S>Z ;mode 0=before dp 1=after E <0=#positions past dp
DO
 Z>S DUP S>Z IFZ ;if before dp...
  $HEAD ;pop 1 char from string and push to stack
  CASE = 55 Y>S DROP #1 S>Y ;"-" set sign flag to neg
       = 60 50000 10 FP*              ;"0"
       = 61 50000 10 FP* 40000 2 FP+  ;"1"
       = 62 50000 10 FP* 40000 4 FP+  ;"2"
       = 63 50000 10 FP* 60000 4 FP+  ;"3"
       = 64 50000 10 FP* 40000 6 FP+  ;"4"
       = 65 50000 10 FP* 50000 6 FP+  ;"5"
       = 66 50000 10 FP* 60000 6 FP+  ;"6"
       = 67 50000 10 FP* 70000 6 FP+  ;"7"
       = 70 50000 10 FP* 40000 10 FP+ ;"8"
       = 71 50000 10 FP* 44000 10 FP+ ;"9"
       = 56  Z>S DROP -1 S>Z ;"." switch to after point
       = 105 Z>S DROP #1 S>Z ;"E" switch to after E
       ;default is do nothing
  ENDCASE
 ELSE
  Z>S DUP S>Z IF<0 ;if after point
   $HEAD ;pop 1 char from string and push to stack
   CASE = 60 Z>S DEC S>Z                        ;"0"
        = 61 40000 2 Z>S DUP DEC S>Z PWR10 FP+  ;"1"
        = 62 40000 4 Z>S DUP DEC S>Z PWR10 FP+  ;"2"
        = 63 60000 4 Z>S DUP DEC S>Z PWR10 FP+  ;"3"
        = 64 40000 6 Z>S DUP DEC S>Z PWR10 FP+  ;"4"
        = 65 50000 6 Z>S DUP DEC S>Z PWR10 FP+  ;"5"
        = 66 60000 6 Z>S DUP DEC S>Z PWR10 FP+  ;"6"
        = 67 70000 6 Z>S DUP DEC S>Z PWR10 FP+  ;"7"
        = 70 40000 10 Z>S DUP DEC S>Z PWR10 FP+ ;"8"
        = 71 44000 10 Z>S DUP DEC S>Z PWR10 FP+ ;"9"
        = 105 Z>S DROP #1 S>Z ;"E" switch to after E
        ;default is do nothing
   ENDCASE
  ELSE ;must be after E
   $DVAL SWAP DROP ;push value of exponent
   PWR10 ;raise accumulator by power of 10
   "" ;empty string to keep the gears going
  ENDIF
 ENDIF
 $LEN
WHILE ;keep looping until string is empty
$DROP
Y>S ;get sign
IFNZ -1 FLT FP* ENDIF ;make neg if neg
Z>S DROP ;drop mode
END
;
; fp FP>$ - pushes string with fp value
; if expressible with 6 digits then expressed normally
; as in .5 250 etc otherwise expressed E-style.
; Req. float words, PWR10, $DSTR, $SLICE
;
OCTAL DEFINE FP>$
66343 167005 S>Z S>Z ;place 1E-38 on Z stack
-46 S>Y ;exponent on Y stack
"" ;string to collect digits in
DO ;loop to collect digits
 #0 S>Y ;push sign flag
 OVER OVER Z>S Z>S OVER OVER S>Z S>Z
 FP* FIX ;convert digit to int
 DUP IF<0
  2CPL
  $LEN IFZ 55 $APPEND ENDIF
  Y>S INC S>Y ;make sign flag non-zero for neg
 ENDIF
 DUP IFZ ;if digit is zero
  $LEN IFNZ ;and string more than 0 chars
   60 $APPEND ;append the "0" (suppress leading)
  ENDIF
  DROP
 ELSE
  DUP 60 ADD $APPEND ;digit 1-9
  Y>S DUP S>Y IFNZ 2CPL ENDIF ;comp if negative
  FLT ;float the int digit
  Z>S Z>S OVER OVER S>Z S>Z ;get current mult
  FP/ FP- ;subtract digit amount from number
 ENDIF
 Y>S DROP ;sign flag (not accurate at end, no -0)
 Z>S Z>S #1 PWR10 S>Z S>Z ;next multiplier
 $LEN 7 SUB ;end flag non-zero until 7 chars
 Y>S DUP INC S>Y ;get exp counter, push incremented
 46 SUB IFZ DROP #0 ENDIF ;terminate at 1E37
WHILE ;loop until 6-7 significant characters collected
DROP DROP ;picked apart FP number
Z>S Z>S DROP DROP ;don't need multiplier anymore
;raw digits in string, incremented inverse exponent on Y
;if zero, string is empty and Y=47
Y>S DEC
$LEN IFZ
 $DROP DROP " 0" ;handle 0 case
ELSE
 ;the minus sign gets in the way! put the sign on z stack
 $DUP $HEAD $DROP 55 SUB IFZ ;if there's a "-"
  $HEAD DROP "-" X>>Z ;push "-" to z stack
 ELSE " " X>>Z ;otherwise push " " to z
 ENDIF
 $LEN 7 SUB IFZ ;if 7 chars got collected
  $TAIL DROP ;discard last char
  DEC ;adjust exp
 ENDIF
 ;now only 6 or less significant digits in string
 DO ;strip off trailing zeroes
  $TAIL DUP 60 SUB IFNZ $APPEND #1
  ELSE DROP DEC ;adjust exp
  DUP IFZ #1 ELSE #0 ENDIF ENDIF ;stop if whole
 UNTIL ;last non-zero digit encountered or whole number
 DUP IFZ ;if exponent is 0
  DROP ;exponent
  Z>>X $SWAP $CAT ;prepend - or space to raw digits
 ELSE ;must represent with dp or E, sign string on Z
  DUP 7 SUB IF<0 #1 ELSE #0 ENDIF ;push 1 if invexp <= 6 else 0
  OVER IF<0 DROP #0 ENDIF           ;if invexp <0 change to 0
  IFNZ ;if tos=1 then display using decimal point
   $LEN OVER SUB DUP IF<0 ;if pre-0's needed add them...
    2CPL ;difference to be # of zeroes needed
    60 $CREATE $SWAP $CAT ;prepend to string
   ELSE DROP ENDIF ;discard difference, already in range
   DUP $LEN SUB IFZ ;if nothing before dp
    "" X>>Z ;push empty string to Z
   ELSE ;push part before dp to Z
    $LEN DEC OVER SUB #0 SWAP $SLICE X>>Z
   ENDIF
   $LEN OVER SUB $LEN DEC $SLICE
   "." $SWAP $CAT X>>Y ;part after dp on Y
   Z>>X ;retreve pre-dp
   Z>>X $SWAP $CAT ;prepend space or -
   Y>>X $CAT $SWAP $DROP ;form output string
   DROP ;exponent
  ELSE ;display in scientific format
   $LEN DEC ;push string len - 1
   SWAP OVER SUB SWAP ;subtract from inv exponent
   DUP IFNZ ;if stuff after dp
    #1 SWAP $SLICE
    "." $SWAP $CAT X>>Y ;push dp and digits to Y
   ELSE DROP "" X>>Y ;no fraction
   ENDIF
   2CPL ;invert exponent to true exponent
   #0 #0 $SLICE ;push string w/ 1st digit
   Y>>X $CAT ;append rest of the digits if any
   Z>>X $SWAP $CAT ;prepend sign
   "E" $CAT  ;append E
   DUP IF<0 "-" 2CPL ELSE "+" ENDIF $CAT ;adjust
   #0 SWAP $DSTR $CAT ;append exponent in decimal
   $SWAP $DROP ;original digits
  ENDIF
 ENDIF
ENDIF
END
;
;
; FSGN - pops fp number and pushes 0 if fp = 0,
; pushes 1 if fp>0, or pushes -1 if fp<0
; Req. float words
;
OCTAL DEFINE FSGN
#0 S>Z ;flag on Z
OVER OVER ;dup fp #
IFZ       ;if 2nd word 0
 IFZ      ; if 1st word 0
  Z>S DROP #1 S>Z ;change Z to 1
 ENDIF
ELSE
 DROP     ;1st word if 2nd word not 0
ENDIF
Z>S IFNZ ;if zero detected
 DROP DROP ;fp number
 #0 ;push 0 and exit
ELSE
 FIX IF<0 ;if negative
  -1 ;push -1 and exit
 ELSE
  #1 ;push 1 and exit
 ENDIF
ENDIF
END
;
;
; FSQR - calculate square root
; Req. float words, FSGN
;
OCTAL DEFINE FSQR
;number to compute on stack, replace with square root
OVER OVER FSGN ;test number to compute
DUP IF<0
 DROP "ERROR " $PRINT
ELSE
 IFNZ ;if non-zero
  ;previous solution kept on Y, start with fp/10...
  OVER OVER 12 FLT FP/ S>Y S>Y
  ;bailout counter on Z...
  377 S>Z ;probably could be much lower
  DO ;until a solution is found using "Babylonian" method
   ;new guess Z = (Y + FP/Y)/2
   OVER OVER Y>S Y>S OVER OVER S>Y S>Y FP/
   Y>S Y>S OVER OVER S>Y S>Y FP+
   2 FLT FP/ S>Z S>Z
   ;check to see how close current guess is to last guess
   Y>S Y>S OVER OVER S>Y S>Y
   Z>S Z>S OVER OVER S>Z S>Z
   FP- FSGN ;determine difference
   IFZ ;if equal
    #1 ;terminate until loop
    Z>S Z>S DROP DROP ;remove Z
   ELSE
    ;copy Z to Y, replacing old Y
    Y>S Y>S DROP DROP Z>S Z>S S>Y S>Y
    Z>S DEC DUP S>Z ;dec bailout
    IFNZ ;if not stuck
     #0   ;keep looping
    ELSE
     #1   ;terminate if no convergence
    ENDIF
   ENDIF
  UNTIL
  DROP DROP ;remove original fp
  Y>S Y>S ;replace with square root
  Z>S DROP ;bailout counter
 ENDIF
ENDIF
END
;
;
CONSOLE