'===========================================================================
' Subject: EXTENDED PRECISION CALCULATOR     Date: 05-23-98 (13:24)       
' Author:  Judson D. McClendon               Code: QB, QBasic, PDS        
' Origin:  comp.lang.basic.misc            Packet: ALGOR.ABC
'===========================================================================
'From: "Judson McClendon" <judmc123@bellsouth.net>

'Here is an early QuickBasic/QBasic prototype for a high precision
'calculator program which I wrote about 10 years ago.  This prototype
'only uses double precision.  The real BIGCALC is about 10,000 lines
'of C, and does transcendental functions on numbers up to 1075 digits.

'If anybody is interested in the C version of BIGCALC, e-mail me and I
'will send it to you, along with the highly commented source code.


'  **************************************************
'  *                                                *
'  *                 BIGCALC.BAS                    *
'  *                                                *
'  *          Extended Precision Calculator         *
'  *                                                *
'  *              Judson D. McClendon               *
'  *              Sun Valley Systems                *
'  *              329 37th Court N.E.               *
'  *              Birmingham, AL 35215              *
'  *                 205-853-8440                   *
'  *                                                *
'  **************************************************
'
DEFINT A-Z
'
'  Declare Functions/Subroutines
'
DECLARE SUB AcceptX ()
DECLARE SUB Add ()
DECLARE SUB ClearStack (S%)
DECLARE SUB ClearX ()
DECLARE SUB Divide ()
DECLARE SUB DropStack ()
DECLARE SUB Exchange ()
DECLARE SUB ExtendedAdd ()
DECLARE SUB ExtendedDivide ()
DECLARE SUB ExtendedMultiply ()
DECLARE SUB ExtendedSubtract ()
DECLARE FUNCTION GetChar ()
DECLARE SUB HelpScreen ()
DECLARE SUB Initialize ()
DECLARE SUB MoveRegStack (Source%, Dest%)
DECLARE SUB MoveStackReg (Source%, Dest%)
DECLARE SUB MoveStackStack (Source%, Dest%)
DECLARE SUB MoveStackWork (Source%, Dest%)
DECLARE SUB MoveWorkStack (Source%, Dest%)
DECLARE SUB Multiply ()
DECLARE SUB PrintReg (R%)
DECLARE SUB PrintScreen ()
DECLARE SUB PrintStack (Lo%, Hi%)
DECLARE SUB Push ()
DECLARE SUB PushStack ()
DECLARE SUB RecallX ()
DECLARE SUB RollDown ()
DECLARE SUB RollUp ()
DECLARE SUB StoreX ()
DECLARE SUB Subtract ()

'
'  ***  Constants  ***
'
CONST FALSE = 0, TRUE = -1
CONST Precision = 6     ' Maximum Number of Digits
CONST Plus = 43         ' +
CONST Minus = 45        ' -
CONST Asterisk = 42     ' *
CONST Virgule = 47      ' /
CONST Escape = 27       ' Escape
CONST Enter = 13        ' Enter
CONST Ins = 1082        ' Ins
CONST F1 = 1059         ' F1
CONST LeftArrow = 1075  ' Left Arrow
CONST RightArrow = 1077 ' Right Arrow
CONST DownArrow = 1080  ' Down Arrow
CONST UpArrow = 1072    ' Up Arrow
CONST Del = 1083        ' Del
CONST PageUp = 1073     ' PgUp
CONST PageDown = 1081   ' PgDn

'
'  ***  Shared Areas  ***
'
DIM SHARED Stak(1 TO 4) AS DOUBLE, Reg(0 TO 9) AS DOUBLE, Work(1 TO 3) AS DOUBLE
DIM SHARED StackLift AS INTEGER

'
'  ***  Begin  ***
'
CALL Initialize

LOCATE 23, 13
Char = GetChar
DO UNTIL (Char = Escape)
   SELECT CASE (Char)
      CASE Enter
         CALL Push
      CASE Plus
         CALL Add
      CASE Minus
         CALL Subtract
      CASE Asterisk
         CALL Multiply
      CASE Virgule
         CALL Divide
      CASE LeftArrow, RightArrow
         CALL Exchange
      CASE DownArrow
         CALL RollDown
      CASE UpArrow
         CALL RollUp
      CASE Del
         CALL ClearX
      CASE PageUp
         CALL StoreX
      CASE PageDown
         CALL RecallX
      CASE Ins
         CALL AcceptX
      CASE F1
         CALL HelpScreen
      CASE ELSE
         BEEP
   END SELECT
   LOCATE 23, 13
   Char = GetChar
