home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / chkbook.seq < prev    next >
Text File  |  1990-04-16  |  21KB  |  485 lines
  1. \ File Name    : CHKBOOK.SEQ
  2. \ Program Name : Check Book
  3. \ Author       : Jack W. Brown
  4.  
  5. \ Original Date: July  25, 1988 for PF Forth
  6. \ Last Modified: April 16, 1990 for F-PC 3.5
  7.  
  8. \ Function     : Balance your check book
  9.  
  10. \ Required     :
  11. \ Support Files: DMATH.SEQ   from provided with Lesson 5
  12. \              : JBINPUT.SEQ from JBINPUT.ZIP
  13.  
  14. \ Usage        : Fload file and type  MAIN, follow instructions
  15. \              : it won't break.
  16.  
  17. \ Overview     : A simple menu driven program that illustrates how
  18. \              : you can program dollars and cents using single
  19. \              : integers.  You must also have your ANSI.SYS driver
  20. \              : installed in your CONFIG.SYS file.
  21. \              : BIG BOX COMMENTS JUST LIKE " C " PROGRAMMERS USE!!
  22.  
  23. \ Revision History
  24. \ JWB 25-07-88 Original PF-Forth version created.
  25. \ JWB 07-03-89 Modified for F-PC 2.25 and Tutorial
  26. \ JWB 16-04-90 Modified for F-PC 3.5
  27. \ Re define comment to end of line so we can use "C" type comments.
  28. : /* [COMPILE] \ ; IMMEDIATE
  29.  
  30. /* ************************************************************ */
  31. /*                                                              */
  32. /* For F-PC 2.25  with ANSI.SYS installed in your CONFIG.SYS    */
  33. /*                                                              */
  34. /* Program: Checkbook - Implement simple checkbook program.     */
  35. /*                      FORTH version.                          */
  36. /* Date: July 25, 1988                                          */
  37. /*                                                              */
  38. /* ************************************************************ */
  39.  
  40. \ FLOAD DMULDIV.SEQ
  41. \ FLOAD DMATH.SEQ
  42. \ FLOAD JBINPUT.SEQ
  43.  
  44. VARIABLE BAL_DOLLARS            /* Checkbook balance dollar amount */
  45. VARIABLE BAL_CENTS              /* Checkbook balance cents amount  */
  46. VARIABLE TR_DOLLARS             /* Transaction dollar amount       */
  47. VARIABLE TR_CENTS               /* Transaction cents amount        */
  48. VARIABLE VALID                  /* Valid return code from scanf    */
  49. VARIABLE OLD_DOLLARS            /* Initial dollar balance          */
  50. VARIABLE OLD_CENTS              /* Initial cents balance           */
  51. VARIABLE CHK_DOLLARS            /* Total check dollars             */
  52. VARIABLE CHK_CENTS              /* Total check cents               */
  53. VARIABLE CHK_COUNT              /* Number of checks this session   */
  54. VARIABLE DEP_COUNT              /* Number of deposits this session */
  55. VARIABLE DEP_DOLLARS            /* Total deposit dollars           */
  56. VARIABLE DEP_CENTS              /* Total deposit cents             */
  57. VARIABLE TEST
  58.  
  59. /* ************************************************************ */
  60. /*                                                              */
  61. /* Function:    scan_for_int  - scan input stream for a single  */
  62. /*                              integer.                        */
  63. /*                                                              */
  64. /* Date: July 25, 1988                                          */
  65. /*                                                              */
  66. /* Interface:    SCAN_FOR_INT(-- n )                            */
  67. /*                                                              */
  68. /* ************************************************************ */
  69.  
  70. : SCAN_FOR_INT     ( --   num )   #IN ;
  71.  
  72.  
  73. /* ************************************************************ */
  74. /* Function: HBAR     Draws a horizontal bar on display         */
  75. /*                                                              */
  76. /* Date: July 25, 1988                                          */
  77. /*                                                              */
  78. /* Interface:   HBAR ( n  --)                                   */
  79. /*                                                              */
  80. /* ************************************************************ */
  81.  
  82. : HBAR ( n  -- )
  83.      0 DO ASCII = EMIT LOOP CR ;
  84.  
  85. /* ************************************************************ */
  86. /* Function: CLR_HBAR   Clear screan and draw horizontal bar    */
  87. /*                                                              */
  88. /* Date: July 25, 1988                                          */
  89. /*                                                              */
  90. /* Interface:   CLR_HBAR ( n   -- )                             */
  91. /*                                                              */
  92. /* ************************************************************ */
  93.  
  94. : CLR_HBAR ( n  -- )
  95.      27 EMIT ." [2J" CR HBAR ;
  96.  
  97. /* ************************************************************ */
  98. /* Function: GET_DOLLARS   Fetch dollars with error checking.   */
  99. /*                                                              */
  100. /* Date: July 22, 1988                                          */
  101. /*                                                              */
  102. /* Interface:   GET_DOLLARS ( --  n )                           */
  103. /*                                                              */
  104. /* ************************************************************ */
  105.  
  106. : GET_DOLLARS ( --  n )
  107.       BEGIN
  108.       27 EMIT ." [K Dollars: "
  109.       SCAN_FOR_INT CR DUP
  110.       9999 > OVER 0 < OR
  111.       WHILE
  112.       DROP 27 EMIT ." [1;A"
  113.       REPEAT ;
  114.  
  115. /* ************************************************************ */
  116. /* Function: GET_CENTS   Fetch cents with error checking.       */
  117. /*                                                              */
  118. /* Date: July 22, 1988                                          */
  119. /*                                                              */
  120. /* Interface:   GET_CENTS ( --  n )                             */
  121. /*                                                              */
  122. /* ************************************************************ */
  123.  
  124. : GET_CENTS ( --   n )
  125.         BEGIN
  126.         27 EMIT ." [K Cents: "
  127.         SCAN_FOR_INT CR DUP
  128.         99 > OVER 0 < OR
  129.         WHILE
  130.         DROP
  131.         27 EMIT ." [1;A"
  132.         REPEAT ;
  133.  
  134. /* ************************************************************ */
  135. /*                                                              */
  136. /* Function:    ROUND     - Roll cents into dollars.            */
  137. /*                                                              */
  138. /* Date: July 25, 1988                                          */
  139. /*                                                              */
  140. /* Interface:   ROUND ( dollars cents -- dollars' cents' )      */
  141. /*                                                              */
  142. /* ************************************************************ */
  143.  
  144. : ROUND ( dollars cents -- dollars' cents')
  145.       DUP >R
  146.       100 / +
  147.       R> 100 MOD ;
  148.  
  149. /* ************************************************************ */
  150. /*                                                              */
  151. /* Function: ADD_TO_BAL - Add dollars, cents amount to balance  */
  152. /*                                                              */
  153. /* Date: July 22, 1988                                          */
  154. /*                                                              */
  155. /* Interface:    ADD_TO_BAL ( dollars cents  -- )               */
  156. /*               dollars: dollar amount to be added             */
  157. /*               cents  : cents amount to be added              */
  158. /*                                                              */
  159. /* ************************************************************ */
  160.  
  161. : ADD_TO_BAL ( dollars cents  -- )
  162.       BAL_CENTS +!
  163.       BAL_DOLLARS +!
  164.       BAL_DOLLARS @ BAL_CENTS @ ROUND
  165.       BAL_CENTS ! BAL_DOLLARS ! ;
  166.  
  167. /* ************************************************************ */
  168. /*                                                              */
  169. /* Function:    SUB_FROM_BAL - subtract dollars, cents amount   */
  170. /*                             from balance.                    */
  171. /*                                                              */
  172. /* Date: July 22, 1988                                          */
  173. /*                                                              */
  174. /* Interface:   SUB_FROM_BAL ( dollars cents --  flag)          */
  175. /*               dollars : dollar amount to be subtracted       */
  176. /*               cents   : cents amount to be subtracted        */
  177. /*               flag = false if illeagal transaction.          */
  178. /*                                                              */
  179. /* ************************************************************ */
  180.  
  181. VARIABLE D
  182. VARIABLE C
  183.  
  184. : SUB_FROM_BAL ( dollars cents --  flag )
  185.         BAL_DOLLARS @ D !
  186.         BAL_CENTS   @ C !
  187.         DUP C @ >
  188.         IF  -1 D +! 100 C +! THEN
  189.         NEGATE C +! NEGATE D +!
  190.         D @ 0 <
  191.         IF   60 CLR_HBAR
  192.              7 DUP DUP EMIT EMIT EMIT
  193.             ." You are trying to overdraw your account. You must" CR
  194.             ." first make a deposit before trying to write a cheque" CR
  195.             ." this large." CR
  196.             60 HBAR
  197.             FALSE
  198.         ELSE  C @ BAL_CENTS ! D @ BAL_DOLLARS ! TRUE
  199.         THEN  ;
  200.  
  201. : $XX.XX  ( dollars cents  -- )
  202.        0  <# # # ASCII . HOLD DROP #S ASCII $ HOLD #> TYPE ;
  203.  
  204. /* ************************************************************ */
  205. /*                                                              */
  206. /* Function     WRITE_A_CHECK - Calculate new balance           */
  207. /*                              after check is written          */
  208. /*                                                              */
  209. /* Date: July 25, 1988                                          */
  210. /*                                                              */
  211. /* Interface:   WRITE_A_CHECK ( -- )                            */
  212. /*                                                              */
  213. /*                                                              */
  214. /* Notes: Calls SUB_FROM_BAL to perform the fixed point         */
  215. /*        calculations.                                         */
  216. /*                                                              */
  217. /* ************************************************************ */
  218.  
  219. : WRITE_A_CHECK ( -- )
  220.         40 CLR_HBAR
  221.         ." Enter the amount of the check:" CR
  222.         40 HBAR
  223.         GET_DOLLARS GET_CENTS ROUND
  224.         OVER OVER
  225.         TR_CENTS ! TR_DOLLARS !
  226.         40 HBAR
  227.         SUB_FROM_BAL
  228.         IF  1 CHK_COUNT +!
  229.             TR_DOLLARS @ CHK_DOLLARS @ +
  230.             TR_CENTS   @ CHK_CENTS   @ +
  231.             ROUND  
  232.             CHK_CENTS ! CHK_DOLLARS !
  233.            ." After writing a check for: " 
  234.            TR_DOLLARS @ TR_CENTS @ $XX.XX CR           
  235.            ." your new balance comes to: "
  236.            BAL_DOLLARS @ BAL_CENTS @ $XX.XX CR
  237.            40 HBAR
  238.        THEN ;
  239.  
  240. /* ************************************************************ */
  241. /*                                                              */
  242. /* Function:    MAKE_A_DEPOSIT - calculates new balance after   */
  243. /*                               a deposit is made.             */
  244. /*                                                              */
  245. /* Date: July 25, 1988                                          */
  246. /*                                                              */
  247. /* Interface:   MAKE_A_DEPOSIT ( --)                            */
  248. /*                                                              */
  249. /* Notes: Calls add_to_bal to perform fixed point calculations. */
  250. /*                                                              */
  251. /* ************************************************************ */
  252.  
  253. : MAKE_A_DEPOSIT ( -- )
  254.         40 CLR_HBAR
  255.         ." Enter the amount of the deposit: " CR
  256.         40 HBAR
  257.         GET_DOLLARS  TR_DOLLARS !
  258.         GET_CENTS    TR_CENTS !
  259.         1 DEP_COUNT +!
  260.         TR_DOLLARS @ DEP_DOLLARS @ + 
  261.         TR_CENTS   @ DEP_CENTS   @ +
  262.         ROUND  DEP_CENTS ! DEP_DOLLARS !
  263.         40 HBAR
  264.         TR_DOLLARS @ TR_CENTS @ ADD_TO_BAL
  265.        ." After a deposit of "
  266.        TR_DOLLARS  @ TR_CENTS  @ $XX.XX CR
  267.        ." your new balance comes to: "
  268.        BAL_DOLLARS @ BAL_CENTS @ $XX.XX CR
  269.        40 HBAR ;
  270.  
  271. /* ************************************************************ */
  272. /*                                                              */
  273. /* Function: NET_CHANGE       Displays net change from session  */
  274. /*                            start.                            */
  275. /*                                                              */
  276. /* Date: July 25, 1988                                          */
  277. /*                                                              */
  278. /* Interface:   NET_CHANGE ( -- )                               */
  279. /*                                                              */
  280. /* ************************************************************ */
  281.  
  282. VARIABLE DIF_DOLLARS
  283. VARIABLE DIF_CENTS
  284.  
  285. : NET_CHANGE ( -- )
  286.         BAL_DOLLARS @ DIF_DOLLARS !
  287.         BAL_CENTS   @ DIF_CENTS   !
  288. /*      40 CLR_HBAR
  289.         OLD_CENTS @ BAL_CENTS @ >
  290.         IF  -1 DIF_DOLLARS +!
  291.             100 DIF_CENTS +!
  292.         THEN
  293.         OLD_DOLLARS @ NEGATE DIF_DOLLARS +!
  294.         OLD_CENTS   @ NEGATE DIF_CENTS   +!
  295.         40 CLR_HBAR
  296.         ." Net change this session: "
  297.         DIF_DOLLARS @ 0 <
  298.         IF   100 DIF_CENTS @ - DIF_CENTS !
  299.              1 DIF_DOLLARS @ + NEGATE DIF_DOLLARS !
  300.              ASCII - EMIT 
  301.         THEN
  302.         DIF_DOLLARS @ DIF_CENTS @ $XX.XX CR
  303.         40 HBAR ;
  304.  
  305. /* ************************************************************ */
  306. /*                                                              */
  307. /* Function:    TOT_CHECKS     Displays total checks written    */
  308. /*                             this session.                    */
  309. /*                                                              */
  310. /* Date: July 25, 1988                                          */
  311. /*                                                              */
  312. /* Interface:   TOT_CHECKS ( --  )                              */
  313. /*                                                              */
  314. /* ************************************************************ */
  315.  
  316. : TOT_CHECKS ( -- )
  317.         70 CLR_HBAR
  318.         CHK_COUNT @ 0=
  319.         IF
  320.         ." There have been no checks written so far this session "
  321.         ." so the total is: "
  322.         ELSE CHK_COUNT @ 1 =
  323.              IF
  324.              ." Only one check has been written so far this session "
  325.              ." for a total of: "
  326.              ELSE
  327.             ." There were " CHK_COUNT @ .
  328.             ." checks written so far this session "
  329.             ." that total: "
  330.             THEN
  331.        THEN
  332.        CHK_DOLLARS @ CHK_CENTS @ $XX.XX CR
  333.        70 HBAR ;
  334.  
  335. /* ************************************************************ */
  336. /*                                                              */
  337. /* Function: TOT_DEPOSIT   Total deposits this session          */
  338. /*                                                              */
  339. /* Date: July 25, 1988                                          */
  340. /*                                                              */
  341. /* Interface:   TOT_DEPOSIT ( -- )                              */
  342. /*                                                              */
  343. /* ************************************************************ */
  344.  
  345. : TOT_DEPOSIT ( -- )
  346.         70 CLR_HBAR
  347.         DEP_COUNT @ 0=
  348.         IF
  349.         ." There have been no deposits so far this session "
  350.         ." so the total is: "
  351.         ELSE DEP_COUNT @ 1 =
  352.              IF
  353.              ." Only one deposite has been made so far this session "
  354.              ." for a total of: "
  355.              ELSE
  356.             ." There were " DEP_COUNT @ .
  357.             ." deposits made so far this session "
  358.             ." that total: "
  359.             THEN
  360.        THEN
  361.        DEP_DOLLARS @ DEP_CENTS @ $XX.XX CR
  362.        70 HBAR ;
  363.  
  364. /* ************************************************************ */
  365. /* Function: AVERAGE   Reports average check written this       */
  366. /*                     session                                  */
  367. /* Date: July 25, 1988                                          */
  368. /*                                                              */
  369. /* Interface:   AVERAGE ( -- )                                  */
  370. /*                                                              */
  371. /* ************************************************************ */
  372.  
  373. CREATE MILLS 4 ALLOT
  374. VARIABLE ADOLLARS
  375. VARIABLE ACENTS
  376.  
  377. : AVERAGE ( -- )
  378.         CHK_COUNT @ 0=
  379.         IF
  380.         50 CLR_HBAR
  381.         ." You have not written any checks this session." CR
  382.         50 HBAR
  383.         ELSE
  384.         CHK_DOLLARS @ 1000 UM*
  385.         CHK_CENTS @ 10 * 0 D+
  386.         CHK_COUNT @ 0 D/
  387.         5 0 D+  10 0 D/
  388.         OVER OVER 100 0 D/ DROP ADOLLARS !
  389.         100 0 DMOD DROP ACENTS !
  390.         60 CLR_HBAR
  391.         ." For this session the average check written was: "
  392.         ADOLLARS @ ACENTS @ $XX.XX CR
  393.         60 HBAR
  394.         THEN ;
  395.  
  396. /* ************************************************************ */
  397. /*                                                              */
  398. /* Function: BALANCE  - Handle user menu in checkbook program.  */
  399. /*                                                              */
  400. /*                                                              */
  401. /* Notes:  Uses a case statement to respond to choices made     */
  402. /*         from a menu.                                         */
  403. /*                                                              */
  404. /* ************************************************************ */
  405.  
  406.  
  407. : BALANCE ( --  flag )
  408.  
  409.    ." You may choose one of the following:" CR CR
  410.    ."    (1) Write a check." CR
  411.    ."    (2) Make a deposit." CR
  412.    ."    (3) Check your balance." CR
  413.    ."    (4) Net change this session." CR
  414.    ."    (5) Total checks this session." CR
  415.    ."    (6) Total deposits this session." CR
  416.    ."    (7) Average check written this session." CR
  417.    ."    (8) Exit." CR
  418.    ."    (9) Reinitialize." CR CR
  419.  
  420.    ." Enter your choice by typing the corresponding number." CR
  421.  
  422.         SCAN_FOR_INT  CR
  423.  
  424.         1  OVER = IF DROP WRITE_A_CHECK                  1 ELSE
  425.         2  OVER = IF DROP MAKE_A_DEPOSIT                 1 ELSE
  426.         3  OVER = IF DROP 40 HBAR
  427.                      ." Your current balance is: "
  428.                       BAL_DOLLARS @ BAL_CENTS @ $XX.XX CR
  429.                      40 HBAR                             1 ELSE
  430.         4  OVER = IF DROP NET_CHANGE                     1 ELSE
  431.         5  OVER = IF DROP TOT_CHECKS                     1 ELSE
  432.         6  OVER = IF DROP TOT_DEPOSIT                    1 ELSE
  433.         7  OVER = IF DROP AVERAGE                        1 ELSE
  434.         8  OVER = IF DROP
  435.                      60 CLR_HBAR
  436.                      ." Check Book terminated normally "
  437.                      ." with a balance of: "
  438.                      BAL_DOLLARS @ BAL_CENTS @ $XX.XX CR
  439.                      60 HBAR FAST  QUIT ( CR 0 0 BDOS )    ELSE
  440.         9  OVER = IF DROP                                0 ELSE
  441.                      40 CLR_HBAR
  442.                       7 DUP DUP EMIT EMIT EMIT
  443.                      ." That choice is unavailable, try again." CR
  444.                      ." Type 1, 2, 3, 4, 5, 6, 7, 8 or 9." CR
  445.                      40 HBAR DROP 1
  446.                   THEN THEN THEN THEN THEN
  447.                   THEN THEN THEN THEN      ;
  448.  
  449. /* ************************************************************ */
  450. /*                                                              */
  451. /* Function: Checkbook  main function of the checkbook program. */
  452. /*                                                              */
  453. /* Date:        July 21, 1988                                   */
  454. /*                                                              */
  455. /* Interface:   int checkbook()                                 */
  456. /*                                                              */
  457. /* Notes: This program will do your checkbook calculations      */
  458. /* Why would anyone use a computer to balance their checkbook?  */
  459. /*                                                              */
  460. /* ************************************************************ */
  461.  
  462. : MAIN ( -- )
  463.    SLOW
  464.    BEGIN
  465.    BAL_DOLLARS OFF BAL_CENTS OFF TR_DOLLARS OFF TR_CENTS OFF
  466.    OLD_DOLLARS OFF OLD_CENTS OFF CHK_DOLLARS OFF CHK_CENTS OFF
  467.    DEP_COUNT OFF CHK_COUNT OFF DEP_DOLLARS OFF DEP_CENTS OFF
  468.  
  469.    40 CLR_HBAR
  470.    ." Welcome to your checkbook." CR
  471.    ." Please enter your current balance:" CR
  472.    40 HBAR
  473.    GET_DOLLARS DUP OLD_DOLLARS ! BAL_DOLLARS !
  474.    GET_CENTS   DUP OLD_CENTS   ! BAL_CENTS   !
  475.    40 HBAR
  476.    ." Thank you. Your current balance is: "
  477.    BAL_DOLLARS @ BAL_CENTS @ $XX.XX CR
  478.    40 HBAR
  479.    BEGIN
  480.    BALANCE
  481.    0= UNTIL
  482.    AGAIN ;
  483.  
  484.  
  485.