home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 400-499 / ff471.lzh / MoleWt / MoleWt.4th < prev    next >
Text File  |  1991-04-17  |  18KB  |  528 lines
  1. \ A molecular weight calculator V1.01 - by John Kennan
  2. \ Last Modified on 3/8/91
  3.  
  4. \ First we include some words I wrote that I found useful
  5. \ It assumes you keep your Include files in an assigned directory or
  6. \ disk named Includes
  7.  
  8. Include Includes:Misc/IOWords.4th
  9. Include Includes:Misc/Struct.4th
  10.  
  11. \ Anew Moleweight \ Don't need in Turnkey
  12. \ *************************
  13.  
  14. CStruct NewWindow MWWindow    \ Allot a NewWindow Structure
  15.     5 w,     10 w,    \ Leftedge TopEdge
  16.   300 w,    120 w,    \ Width Height
  17.     0 c,      1 c,    \ DetailPen BlockPen
  18.  GadgetUp fCloseWindow | RefreshWindow |
  19.               ,    \ IDCMPFlags
  20.  Smart_Refresh WindowDrag | WindowClose | WindowSizing | WindowDepth |
  21.  Activate |         ,    \ Flags
  22.     0  ,      0  ,    \ FirstGadget Checkmark
  23.     0  ,      0  ,    \ Title Screen
  24.     0  ,        \ Bitmap
  25.   175 w,    150 w,    \ minWidth minHeight
  26.   320 w,    150 w,    \ maxWidth maxHeight
  27.   WbenchScreen    w,    \ Type
  28. StructEnd
  29.  
  30. \ These are the gadget ID's.  These are the numbers Intuition
  31. \ will return to let the program know which gadget was activated
  32.  
  33. 25 Constant StringGadID
  34. 26 Constant QuitGadID
  35. 27 Constant InfoGadID
  36. \ other constants
  37.  
  38. 2 Constant #SRGadText    \ The number of boolean gadgets ( Info, Quit )
  39. 80 CONSTANT SRMaxChar    \ The maximum # of chars in string gadget
  40.  
  41. \ Variables
  42.  
  43. \ ******************
  44. \ AutoRequest Code
  45. \ Create the Autorequest for Credits
  46.  
  47. CREATE ARTextArray
  48. 0," Okay"
  49. 0," Okay"
  50. 0," In Multi-Forth by J. Kennan"
  51.  
  52. 3  CONSTANT #ReqIntuitext
  53. 275 CONSTANT ARWidth
  54. 75  CONSTANT ARHEIGHT
  55.  
  56. \ An array to store Requester Intuitext Structs
  57. #ReqIntuitext Intuitext 1Array ReqIntuitext 
  58.  
  59. : InitIText   \ Initialize intuitext
  60.     #ReqIntuitext  0 DO
  61.     i ReqIntuitext
  62.     0 OVER +itFrontpen    C!
  63.     1 OVER +itBackPen    C!
  64.     Jam2  OVER +itDrawMode    C!
  65.     6 OVER +itLeftEdge    W!
  66.     4 OVER +itTopEdge    W!
  67.     0 OVER +itITextFont    !
  68.     0 OVER +itIText        !    \ ptr to string - initialize at run time
  69.     0 SWAP +itNextText    !    \ ptr to next intuitext - init. at run time
  70.   LOOP ;
  71.  
  72. InitItext Forget InitItext    \ Initialize Requester Intuitexts
  73.                 \ and then forget the intialization code
  74.     
  75. : RIntuitext>Text   \ put the text ptrs into intuitext at run time
  76.             \ Must be called before DoAutoRequest is used
  77.     #ReqIntuitext  ARTextArray 0 ReqIntuitext Intuitext>Text ;
  78.  
  79. : DoAutoRequest ( txt--flag )  \ given a ptr to text, creates the Autorequest
  80.     CurrentWindow @
  81.     Swap
  82.     0 ReqIntuitext        \ Get text for left bool gadget
  83.     1 ReqIntuitext        \ Get text for right bool gadget
  84.     0
  85.     0
  86.     ARWidth            \ Width of AutoReq.
  87.     ARHeight        \ Height of AutoReq.
  88.     AutoRequest ;        \ Do it!
  89.     
  90. : ReqInfo  ( --flag )  \ This is the autorequester for info
  91.     2 ReqIntuitext DoAutoRequest Drop ; 
  92.  
  93. \ End of Code for AutoRequest 
  94. \ ******************
  95.  
  96. \ The structures that will be required
  97.  
  98. #SRGadText Intuitext 1ARRAY SRGadgetIntuitexts  \ one intuitext struct
  99.                             \ used by Bool gadget
  100. Struct Gadget     SRStringGadget        \ string gadget
  101. Struct StringInfo SRStringInfo             \ stringInfo Structure
  102. Struct Border     SRStringBorder1    \ border for string gadget
  103. Struct Border     SRStringBorder2       \ shadow of border for string gadget
  104. Struct Intuitext  SRStringIntuitext    \ intuitext for input string
  105. Struct Gadget     SRQuitGadget           \ bool gadget
  106. Struct Gadget      SRInfoGadget        \ bool gadget
  107. Struct Border     SRBoolBorder1        \ border for bool gadget
  108. Struct Border     SRBoolBorder2         \ shadow of border for bool gadget
  109.  
  110. \ The text for the two Boolean gadgets
  111. Create SRGadgetTexts   
  112. 0," Quit"
  113. 0," Info"
  114.  
  115. : InitSRGadgetIntuitexts   \ initialize the intuitext structures for the
  116.                \ Gadgets ( Info and Quit )
  117.    #SRGadText 0 DO
  118.     i SRGadgetIntuitexts
  119.     1 OVER +itFrontPen  C!
  120.     0 OVER +itBackPen   C!
  121.      Jam2 OVER +itDrawMode  C!
  122.         8 OVER +itLeftEdge  W!
  123.         4 OVER +itTopEdge   W!
  124.     0 OVER +itITextFont  !
  125.     0 OVER +itIText      !  \ Init at RT
  126.     0 SWAP +itNextText   !  \ Init at RT
  127.     LOOP ;
  128.  
  129. InitSRGadgetIntuitexts Forget InitSRGadgetIntuitexts
  130.                 \ Initial Gadget Intuitexts at compile time
  131.                 \ then forget the initialization code
  132.  
  133. : SRGadgetIntuitexts>SRTexts    \ text addr into intuitext struct at RT
  134.     #SRGadText SRGadgetTexts 0 SRGadgetIntuitexts Intuitext>Text ;
  135.  
  136. \ fill the string gadget structure
  137. SRStringGadget
  138.       0 OVER +ggNextGadget       !  \ Init at RT
  139.      20 OVER +ggLeftEdge      W!
  140.      35 OVER +ggTopEdge       W!
  141.     188 OVER +ggWidth      W!
  142.       8 OVER +ggHeight      W!
  143.   gadgHcomp OVER +ggFlags      W!
  144.   relverify OVER +ggActivation      W!  
  145.    strGadget 
  146.         OVER +ggGadgetType    W!
  147.       0 OVER +ggGadgetRender   !  \ Init at RT
  148.       0 OVER +ggSelectRender   !
  149.       0 OVER +ggGadgetText       !  \ Init at RT
  150.       0 OVER +ggMutualExclude  !
  151.       0 OVER +ggSpecialInfo       !  \ Init at RT
  152. StringGadID OVER +ggGadgetID      W!
  153.       0 SWAP +ggUserData       ! 
  154. StructEnd
  155.  
  156. CREATE SRStringbdXY1   \ relative XY coord. of box around string gadget
  157.    0 w, 11 w,  0 w, 0 w,  192 w, 0 w,
  158.  
  159. CREATE SRStringbdXY2
  160.    192 w, 0 w, 192 w, 11 w, 0 w, 11 w,
  161.  
  162. CREATE |SRString SRMaxChar 1+ ALLOT   \ create the buffer for the string
  163. |SRString SRMaxChar 1+ ERASE          \ gadget text
  164. 0 |SRString C!                  \ must be initialized with empty
  165.                       \ string
  166.  
  167. SRStringInfo StringInfo ERASE          \ clear stringInfo struct
  168. SRMaxChar SRStringInfo +siMaxChars W! \ set the maximum #Chars in Buffer
  169.  
  170. \ Fill String Border structure 
  171. SRStringBorder1
  172.    -3      OVER    +bdLeftEdge  w!
  173.    -2      OVER    +bdTopEdge   w!
  174.    1       OVER    +bdFrontPen  C!
  175.    0       OVER    +bdBackPen   C!
  176.    jam1    OVER    +bdDrawMode  C!
  177.    3       OVER    +bdCount     C!
  178.    0       OVER    +bdXY         !  \ Init at RT
  179.    0       SWAP    +bdNextBorder !  \ Init at RT
  180. Structend
  181.  
  182. SRStringBorder2
  183.    -3      OVER    +bdLeftEdge  w!
  184.    -2      OVER    +bdTopEdge   w!
  185.    2       OVER    +bdFrontPen  C!
  186.    0       OVER    +bdBackPen   C!
  187.    jam1    OVER    +bdDrawMode  C!
  188.    3       OVER    +bdCount     C!
  189.    0       OVER    +bdXY         !  \ Init at RT
  190.    0       SWAP    +bdNextBorder !  \ Init at RT
  191. Structend
  192.  
  193. : InitStrGadget     \ Run time initializations of String Gadget Pointers
  194.     SRStringbdXY1 SRStringBorder1 +bdXY !
  195.                 \ give border ptr to image
  196.     SRStringbdXY2 SRStringBorder2 +bdXY !
  197.                 \ give shadow border ptr to image
  198.     SRStringBorder2 SRStringBorder1 +bdNextBorder !
  199.                 \ link the two borders for the string gad.
  200.     SRStringBorder1 SRStringGadget +ggGadgetRender !
  201.                 \ give gadget ptr to border 
  202.     |SRString SRStringInfo +siBuffer ! 
  203.                 \ give Gadget's Info ptr to str buffer
  204.     SRStringInfo SRStringGadget +ggSpecialInfo ! ;
  205.                 \ give Gadget ptr to Info struct
  206.  
  207.  
  208. SRQuitGadget        \ fill the Quit gadget
  209.       0 OVER +ggNextGadget       !  \ Init at RT
  210.         125 OVER +ggLeftEdge      W!
  211.      70 OVER +ggTopEdge      W!
  212.      61 OVER +ggWidth      W!
  213.      18 OVER +ggHeight      W!
  214.   gadgHcomp OVER +ggFlags      W!
  215.   relVerify                 
  216.         OVER +ggActivation      W!  \ gadget will end requester
  217.   boolGadget 
  218.         OVER +ggGadgetType    W!
  219.       0 OVER +ggGadgetRender   !  \ Init at RT
  220.       0 OVER +ggSelectRender   !
  221.       0 OVER +ggGadgetText       !  \ Init at RT
  222.       0 OVER +ggMutualExclude  !
  223.       0 OVER +ggSpecialInfo       !
  224.   QuitGadID OVER +ggGadgetID      W!    
  225.       0 SWAP +ggUserData       !      
  226. Structend
  227.  
  228. SRQuitGadget SRInfoGadget Gadget CMove    \ Copy the Quit Gadget Structure
  229.  
  230. SRInfoGadget                \ Then make minor changes
  231.          40 OVER +ggLeftEdge      W!
  232.   InfoGadID Swap +ggGadgetID      W!
  233.  
  234. CREATE SRBoolbdXY1   \ 3 XY pairs describing inner box around Bool gadgets
  235.     0 w, 18 w,
  236.     0 w,  0 w,
  237.    62 w,  0 w,
  238.  
  239. CREATE SRBoolbdXY2   \ 3 XY pairs describing shadow for box around Bool gadgets
  240.    63 w,  0 w,
  241.    63 w, 19 w,
  242.     0 w, 19 w,
  243.  
  244. SRBoolBorder1   \ fill border structure for bool gadgets
  245.    -2      OVER    +bdLeftEdge  w!
  246.    -1      OVER    +bdTopEdge   w!
  247.    1       OVER    +bdFrontPen  C!
  248.    0       OVER    +bdBackPen   C!
  249.    jam1    OVER    +bdDrawMode  C!
  250.    3       OVER    +bdCount     C!
  251.    0       OVER    +bdXY         !  \ init at RT
  252.    0       SWAP    +bdNextBorder !  \ init at RT
  253. Structend
  254.  
  255. SRBoolBorder2   \ border structure for shadow for bool gadgets
  256.    -2      OVER    +bdLeftEdge  w!
  257.    -1      OVER    +bdTopEdge   w!
  258.    2       OVER    +bdFrontPen  C!
  259.    0       OVER    +bdBackPen   C!
  260.    jam1    OVER    +bdDrawMode  C!
  261.    3       OVER    +bdCount     C!
  262.    0       OVER    +bdXY         !  \ init at RT
  263.    0       SWAP    +bdNextBorder !  \ init at RT
  264. Structend
  265.  
  266. : SRBoolGadget>Border  \ run time linkage of gadget with border
  267.     SRBoolbdXY1    SRBoolBorder1   +bdXY !
  268.     SRBoolbdXY2    SRBoolBorder2   +bdXY !
  269.     SRBoolBorder2  SRBoolBorder1   +bdNextBorder !
  270.     SRBoolBorder1  SRQuitGadget +ggGadgetRender !
  271.     SRBoolBorder1  SRInfoGadget +ggGadgetRender ! ;
  272.  
  273. : SRBoolGadget>Text \ run time linkage of gadget with text
  274.     0 SRGadgetIntuitexts SRQuitGadget +ggGadgetText !
  275.     1 SRGadgetIntuitexts SRInfoGadget +ggGadgetText ! ;
  276.     
  277. : SRStrGadget>SRBoolGadgets \ run time linkage of 
  278.                 \ Bool gadgets to string gadget
  279.    SRQuitGadget  SRStringGadget +ggNextGadget !
  280.    SRInfoGadget  SRQuitGadget   +ggNextGadget !  ;
  281.     
  282. \ Fill the string intuitext by copying a previously defined
  283. \ Intuitext structure
  284.  
  285. 0 SRGadgetIntuitexts SRStringIntuitext INTUITEXT CMOVE
  286.         SRStringIntuitext   
  287.         0 OVER +itLeftEdge  W!
  288.       -10 Swap +itTopEdge   W!
  289.  
  290. : Intuitext>SRString ( -- )   \ Run time linkage of Intuitext with text
  291.     0" Molecular Formula:" SRStringIntuitext +itIText ! ;
  292.  
  293. : SRGadget>SRIntuitext ( -- )  \ Run time linkage of Gadget with intuitext
  294.     SRStringIntuitext SRStringGadget +ggGadgetText ! ;
  295.     
  296. : Window>Data ( -- )  \ runtime linkage of file requester
  297.     MWWindow
  298.     0" MoleWt Calc."  Over +nwTitle !
  299.     SRStringGadget    Swap +nwFirstGadget !  ; \ give window a ptr to gadgets
  300.  
  301. : CorrectRunTimePtrs ( -- )    
  302.     InitStrGadget
  303.     RIntuitext>Text        \ Give Req. Intuitexts ptrs to text
  304.         SRGadgetIntuitexts>SRTexts
  305.     SRStrGadget>SRBoolGadgets
  306.     SRBoolGadget>Border
  307.     SRBoolGadget>Text
  308.     Window>Data
  309.     Intuitext>SRString
  310.     SRGadget>SRIntuitext ;
  311.  
  312. CREATE MoleWtTable
  313. 1008 ,        4003 ,        6941 ,        9012 ,
  314. 10810 ,        12011 ,        14007 ,        15999 ,
  315. 18998 ,        20179 ,        22990 ,        24305 ,
  316. 26982 ,        28086 ,        30974 ,        32060 ,
  317. 35453 ,        39948 ,        39102 ,        40080 ,
  318. 44956 ,        47900 ,        50941 ,        51996 ,
  319. 54938 ,        55847 ,        58933 ,        58710 ,
  320. 63546 ,        65370 ,        69720 ,        72590 ,
  321. 74922 ,        78960 ,        79904 ,        83800 ,
  322. 85468 ,        87620 ,        88906 ,        91220 ,
  323. 92906 ,        95940 ,        98906 ,        101070 ,
  324. 102906 ,    106400 ,    107868 ,    112400 ,
  325. 114820 ,    118690 ,    121750 ,    127600 ,
  326. 126905 ,    131300 ,    132906 ,    137340 ,
  327. 138906 ,    178490 ,    180948 ,    183850 ,
  328. 186200 ,    190200 ,    192220 ,    195090 ,
  329. 196967 ,    200590 ,    204370 ,    207200 ,
  330. 208981 ,    210000 ,    210000 ,    222000 ,
  331. 223000 ,    226025 ,    227000 ,    140120 ,
  332. 140908 ,    144240 ,    147000 ,    150400 ,
  333. 151960 ,    157250 ,    158925 ,    162500 ,
  334. 164930 ,    167260 ,    168934 ,    173040 ,
  335. 174970 ,    232038 ,    231036 ,    238029 ,
  336. 237048 ,    242000 ,    243000 ,    247000 ,
  337. 247000 ,    251000 ,    254000 ,    253000 ,
  338. 256000 ,    254000 ,    257000 ,
  339. \ a few extras for shortcuts - Me=CH3, Et=CH3CH2, Vi=CH2CH, Ph=C6H5
  340. 15035 ,        29062 ,        27046 ,        77106 ,
  341.  
  342. CREATE El$
  343. ," H HeLiBeB C N O F NeNaMgAlSiP S ClArK CaScTiV CrMnFeCoNiCuZnGaGeAsSeBrKrRbSrY ZrNbMoTcRuRhPdAgCdInSnSbTeI XeCsBaLaHfTaW ReOsIrPtAuHgTlPbBiPoAtRnFrRaAcCePrNdPmSmEuGdTbDyHoErTmYbLuThPaU NpPuAmCmBkCfEsFmMdNoLrMeEtViPh"
  344.  
  345. CREATE |StrBuf  10 ALLOT    \ A buffer for parsing the string
  346.  
  347. : NMatch ( addr$\$cnt\addr\cnt -- [#instring] or [0] )  \ find str at addr$
  348.    LOCALS| LStr AStr LStr2 AStr2 |                     \ in str at addr
  349.    LStr  LStr2 -    \ set up to match from start 
  350.             \ to LStr chars from end of Str1
  351.    0 TO  LStr         \ Now use LStr to count our position in the string Str1
  352.    0 DO 
  353.      AStr2 LStr2  AStr I + -TEXT    \ Loop through and check for match
  354.      NOT IF
  355.        I 1+ TO LStr    \ If found, set LStr to the char cnt.
  356.      THEN
  357.    LOOP LStr ; 
  358.  
  359. : fdInString  ( -- [#instr] or [0] )  \ look for valid element in El$
  360.    |StrBuf 1+ 2            \ pointer to string buffer and
  361.                 \ length of single elemment ( 2 chars)
  362.    El$ DUP 1+ SWAP C@ 1+    \ pointer to string holding all element names
  363.                 \ and the length
  364.    NMATCH ;            \ look for match    
  365.  
  366. VARIABLE >Formula    \ ptr to next char to parse
  367. VARIABLE >StrBuf    \ a temporary buffer to parse strings in
  368. VARIABLE >EndFormula    \ ptr to the end of the string
  369. VARIABLE ErrorFlag
  370. VARIABLE ParenCnt   \ counts the number of unresolved parentheses
  371. 0 ErrorFlag !
  372.  
  373. : InitPtr ( -- )             \ Initialize pointers for string transfer
  374.    |SRString >Formula !        \ Init. to beginning of String Gad. buffer
  375.    |StrBuf 1+ >StrBuf !        \ Init. to beginning of temp. str. buffer
  376.    |SRString DUP 0$Len + >EndFormula ! ;  \ init. ptr. to end of formula
  377.  
  378. : GetNextChar ( --char )    \ Get the next character in the formula
  379.     >Formula @ C@ ;
  380.  
  381. : AdvancePtr ( -- )        \ Increment pointer in formula to next Char
  382.     1 >Formula +! ;
  383.  
  384. : ResetBuf     ( -- )  \ fills strbuf with spaces and sets str length to 2
  385.    |StrBuf 2 OVER C!   \ set string length to 2 characters
  386.    1+ DUP 9 + SWAP DO 32 I C! LOOP  \ fill the rest of the buffer with blanks
  387.    |StrBuf 1+ >StrBuf !  ; \ set pointer to first char in (now empty) buffer
  388.  
  389. :  AtomWt@   ( #inStr -- Molewt )    \ Get the Atomic Wt. out of the table
  390.    1+ 2/ 1- 4* MoleWtTable + @ ;
  391.  
  392. : TestCap ( -- )        \ test if letter pointed to by >Formula is
  393.    >Formula @ C@ 65 90 RANGE    \ a capital letter
  394.    If >StrBuf @ C! Else        \ if so move to buffer
  395.    1 ErrorFlag !        \ otherwise set errorflag - invalid formula
  396.    THEN                \ Increment pointers 
  397.    1 DUP >Formula +! >StrBuf +! ;
  398.  
  399. : TestLow ( -- )        \ Test if letter pointed to by >Formula is
  400.    >Formula @ C@ 97 122 RANGE      \ lower case letter
  401.    IF >StrBuf @ C!        \ if so move to buffer
  402.    1 >Formula +!        \ and increment pointer & remove from stack
  403.    ELSE DROP THEN ;        \ or remove non lower case from stack
  404.  
  405. : NumCheck       ( n--flag )    \ check if n is an ASCII number
  406.    48 57 RANGE SWAP DROP ;
  407.  
  408. : TestNum ( --)                 \ If the string at the current >Formula
  409.    >Formula @            \ is a numeric string, then evaluate
  410.    LOCALS| EndNum |             \ and multiply top of stack by that amount
  411.    BEGIN EndNum C@ NumCheck While
  412.    EndNum 1+ TO EndNum REPEAT
  413.    EndNum >Formula @ - DUP
  414.    IF DUP >Formula @ SWAP $>NUMBER DROP
  415.    SWAP >Formula +! * ELSE DROP THEN ;
  416.  
  417. : NotDone?  ( -- flag)   \ flag=-1 if not done
  418.    ErrorFlag @  IF 0 ELSE >Formula @ >EndFormula @ - 0< THEN ;
  419.  
  420. : OpenParen ( -- 0 )
  421.       1 >Formula +!        \ Increment ptr to next char in formula
  422.       1 ParenCnt +!        \ Increment the parenthesis count
  423.       0 ;              \ start a new subgroup on top of stack
  424.  
  425. : CloseParen
  426.     ParenCnt @ 0 > IF    \    Make sure Parentheses match
  427.       1 >Formula +! -1 ParenCnt +!  \ advance ptr and dec. ParenCnt
  428.       NotDone? IF TestNum THEN    
  429.       +                 \ total Molecular wt.
  430.     ELSE  1 ERRORFLAG ! THEN ;     \ If parenCnt doesn't match then error
  431.  
  432. : GetEl ( -- )    \ get the next element in the string
  433.     ResetBuf
  434.     GetNextChar  >StrBuf @ C!     \ move char to scratchpad
  435.     1 DUP >Formula +! >StrBuf +! \ advance ptrs
  436.     NotDone?    
  437.     IF TestLow THEN              \ then check next char for lower case
  438.     FdinString DUP               \ find occurence of string in EL$
  439.     NOT IF 1  ErrorFlag ! THEN
  440.     AtomWt@                \ put molecular wt. on stack
  441.     NotDone?
  442.     IF TestNum THEN              \ check for number
  443.     + ;                          \ sum molecular wt.
  444.  
  445. : DisplayDecimal ( n-- )   \ prints as decimal to three places
  446.    RPort SWAP            \ ( RPort\n - )
  447.    DUP ABS            \ ( RPort\n\abs(n)-- )
  448.    <# # # # ASCII . HOLD #S SWAP SIGN #>    \ ( RPort\>Text\Cnt-- )
  449.    RPort 120 60 Move
  450.    RPort ClearEOL    \ Move to Position and Clear line
  451.    RPort 120 60 Move
  452.    Text Drop
  453.    CurrentWindow @ RefreshWindowFrame ;
  454.  
  455. : NDROP ( n -- )  \ drops n and the following n numbers off the stack
  456.     ?DUP IF 0 DO DROP LOOP THEN ;
  457.     
  458. : PrintMoleWt
  459.    0     \ Initialize Molecular Weight on stack
  460.    InitPtr
  461.    0 ParenCnt !    \ intialize variable to count parenthesis
  462.    BEGIN NotDone? WHILE 
  463.     GetNextChar
  464.     CASE
  465.        40  OF OpenParen ENDOF    \ Open parentheses encountered
  466.        41  OF CloseParen ENDOF    \ Closed parentheses encountered
  467.        65  90  RANGE.OF  GetEl  ENDOF \ Probably an element encountered
  468.        1 ErrorFlag !    \ if none of the above, then set error flag
  469.     ENDCASE
  470.    REPEAT    
  471.    ErrorFlag @ ParenCnt @ OR NOT IF    \ Check for errors or unmatched paren.
  472.      Displaydecimal            \ Display the molecular Weight
  473.    ELSE Depth NDROP
  474.      RPort 120 60 Move
  475.      RPort ClearEOL            \ Clear old text
  476.      RPort 120 60  Move
  477.      RPort 0" Invalid Input" DUP 0$Len Text DROP
  478.      CurrentWindow @ RefreshWindowFrame
  479.      0 ErrorFlag !
  480.    THEN ;
  481.  
  482. : SRGadEvent ( --gadID )  \ identifies the Gadget that was activated
  483.    ThisEvent  +eIaddress @
  484.           +ggGadgetID W@ ;
  485.  
  486. : CheckGadEvent
  487.     SRGadEvent    \ Find out which Gadget was activated
  488.     CASE
  489.        StringGadID    OF PrintMoleWt 0  EndOf \ User input Formula
  490.        InfoGadID      OF ReqInfo     0  EndOF
  491.        QuitGadID      OF 1              EndOf \ User hit Quit Gadget
  492.             \ Quit leaves a 1 thus ending the loop
  493.        0            \ If something else happened, ignore it
  494.     EndCase ;
  495.   
  496. : PrintWindowText ( -- ) \ Put text in window at start or during window resize
  497.     RPort 20 20 Move            \ locate pen for text
  498.     RPort 0" Molecular Weight Calculator" DUP 0$Len Text DROP
  499.     RPort 10 60 Move
  500.     RPort 0" Molecular Wt: " Dup 0$Len Text DROP ;
  501.  
  502. : RefreshCurrentWindow
  503.     CurrentWindow @ BeginRefresh
  504.     PrintWindowText
  505.     CurrentWindow @ True EndRefresh ;
  506.  
  507. : WaitForEvents (  -- ) 
  508.     Begin
  509.       SRStringGadget CurrentWindow @ 0    \ Setup Intuition ActiveGad.
  510.       ActivateGadget Drop            \ Activate String Gadget
  511.       WaitEvent                     \ Wait for user to respond
  512.       CASE
  513.          RefreshWindow OF RefreshCurrentWindow 0 Endof \ Refresh window text
  514.          GadgetUP  OF  CheckGadEvent  EndOF            \ A gadget was used
  515.          fCloseWindow OF 1 Endof                   \ User closed window
  516.          0
  517.       EndCase
  518.     Until ;
  519.  
  520. : Program  ( -- )
  521.    CorrectRunTimePtrs    \ Runtime linkage of ptrs.
  522.    MWWindow OpenWindow  \ Open the Window
  523.    CurrentWindow @ 0= IF Bye Then  \ If window doesn't open abort
  524.    PrintWindowText
  525.    WaitForEvents            \ Go into main program loop
  526.    CurrentWindow @ CloseWindow        \ Cleanup
  527.    ?Turnkey IF Bye Then ;
  528.