LOOP
LOCATE 23, 1
END

'
' ***  Accept X  ***
'
SUB AcceptX
   IF StackLift THEN
      CALL PushStack
   END IF
   LOCATE 22, 1: INPUT "Value: ", Stak(1)
   IF StackLift THEN
      CALL PrintStack(1, 4)
   ELSE
      CALL PrintStack(1, 1)
   END IF
   LOCATE 22, 1: PRINT SPACE$(30);
   StackLift = TRUE
END SUB

'
' ***  Add  ***
'
SUB Add
   CALL MoveStackWork(1, 1)
   CALL MoveStackWork(2, 2)
   CALL ExtendedAdd
   CALL DropStack
   CALL MoveWorkStack(3, 1)
   CALL PrintStack(1, 3)
   StackLift = TRUE
END SUB

'
' ***  Clear Stak  ***
'
SUB ClearStack (S)
   Stak(S) = 0
END SUB

'
' ***  Clear X  ***
'
SUB ClearX
   CALL ClearStack(1)
   CALL PrintStack(1, 1)
   StackLift = FALSE
END SUB

'
' ***  Divide  ***
'
SUB Divide
   CALL MoveStackWork(1, 1)
   CALL MoveStackWork(2, 2)
   CALL ExtendedDivide
   CALL DropStack
   CALL MoveWorkStack(3, 1)
   CALL PrintStack(1, 3)
   StackLift = TRUE
END SUB

'
' ***  Drop Stak  ***
'
SUB DropStack
   FOR S = 1 TO 3
      CALL MoveStackStack(S + 1, S)
   NEXT
END SUB

'
' ***  Exchange  ***
'
SUB Exchange
   CALL MoveStackWork(1, 1)
   CALL MoveStackStack(2, 1)
   CALL MoveWorkStack(1, 2)
   CALL PrintStack(1, 2)
   StackLift = TRUE
END SUB

'
' ***  Extended Add  ***
'
SUB ExtendedAdd
   Work(3) = Work(2) + Work(1)
END SUB

'
' ***  Extended Divide  ***
'
SUB ExtendedDivide
   Work(3) = Work(2) / Work(1)
END SUB

'
' ***  Extended Multiply  ***
'
SUB ExtendedMultiply
   Work(3) = Work(2) * Work(1)
END SUB

'
' ***  Extended Subtract  ***
'
SUB ExtendedSubtract
   Work(3) = Work(2) - Work(1)
END SUB

'
' ***  Get Character  ***
'
FUNCTION GetChar
   DO
      Char$ = INKEY$
   LOOP WHILE (Char$ = "")
   IF LEN(Char$) > 1 THEN
      GetChar = 1000 + ASC(RIGHT$(Char$, 1))
   ELSE
      GetChar = ASC(Char$)
   END IF
END FUNCTION

'
' ***  HelpScreen  ***
'
SUB HelpScreen
   CLS
   PRINT TAB(24); "Extended Precision Calculator       Judson D. McClendon"
   PRINT "                                                           Sun Valley Systems"
   PRINT "This program uses RPN logic much like Hewlett-Packard      329 37th Court N.E."
   PRINT "calculators. It supports a four level stack and 10         Birmingham, AL 35215"
   PRINT "registers.  The table below lists the valid commands.         205-853-8440    "
   PRINT : PRINT
   PRINT "      F1  Help (this screen)                 C  Clear Stack, Regs, Both"
   PRINT "       +  Add X to Y                         P  Print X, Stack, Regs, All"
   PRINT "       -  Subtract X from Y             PgUp #  Store X in Register"
   PRINT "       *  Multiply X times Y            PgDn #  Recall Register to X    "
   PRINT "       /  Divide Y by X             Left Arrow  Swap X Y"
   PRINT "     Ins  Accept new X value       Right Arrow  Swap X Y"
   PRINT "     Del  Clear X                   Down Arrow  Roll Down Registers"
   PRINT "   Enter  Push up stack               Up Arrow  Roll Up Registers "
   PRINT : PRINT
   PRINT "      Note: Clear, Print, Store & Recall prompt for action,"
   PRINT "            Accept (Ins) prompts for new X value."
   LOCATE 25, 25: PRINT "(Press any key to continue)";
   WHILE INKEY$ = "": WEND
   CALL PrintScreen
END SUB

SUB Initialize
   StackLift = TRUE
   CALL HelpScreen
END SUB

'
' ***  Move Reg to Stak  ***
'
SUB MoveRegStack (Source, Dest)
   Stak(Dest) = Reg(Source)
