home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / jb_edit.seq < prev    next >
Text File  |  1990-04-20  |  15KB  |  339 lines
  1. \ File:          JB#EDIT.SEQ
  2. \ Original Date: September 12, 1988
  3. \ Last Modified: April 20, 1990
  4. \ Author:        Jack W. Brown
  5. \ Function:      Single, Double, and Floating Variable editing
  6. \                and numeric input.
  7. \ Note:          Floating point operators assume VP-Planner floating
  8. \                point routines are loaded.  VPSFP101.ZIP or later.
  9.  
  10. CR .( Requires VP-Planner Floating point to be loaded. )
  11.  
  12. \ ┌────────────────────────────────────────────────────────────────────┐
  13. \ │                 Description                                        │
  14. \ ├────────────────────────────────────────────────────────────────────┤
  15. \ │  One characteristic ( perhaps novel ) of these operators is        │
  16. \ │  that they take the address of a variable ( single, double or      │
  17. \ │  floating ) and allow the user to edit the contents of the         │
  18. \ │  variable.                                                         │
  19. \ │                                                                    │
  20. \ │  VARIABLE A   123 A !     followed by:                             │
  21. \ │  A S#ED                   would display  123 on the screen         │
  22. \ │                           in a default field 6 spaces wide.        │
  23. \ │                                                                    │
  24. \ │  User could then edit or modify the number and upon pressing       │
  25. \ │  return the changed value would be automatically stored back       │
  26. \ │  in the VARIABLE A                                                 │
  27. \ │                                                                    │
  28. \ │  2VARIABLE B  123.45 B 2!   followed by:                           │
  29. \ │  B D#ED                     would do the same for doubles in       │
  30. \ │                             a default field 12 wide.               │
  31. \ │                                                                    │
  32. \ │  FVARIABLE C  1.56E-4 C F!  followed by:                           │
  33. \ │  C F#ED                     would do the same for floating         │
  34. \ │                             point with 12 the default field.       │
  35. \ │                                                                    │
  36. \ │  A similar family of words,  WS#ED , WD#ED , and WF#ED             │
  37. \ │  allowed the user to specify his own field width, and yet          │
  38. \ │  another family of words,  XYWS#ED , XYWD#ED , and XYWF#ED         │
  39. \ │  allow users to specify the column X , row Y , and the width W.    │
  40. \ │                                                                    │
  41. \ │  Here is the whole family: adr = variable address, x is cursor     │
  42. \ │  column, y is cursor row, and w is input field width.              │
  43. \ │                                                                    │
  44. \ │  S#ED ( adr -- )   WS#ED ( adr w -- )   XYWS#ED ( adr x y w -- )   │
  45. \ │  D#ED ( adr -- )   WD#ED ( adr w -- )   XYWD#ED ( adr x y w -- )   │
  46. \ │  F#ED ( adr -- )   WF#ED ( adr w -- )   XYWF#ED ( adr x y w -- )   │
  47. \ │                                                                    │
  48. \ │  Using the above operators it is a simple mater to implement       │
  49. \ │  a more traditional set of operators that leave their input on     │
  50. \ │  on the parameter or floating point stack.                         │
  51. \ │                                                                    │
  52. \ │     S#IN ( -- n )        WS#IN ( w -- n )                          │
  53. \ │  XYWS#IN ( x y w -- n )                                            │
  54. \ │     D#IN ( -- dn)        WD#IN ( w -- dn)                          │
  55. \ │  XYWD#IN ( x y w -- dn)                                            │
  56. \ │                                                                    │
  57. \ │  Floating point input operators left values on the floatinng       │
  58. \ │  point stack.                                                      │
  59. \ │             parameter stack     floating point stack               │
  60. \ │        F#IN ( P: -- )           ( F: -- r )                        │
  61. \ │       WF#IN ( P: w -- )         ( F: -- r )                        │
  62. \ │     XYWF#IN ( P: x y w -- )     ( F: -- r )                        │
  63. \ └────────────────────────────────────────────────────────────────────┘
  64.  
  65. ONLY  FORTH ALSO DEFINITIONS
  66.  
  67. CREATE TPAD 34 ALLOT  TPAD 34 BLANK
  68.  
  69. CREATE SNUM 10 ALLOT   \ Scratch variable of ????IN operators.
  70.  
  71. \ Leave a true flag if string begins with a -ve sign.
  72. \ Note we assume a counted string!!  adr is 1 less than the
  73. \ the first string character.
  74. : ANY-SIGN? ( adr -- adr' flag )
  75.         DUP 1+ C@ DUP ASCII - =     \ Increment adr , check for -
  76.         IF    DROP 1+ TRUE          \ Leave true flag if found.
  77.         ELSE  ASCII + =             \ Allow a +sign if desired.
  78.               IF    1+  THEN        \ Increment past + sign
  79.               FALSE                 \ and leave false flag.
  80.         THEN ;
  81.  
  82. \ Move up to first non blank of string.  Actually adr' points
  83. \ to position before first non blank!!
  84. : SKIP-BLANKS ( adr -- adr' )
  85.         BEGIN 1+ DUP C@ BL <> UNTIL  1-  ;
  86.  
  87. \ Set cursor from 16 bit hi-x lo-y format.
  88. : CUR!  ( xy -- )  SPLIT AT ;
  89.  
  90. \ Fetch cursor to 16 bit form.
  91. : CUR@  ( -- xy )  IBM-AT? FLIP + ;
  92.  
  93. \ This character will fill unused digit posn
  94. 254 CONSTANT CHFL
  95.  
  96.  
  97. \ This routine edits a counted string and converts to double number.
  98. \ cur is cursor x y packed into one word.
  99. \ We are using F-PC's LINEEDITOR ( x y a n -- flag )
  100. : ED_CONVERT  ( adr n cur -- cur adr n dn )
  101.         BEGIN DUP >R                     \ a n c  Position cursor.
  102.           -ROT R> SPLIT 2OVER            \ c a n x y a n
  103.           LINEEDITOR DROP                \ c a n  Edit string.
  104.           OVER SKIP-BLANKS               \ c a n  Move up to non-blank
  105.           ANY-SIGN?                      \ c a n a' flg
  106.           >R 0 0 ROT -1                  \ c a n dn a' -1
  107.           BEGIN  DPL !  CONVERT          \ c a n dn a"
  108.             DUP C@  ASCII . =            \ c a n dn a" flg
  109.             WHILE 0 REPEAT               \ c a n dn a" 0
  110.             C@ DUP CHFL =
  111.             SWAP BL = OR  NOT            \ c a n dn flag
  112.         WHILE 2DROP R> DROP BEEP         \ c a n
  113.               ASCII ? 2 PICK 1+ C! ROT   \ a n c    marks error
  114.         REPEAT R> ?DNEGATE               \ c a n dn
  115.         DPL @ 0< IF DPL OFF THEN ;       \ DPL=0 if .pt not entered
  116.  
  117.  
  118. \ Fetch a double number using field with of n  using adr  for
  119. \ and input buffer.  Invalid input is marked by ?  and user is
  120. \ required to repeat until he makes a valid number.
  121. : (#ED)  ( adr n -- dn )
  122.         CUR@ ED_CONVERT               \ cur adr n dn
  123.         >R >R                         \ Save double number.
  124.         1+ ROT + CUR!                 \ Restore cursor.
  125.         DROP R> R> ;                  \ Recover our number.
  126.  
  127.  
  128. \  ┌───────────────────────────────────────────────────────┐
  129. \  │  32 bit Variable Editing and 32 bit numeric input.    │
  130. \  └───────────────────────────────────────────────────────┘
  131.  
  132.  
  133. \ As above but field width is specified on the stack.
  134. : WD#ED  ( adr w   -- )
  135.         >R
  136.         TPAD 1+ 32 CHFL FILL    \ blank input field.
  137.         R@ TPAD C!
  138.         DUP 2@ 2DUP D0=         \ Is number 0 ?
  139.         IF   2DROP              \ if so provide blank field
  140.         ELSE TUCK DABS          \ other wise
  141.              <# #S ROT SIGN #>  \ format number and move
  142.              TPAD 1+ SWAP R@    \ to the edit buffer.
  143.              MIN CMOVE
  144.         THEN
  145.         TPAD  R>  (#ED) ROT 2! ;
  146.  
  147. \ Edit double number at current cursor position using default
  148. \ field with of 12.   Input buffer is at TPAD
  149. : D#ED   ( adr -- )
  150.         12 WD#ED  ;
  151.  
  152. \ As above but cursor & field width are specified on the stack.
  153. : XYWD#ED  ( adr x y w   -- )
  154.         -ROT AT WD#ED ;
  155.  
  156.  
  157. \ Input double number with field width on stack
  158. \ and leave resulting double number on the parameter stack.
  159. : WD#IN  ( w -- dn )
  160.         0 0 SNUM 2!
  161.             SNUM SWAP WD#ED
  162.             SNUM 2@  ;
  163.  
  164. \ Input double number and leave on parameter stack.
  165. : D#IN  ( -- dn )
  166.         12 WD#IN ;
  167.  
  168.  
  169. \ Input double number at cursor postion x y using a field width w
  170. \ and leave the resulting double number on the parameter stack.
  171. : XYWD#IN  ( x y w -- dn )
  172.         -ROT AT WD#IN ;
  173.  
  174. \  ┌───────────────────────────────────────────────────────┐
  175. \  │  16 bit Variable Editing and 16 bit Numeric Input.    │
  176. \  └───────────────────────────────────────────────────────┘
  177.  
  178. \ As above but field width is specified on the stack.
  179. : WS#ED  ( adr w   -- )
  180.         >R
  181.         TPAD 1+ 32 CHFL FILL       \ blank input field.
  182.         R@ TPAD C!
  183.         DUP @ DUP 0=               \ Is number 0 ?
  184.         IF    DROP                 \ if so provide blank field
  185.         ELSE  S>D TUCK DABS        \ other wise
  186.               <# #S ROT SIGN #>    \ format number and move
  187.               TPAD 1+ SWAP R@      \ to the edit buffer.
  188.               MIN CMOVE
  189.         THEN
  190.         TPAD   R> (#ED) DROP SWAP ! ;
  191.  
  192. \ Edit single number a current cursor position using default
  193. \ field with of 6.   Edit buffer is at TPAD
  194. : S#ED ( adr   -- )
  195.         6 WS#ED ;
  196.  
  197. \ As above but cursor & field width are specified on the stack.
  198. : XYWS#ED  ( adr x y n   -- )
  199.         -ROT AT WS#ED ;
  200.  
  201. \ Input single number with field width on stack
  202. \ and leave resulting single number on the parameter stack.
  203. : WS#IN  ( w --  n )
  204.       0 SNUM !   SNUM SWAP WS#ED   SNUM @  ;
  205.  
  206. \ Input single number in a default field 6 wide
  207. \ and leave on parameter stack.
  208. : S#IN  ( -- n )
  209.           6 WS#IN ;
  210.  
  211. \ Input single number at cursor postion x y using a field width w
  212. \ and leave the resulting single number on the parameter stack.
  213. : XYWS#IN  ( x y w --  n )
  214.       0 SNUM !  ROT SNUM SWAP 2SWAP XYWS#ED   SNUM @  ;
  215.  
  216. \  ┌────────────────────────────────────────────────────────────────────┐
  217. \  │ Floating point varialbe editing and floating point numeric input.  │
  218. \  └────────────────────────────────────────────────────────────────────┘
  219.  
  220. HEX
  221.  
  222. \ This routine edits a counted string and converts it to a double number.
  223. \ cur is cursor x y packed into one word.
  224. : ED_FCONVERT  ( adr n cur -- cur adr n dn )
  225.         BEGIN DUP >R                \ a n c  Position cursor.
  226.           -ROT R> SPLIT 2OVER       \ c a n x y a n
  227.           LINEEDITOR DROP           \ c a n  Edit string.
  228.           OVER COUNT + BL SWAP C!   \ FIX
  229.           OVER SKIP-BLANKS          \ c a n  Move up to non-blank
  230.           ANY-SIGN?                 \ c a n a' flg      / sgn[dn]
  231.           >R 0 0 ROT 8000           \ c a n |dn| a' -1
  232.           BEGIN  DPL !  FCONVERT    \ c a n |dn| a"
  233.             DUP C@  ASCII . =       \ c a n |dn| a" flg
  234.             WHILE 0 REPEAT          \ c a n |dn| a" 0
  235.             DUP C@ 0DF AND          \ Allow lower case e for exponent.
  236.             ASCII E =               \ c a n |d| a3 f2   / sgn[dn]
  237.             IF DPL @ 0 MAX >R       \ c a n |d| a3 f2   / DPL sgn[dn]
  238.                ANY-SIGN? >R         \ c a n |d| a3 f2   / sgn[exp] DPL sgn[dn]
  239.                DUP C@               \ c a n |dn| a5 c   / sgn[exp] DPL sgn[dn]
  240.                DUP CHFL =
  241.                SWAP BL = OR
  242.                IF   R> R> 2DROP     \ c a n |dn| a5     / sgn[D]
  243.                ELSE DBL0 ROT
  244.                     FCONVERT        \ c a n |dn| de a6  / sgn[de] DPL sgn[dn]
  245.                     NIP SWAP
  246.                     R> NOT
  247.                     ?NEGATE
  248.                     R> + DPL !      \ c a n |dn| a6     / sgn[dn]
  249.                THEN
  250.              THEN                   \ c a n |dn| a7     / sgn[dn]
  251.             C@ DUP CHFL =
  252.             SWAP BL = OR  NOT             \ c a n |dn| flag / sgn[dn]
  253.         WHILE 2DROP R> DROP BEEP          \ c a n
  254.               ASCII ? 2 PICK 1+ C! ROT    \ a n c    Mark error
  255.         REPEAT R> ?DNEGATE                \ c a n dn
  256.         DPL @ 8000 = IF DPL OFF THEN ;    \ DPL=0 if .pt not entered
  257. DECIMAL
  258.  
  259.  
  260. \ Fetch a floating number using field with of n  using adr  for
  261. \ and input buffer.  Invalid input is marked by ?  and user is
  262. \ required to repeat until he makes a valid number.
  263. : (#FED)  ( P: adr n -- ) ( F: -- r )
  264.         CUR@ ED_FCONVERT              \ cur adr n dn
  265.         >R >R                         \ Save double number.
  266.         1+ ROT + CUR!                 \ Restore cursor.
  267.         DROP R> R> FLOAT ;            \ Recover our number.
  268.  
  269.  
  270.  
  271.  
  272. \ Edit double number at current cursor position using field with
  273. \ field with of w.   Input buffer is at TPAD
  274. : WF#ED   ( adr w -- )
  275.         >R
  276.         TPAD 1+  32 CHFL FILL
  277.         R@ TPAD C!
  278.         DUP F@ FDUP F0=
  279.         IF   FDROP
  280.         ELSE FDUP R@ 2- (..) ?DUP 0=
  281.              IF DROP ?NONAN1
  282.                  IF R@ 6 - (E.)
  283.                  ELSE (.NAN)
  284.                  THEN
  285.              ELSE FDROP
  286.              THEN             \ adr  adr" len
  287.              TPAD 1+ SWAP R@ MIN CMOVE
  288.         THEN
  289.         TPAD     R> (#FED)  F! ;
  290.  
  291. \ Edit floating  number at current cursor position using default
  292. \ field with of 16.   Input buffer is at TPAD
  293. : F#ED   ( adr -- )
  294.         16 WF#ED ;
  295.  
  296. \ As above but cursor & field width are specified on the stack.
  297. : XYWF#ED  ( adr x y w   -- )
  298.         -ROT AT WF#ED ;
  299.  
  300. \ Input floating point number with field width on stack
  301. \ and leave resulting floating point number on the floating point stack.
  302. : WF#IN  ( P: w -- )  ( F: -- r )
  303.         0.  SNUM F!   SNUM SWAP WF#ED   SNUM F@  ;
  304.  
  305. \ Input floating point number and leave on floating point stack.
  306. : F#IN  ( F: --  r )
  307.         16 WF#IN ;
  308.  
  309. \ Input floating point number at cursor postion x y using a field width w
  310. \ and leave the resulting floating point number on the floating point stack.
  311. : XYWF#IN  ( P: x y w -- ) ( F: -- r )
  312.            -ROT AT WF#IN ;
  313.  
  314. comment:
  315.   VARIABLE SS     123    SS  !
  316.   DOUBLE
  317.  2VARIABLE DD     123.45 DD 2!
  318.   FLOATING
  319.  FVARIABLE FF     123.45 FF F!
  320.  
  321. : TEST  ( -- )
  322. CLS
  323. CR ." Testing single variable editing."
  324. CR SS            S#ED ( adr -- )        SS @ .
  325. CR SS 8         WS#ED ( adr w -- )      SS @ .
  326. CR SS 40 10 8 XYWS#ED ( adr x y w -- )  SS @ .
  327. CLS
  328. CR ." Testing double variable editing."
  329. CR DD            D#ED ( adr -- )        DD 2@ D.
  330. CR DD 8         WD#ED ( adr w -- )      DD 2@ D.
  331. CR DD 40 10 8 XYWD#ED ( adr x y w -- )  DD 2@ D.
  332. CLS
  333. CR ." Testing floating point variable editing."
  334. CR FF             F#ED ( adr -- )        FF F@ ..
  335. CR FF 12         WF#ED ( adr w -- )      FF F@ ..
  336. CR FF 40 10 12 XYWF#ED ( adr x y w -- )  FF F@ ..  ;
  337. comment;
  338.  
  339.