END SUB

'
' ***  Move Stak to Reg  ***
'
SUB MoveStackReg (Source, Dest)
   Reg(Dest) = Stak(Source)
END SUB

'
' ***  Move Stak to Stak  ***
'
SUB MoveStackStack (Source, Dest)
   Stak(Dest) = Stak(Source)
END SUB

'
' ***  Move Stak to Work  ***
'
SUB MoveStackWork (Source, Dest)
   Work(Dest) = Stak(Source)
END SUB

'
' ***  Move Work to Stak  ***
'
SUB MoveWorkStack (Source, Dest)
   Stak(Dest) = Work(Source)
END SUB

'
' ***  Multiply  ***
'
SUB Multiply
   CALL MoveStackWork(1, 1)
   CALL MoveStackWork(2, 2)
   CALL ExtendedMultiply
   CALL DropStack
   CALL MoveWorkStack(3, 1)
   CALL PrintStack(1, 3)
   StackLift = TRUE
END SUB

'
' ***  PRINT REGISTER  ***
'
SUB PrintReg (R)
   LOCATE R + 4, 6
   PRINT SPACE$(70);
   LOCATE R + 4, 6
   PRINT Reg(R);
END SUB

'
'  ***  Print Screen  ***
'
SUB PrintScreen
   CLS
   PRINT TAB(24); "Extended Precision Calculator"
   LOCATE 3, 3
   PRINT " ==========================  R E G I S T E R S  =========================="
   FOR R = 0 TO 9
      LOCATE 4 + R, 3
      PRINT USING "#: "; R
      CALL PrintReg(R)
   NEXT
   LOCATE 15, 3
   PRINT "==============================  S T A C K  =============================="
   PRINT "  T:"
   PRINT "  Z:"
   PRINT "  Y:"
   PRINT "  X:"
   CALL PrintStack(1, 4)
   LOCATE 25, 24: PRINT "(Press F1 for help, End to Exit)";
END SUB

'
' ***  Print Stak  ***
'
SUB PrintStack (Lo, Hi)
   FOR S = Hi TO Lo STEP -1
      LOCATE 20 - S, 6
      PRINT SPACE$(70);
      LOCATE 20 - S, 6
      PRINT Stak(S);
   NEXT
END SUB

'
' ***  Push  ***
'
SUB Push
   CALL PushStack
   CALL PrintStack(2, 4)
   StackLift = FALSE
END SUB

'
' ***  Push Stak  ***
'
SUB PushStack
   FOR S = 4 TO 2 STEP -1
      CALL MoveStackStack(S - 1, S)
   NEXT
END SUB

'
' ***  Recall X  ***
'
SUB RecallX
   LOCATE 22, 1: PRINT "Register (0-9): "
   Char = GetChar
   IF Char$ >= "0" AND Char$ <= "9" THEN
      IF StackLift THEN
         CALL PushStack
      END IF
      R = VAL(Char$)
      CALL MoveRegStack(R, 1)
      IF StackLift THEN
         CALL PrintStack(1, 4)
      ELSE
         CALL PrintStack(1, 1)
      END IF
   ELSE
      BEEP
   END IF
   LOCATE 22, 1: PRINT SPACE$(30);
   StackLift = TRUE
END SUB

'
' ***  Roll Down  ***
'
SUB RollDown
   CALL MoveStackWork(1, 1)
   CALL DropStack
   CALL MoveWorkStack(1, 4)
   CALL PrintStack(1, 4)
   StackLift = TRUE
END SUB

'
' ***  Roll Up  ***
'
SUB RollUp
   CALL MoveStackWork(4, 1)
   CALL PushStack
   CALL MoveWorkStack(1, 1)
   CALL PrintStack(1, 4)
   StackLift = TRUE
END SUB

'
' ***  Store X  ***
'
SUB StoreX
   LOCATE 22, 1: PRINT "Register (0-9): "
   Char = GetChar
   IF Char$ >= "0" AND Char$ <= "9" THEN
      R = VAL(Char$)
      CALL MoveStackReg(1, R)
      CALL PrintReg(R)
   ELSE
      BEEP
   END IF
   LOCATE 22, 1: PRINT SPACE$(30);
   StackLift = TRUE
END SUB

'
' ***  Subtract  ***
'
SUB Subtract
   CALL MoveStackWork(1, 1)
   CALL MoveStackWork(2, 2)
   CALL ExtendedSubtract
   CALL DropStack
   CALL MoveWorkStack(3, 1)
   CALL PrintStack(1, 3)
   StackLift = TRUE
END SUB