home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d514 / dkbtrace.lha / DKBTrace / dkbutsrc.lzh / lissajou.bas < prev    next >
BASIC Source File  |  1991-05-16  |  35KB  |  1,144 lines
  1. '*************************
  2. ' LISSAJOU.BAS
  3. '     This program displays spherical Lissajous figures
  4. '     and writes a DKB Ray Tracer data file.
  5. '     Program written by Dan Farmer using algorithms from Clifford Pickover.
  6. '     See Scientific American January 1991 and Omni February 1990 for
  7. '     excellent examples by Pickover.
  8. ' COMPILING: QB3.0 or greater
  9. '            Requires /e switch (on error).
  10. ' Revision:
  11. '              Add EXPONENT variable
  12. '              Bug Fix: CLOSE #1 when finished with it.
  13. '              In WRITE.HEADER, use correct variable for R1 reference.
  14. '
  15. ' 01/16/90 DMF Change most GOSUBS to SUBPROGRAMS and FUNCTIONS
  16. '              Specify type of most integers. (Default is single precision)
  17. '              Replace Shellsort with Quicksort
  18. '              Allow pausing of display, with option to write only the
  19. '              spheres displayed.
  20. '              Use Fractint color map or specified color(s) for DKB script.
  21. ' 03/08/91 DMF Drop FRACTINT color map option.  Doubt if anyone uses it.
  22. '              Make colors all color declarations and use the names in
  23. '              the objects, rather than the values.  Easier to edit when
  24. '              you have 100s of objects and several colors to change.
  25. ' 05/01/91 AAC Updated to DKB 2.11 by Aaron A. Collins
  26. '*************************
  27.  
  28. ' The following variables are public to all sub-programs:
  29. '-----------------------------
  30. COMMON SHARED S(2),F10$,FK10$,CU$,CD$,CR$,CL$,CSRL$,RTN$,ESC$,_
  31.                   BS$,TB$,HOM$,EN$,PGUP$,PGDN$,ALPHAS$,NUMBERS$,P$
  32. COMMON SHARED LABEL$(1),DATA$(1),TRUE%,FALSE%,GRMODE%
  33. COMMON SHARED MAXCOLORS%, BG%,WINXCENTER%,WINYCENTER%
  34. COMMON SHARED RADIUS, VIEWER
  35. '-----------------------------
  36.  
  37. FALSE% = 0 : TRUE% = NOT FALSE%
  38.  
  39. '========================== USER-DEFINED FUNCTIONS
  40. ' FUNCTION:                  DESCRIPTION:
  41. ' -----------                ------------
  42. ' FNLOOKKEY$(X)          --- Wait for a keystroke (called by SUB GETKEY)
  43. ' FUNUPPER$(X$)          --- Convert X$ to upper case
  44. ' FNISBLANK(X$)          --- Boolean : is string X$ NULL?
  45. ' FNCOMPARE(X$,Y$)       --- Compare 2 strings for partial match
  46. ' FNPAD$(X$,LENG)        --- Right-pad X$ with spaces to length LENG
  47. ' FNUNPAD$(X$)           --- Remove leading & trailing spaces from string X$
  48. ' FNFMT$ (A#)            --- Create a string from float A#
  49. ' FNFORMAT$(A#,FORM$)   ---  Create a formatted string from float A#
  50. ' FNZSCALE (RADIUS,Z,VIEWER) --- Adjust RADIUS to simulate perspective.
  51.  
  52.  
  53. '          ---  LOOK FOR A KEYSTROKE
  54. DEF FNLOOKKEY$(X)
  55.     STATIC A$
  56.     A$=INKEY$
  57.     IF LEN(A$)=2 THEN               ' FILTER UNUSED CONTROL CODES
  58.         IF ASC(RIGHT$(A$,1)) > 81 THEN A$=""
  59.     END IF
  60.     FNLOOKKEY$=A$
  61. END DEF
  62.  
  63. '          ---  CONVERT STRING TO UPPER CASE
  64. DEF FNUPPER$(X$)
  65.     STATIC A$,I%
  66.     IF LEN(X$) >0 THEN
  67.         FOR I% = 1 TO LEN(X$)
  68.             A$ = MID$(X$,I%,1)
  69.             IF A$ >= "a" AND A$ <= "z" THEN_
  70.                 MID$(X$,I%,1) = CHR$(ASC(A$)-32)
  71.         NEXT I%
  72.     END IF
  73.     FNUPPER$ = X$
  74. END DEF
  75.  
  76. '          ---  IS A STRING A BUNCH OF BLANKS?
  77. DEF FNISBLANK(X$) = (X$=SPACE$(LEN(X$)))
  78.  
  79. '          ---  COMPARE STRINGS FOR PARTIAL MATCH
  80. DEF FNCOMPARE(X$,Y$) = (LEFT$(X$,LEN(Y$))=Y$)
  81. '
  82. '          ---  LEFT-JUSTIFY, BLANK FILL A STRING
  83. DEF FNPAD$(X$,LENG) = LEFT$(X$+SPACE$(LENG),LENG)
  84.  
  85. '          ---  REMOVE LEADING AND TRAILING SPACES
  86. DEF FNUNPAD$(X$)
  87.     WHILE LEFT$(X$,1)=" "
  88.         X$=MID$(X$,2)
  89.     WEND
  90.     WHILE RIGHT$(X$,1)=" "
  91.         X$=LEFT$(X$,LEN(X$)-1)
  92.     WEND
  93.     FNUNPAD$=X$
  94. END DEF
  95.  
  96. '          ---  FORMAT A NUMERIC STRING, SIMPLE VERSION
  97. DEF FNFMT$ (A#)
  98.     FORM$="-####.######"
  99.     STATIC SIGN, S$, P, A$, DEC, W$, F$, WF$, FF$, PAD$, ADD$
  100.     SIGN = SGN(A#)
  101.     A# = ABS(A#)
  102. '          ---  SEPARATE WHOLE AND FRACTIONAL PARTS OF NUMBER
  103.     W$ = MID$(STR$(INT(A#)), 2)
  104.     IF W$ = "" THEN W$ = "0"
  105.     S$ = STR$(1 + A#)
  106.     P = INSTR(S$, ".")
  107.     IF P = 0 THEN
  108.         F$ = ""
  109.        ELSE F$ = MID$(S$, P + 1)
  110.     END IF
  111. '          ---  SEPARATE WHOLE AND FRACTION FORMAT STRINGS
  112.     DEC = INSTR(FORM$, ".")
  113.     IF DEC = 0 THEN
  114.         WF$ = FORM$: FF$ = ""
  115.        ELSE WF$ = LEFT$(FORM$, DEC - 1)
  116.         FF$ = MID$(FORM$, DEC + 1)
  117.     END IF
  118.     ADD$ = "": PAD$ = " "
  119. '          ---  ADD SIGN CHARACTER
  120.     IF LEFT$(WF$, 1) = "-" THEN
  121.         WF$ = MID$(WF$, 2)
  122.         IF SIGN = -1 THEN
  123.             ADD$ = ADD$ + "-"
  124.            ELSE ADD$ = ADD$ + " "
  125.         END IF
  126.     END IF
  127. '          ---  HANDLE NUMERIC OVERFLOW AND UNDERFLOW
  128.     IF LEN(W$) > LEN(WF$) THEN W$ = "%" + RIGHT$(W$, LEN(WF$) - 1)
  129.     IF LEN(F$) > LEN(FF$) THEN F$ = LEFT$(F$, LEN(FF$))
  130. '          ---  FORMAT THE NUMBER STRING
  131.     IF DEC > 0 THEN W$ = W$ + "." + F$ + STRING$(LEN(FF$) - LEN(F$), "0")
  132.     FNFMT$ = ADD$ + W$
  133. END DEF
  134.  
  135. '          ---  FORMAT A NUMERIC STRING, DELUXE VERSION, WITH FORMAT STRING
  136. DEF FNFORMAT$(A#,FORM$)
  137. '       A#:     A POSITIVE INTEGER OR FLOATING POINT NUMBER
  138. '       FORM$:  #####           RIGHT JUSTIFY, BLANK FILL
  139. '               0####           RIGHT JUSTIFY, ZERO FILL
  140. '               $####           ADD DOLLAR SIGN
  141. '               -####           ADD MINUS SIGN IF NEGATIVE
  142. '               ##.##           FORMAT DECIMAL POINT
  143.     STATIC SIGN,S$,P,A$,DEC,W$,F$,WF$,FF$,PAD$,ADD$
  144. '
  145.     SIGN=SGN(A#)
  146.     A#=ABS(A#)
  147. '          ---  SEPARATE WHOLE AND FRACTIONAL PARTS OF NUMBER
  148.     W$=MID$(STR$(INT(A#)),2)
  149.     S$=STR$(1+A#)
  150.     P=INSTR(S$,".")
  151.     IF P=0 THEN
  152.         F$=""
  153.        ELSE F$=MID$(S$,P+1)
  154.     END IF
  155. '          ---  SEPARATE WHOLE AND FRACTION FORMAT STRINGS
  156.     DEC=INSTR(FORM$,".")
  157.     IF DEC=0 THEN
  158.         WF$=FORM$ : FF$=""
  159.        ELSE WF$=LEFT$(FORM$,DEC-1)
  160.         FF$=MID$(FORM$,DEC+1)
  161.     END IF
  162. '          ---  DECIDE ON A PAD CHARACTER
  163.     IF LEFT$(WF$,1)="$" THEN
  164.         WF$=MID$(WF$,2)
  165.         ADD$="$"
  166.        ELSE ADD$=""
  167.     END IF
  168. '          ---  ADD SIGN CHARACTER
  169.     IF LEFT$(WF$,1)="-" THEN
  170.         WF$=MID$(WF$,2)
  171.         IF SIGN=-1 THEN
  172.             ADD$=ADD$+"-"
  173.            ELSE ADD$=ADD$+" "
  174.         END IF
  175.     END IF
  176.     IF LEFT$(WF$,1)="0" THEN
  177.         PAD$="0"
  178.        ELSE PAD$=" "
  179.     END IF
  180. '          ---  HANDLE NUMERIC OVERFLOW AND UNDERFLOW
  181.     IF LEN(W$)>LEN(WF$) THEN W$="%"+RIGHT$(W$,LEN(WF$)-1)
  182.     IF LEN(F$)>LEN(FF$) THEN F$=LEFT$(F$,LEN(FF$))
  183. '          ---  FORMAT THE NUMBER STRING
  184.     A$=STRING$(LEN(WF$)-LEN(W$),PAD$)+W$
  185.     IF DEC>0 THEN A$=A$+"."+F$+STRING$(LEN(FF$)-LEN(F$),"0")
  186.     FNFORMAT$=ADD$+A$
  187. END DEF
  188.  
  189.  
  190. '   ---
  191. '   --- Scale radius based upon distance from viewer
  192. '   ---
  193. DEF FNZSCALE (RADIUS,Z,VIEWER)
  194.     FNZSCALE = TAN(ATN(RADIUS / ABS(VIEWER - Z))) * VIEWER
  195. END DEF
  196.  
  197.  
  198. '------------------------------------------------------------------------------
  199.     ' DATA INPUT VARIABLES
  200. '          ---  CONTROL CODES
  201.     CU$=CHR$(0)+CHR$(72)                    ' UP ARROW
  202.     CD$=CHR$(0)+CHR$(80)                    ' DOWN ARROW
  203.     CR$=CHR$(0)+CHR$(77)                    ' RIGHT ARROW
  204.     CL$=CHR$(0)+CHR$(75)                    ' LEFT ARROW
  205.     CSRL$=CHR$(29)                          ' CURSOR LEFT
  206.     RTN$=CHR$(13)                           ' CARRIAGE RETURN
  207.     ESC$=CHR$(27)                           ' ESCAPE
  208.     BS$=CHR$(8)                             ' BACKSPACE
  209.     TB$=CHR$(9)                             ' TAB
  210.     BT$=CHR$(0)+CHR$(15)                    ' BACKTAB
  211.     F10$=CHR$(0)+CHR$(68)                   ' FUNCTION KEY 10
  212.     HOM$=CHR$(0)+CHR$(71)                   ' HOME
  213.     EN$=CHR$(0)+CHR$(79)                    ' END
  214.     PGUP$=CHR$(0)+CHR$(73)                  ' PAGE UP
  215.     PGDN$=CHR$(0)+CHR$(81)                  ' PAGE DOWN
  216.     ALPHAS$="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz "
  217.     NUMBERS$="0123456789"
  218.     P$=CHR$(250)                            ' DATA ENTRY FIELD PROMPT
  219.  
  220. '          ---  ENTRY SCREEN EDIT ARRAY
  221.     MAXFIELD%=11                         ' SIZE OF FIELD SPEC TABLE
  222.     PARMFIELDS% = 10                     ' NUMBER OF PARAMETER FIELD TO EDIT
  223.     DIM DATA$(MAXFIELD%): DIM LABEL$(MAXFIELD%)
  224.     DIM S(MAXFIELD%,3)                 ' DATA ENTRY FIELD SPECS
  225. '
  226. '
  227. '
  228. '          ---  DATA ENTRY/DISPLAY SCREEN TABLES
  229. '   S(Y,Z) :=
  230. '       Y := FIELD NUMBER
  231. '       Z := FIELD SPECS:
  232. '            1 := FIELD LENGTH
  233.  
  234. '            2 := FIELD TYPES AVAILABLE:
  235. '                 1 := NUMERIC OR ALPHA
  236. '                 2 := NUMERIC
  237. '                 3 := ALPHA
  238. '                 4 := SIGNED NUMERIC
  239. '                 5 := DOLLAR
  240.  
  241. '            3 := Y-COORDINATE
  242. '            4 := X-COORDINATE
  243. '
  244. '   Name      Fieldno      Len, Type, Row,  Col
  245. SCREENDATA:
  246.     R1FIELD     = 1  : DATA 3,  2,    04,   18
  247.     AFIELD      = 2  : DATA 4,  5,    05,   18
  248.     BFIELD      = 3  : DATA 4,  5,    06,   18
  249.     XXFIELD     = 4  : DATA 1,  2,    07,   18
  250.     YXFIELD     = 5  : DATA 1,  2,    08,   18
  251.     ZXFIELD     = 6  : DATA 1,  2,    09,   18
  252.     RADFIELD    = 7  : DATA 2,  2,    10,   18
  253.     QTYFIELD    = 8  : DATA 4,  2,    11,   18
  254.     AXISFIELD   = 9  : DATA 1,  3,    12,   18
  255.     ALGOFIELD   =10  : DATA 1,  2,    13,   18
  256.     ANGLEFIELD  =11  : DATA 4,  4,    24,   50
  257.  
  258.     RESTORE SCREENDATA
  259.     FOR I=1 TO MAXFIELD%
  260.         FOR J=0 TO 3
  261.             READ S(I,J)
  262.         NEXT J
  263.     NEXT I
  264.  
  265.     ' Read default values into DATA$ array
  266.     CALL SET.DATA.DEFAULTS (DATA$())
  267.  
  268.     ' Initialize labels for input fields
  269.     LABEL$(1) = "     R Value = "
  270.     LABEL$(2) = "     A Value = "
  271.     LABEL$(3) = "     B Value = "
  272.     LABEL$(4) = "  X-Exponent = "
  273.     LABEL$(5) = "  Y-Exponent = "
  274.     LABEL$(6) = "  Z-Exponent = "
  275.     LABEL$(7) = "  Sphere Rad = "
  276.     LABEL$(8) = "# of Spheres = "
  277.     LABEL$(9) = "View (x,y,z) = "
  278.     LABEL$(10)= "Method (1-5) = "
  279.     LABEL$(11)= "Angle to rotate: "
  280.  
  281. '------------------------------------------------------------------------------
  282. VIEWER = 300  ' FOR SCREEN PREVIEW ONLY (LOW VALUE="WIDE ANGLE" PERSPECTIVE)
  283. PAINTFLAG%=TRUE%
  284. BG% = 7                          ' SCREEN BACKGROUND COLOR (7 = gray)
  285.  
  286.  
  287. COLS% = 640 : ROWS% = 350 :XCENTER%=COLS%/2 : YCENTER%=ROWS%/2
  288. WINTOP%=16: WINBOTTOM%=ROWS%-50: WINLEFT%=XCENTER%/2+20: WINRIGHT%=COLS%-10
  289. WINXCENTER%=(WINRIGHT%-WINLEFT%)/2 : WINYCENTER%=(WINBOTTOM%-WINTOP%)/2
  290.  
  291. MAXCOLORS% = 15
  292. GRMODE% = 9
  293.  
  294. ON ERROR GOTO NOT.EGA          ' Trap errors before setting graphics mode
  295. SCREEN GRMODE%,1,0,0           ' Initialize graphics mode, page
  296. ON ERROR GOTO 0                ' Reset error trapping
  297.  
  298.  
  299. ' Create an GUI-looking window for the data entry fields.
  300. CALL GUIPANEL (8%,WINTOP%,WINLEFT%-8,WINBOTTOM%,2%)           ' RAISED PANEL
  301. CALL GUIPANEL (16%,190%,WINLEFT%-16,WINBOTTOM%-8,1%)          ' RAISED PANEL
  302.  
  303. ' COLORED DOTS "LOGO"
  304. CALL GUIBOLT( 65%, 240%, 10%, 1%)
  305. CALL GUIBOLT( 90%, 240%, 10%, 1%)
  306. CALL GUIBOLT(115%, 240%, 10%, 1%)
  307. CIRCLE ( 65,240),8,2 : PAINT ( 65,240),2
  308. CIRCLE ( 90,240),8,5 : PAINT ( 90,240),5
  309. CIRCLE (115,240),8,9 : PAINT (115,240),9
  310.  
  311. ' The sunken panel can be printed in from rows 15-20
  312. ' starting at column 4 for a length of 18 Characters.
  313. '                   123456789012345678
  314. LOCATE 15,4: PRINT "  3-D Lissajous  "
  315. LOCATE 16,4: PRINT "    Generator    "
  316. LOCATE 20,4: PRINT "  By Dan Farmer  "
  317.  
  318. CALL GUIBOLT(10%,8%,4%,1%)                       ' UPPER LEFT BOLT
  319. CALL GUIBOLT(COLS%-10%,8%,4%,1%)                 ' UPPER RIGHT BOLT
  320.  
  321. ' Create panel for messages at screen bottom
  322. CALL GUIPANEL(8%,WINBOTTOM%+8%,WINRIGHT%,ROWS%-8%,2%)
  323. CALL GUIBOLT(24%,ROWS%-24%,4%,1%)
  324. CALL GUIBOLT(WINRIGHT%-24%,ROWS%-24%,4%,1%)
  325.  
  326.  
  327. ' Create a GUI-looking window for the image display
  328. CALL GUIPANEL (WINLEFT%,WINTOP%,WINRIGHT%,WINBOTTOM%,-3%)      'SUNKEN PANEL
  329.  
  330. VIEW (WINLEFT%+8,WINTOP%+8)-(WINRIGHT%-8,WINBOTTOM%-8)
  331. COLOR 8,BG%                                        ' BRITE WHITE
  332.  
  333. 'FIRST.TIME%=TRUE%
  334. DO WHILE TRUE%                                     ' GO RIGHT TO DISPLAY
  335.   TOP:
  336.     GOSUB EDIT.PARMS
  337.     FIRST.TIME%=FALSE%                             ' NOW USER HAS CONTROL
  338.  
  339.     COUNTER%=0%
  340.     ON ERROR GOTO TOO.BIG
  341.     REDIM QUEUE(SPHERES%, 5) :  REDIM INDEX%(SPHERES%)
  342.     ON ERROR GOTO 0
  343.  
  344.     COLOR ,7                                        ' CHANGE BG COLOR
  345.     CALL DISPMSG("Generating...")
  346.  
  347.  
  348.     FOR T% = 1 TO SPHERES%
  349.         COUNTER%=COUNTER%+1%
  350.         INDEX%(COUNTER%) = COUNTER%                  ' INITIALIZE SORT ARRAY
  351.  
  352.         ON ALGO GOSUB ALGO.ONE, ALGO.TWO,ALGO.THREE,ALGO.FOUR,ALGO.FIVE
  353.  
  354.         CALL ORIENT.XYZ(X,Y,Z,AXIS%)
  355.  
  356.         ' Scale radius for display
  357.         SCALED.RADIUS=FNZSCALE(RADIUS,Z,VIEWER)
  358.  
  359.         '   Queue parameters for sorting for display (hidden line removal)
  360.         QUEUE(COUNTER%, 1) = X: QUEUE(COUNTER%, 2) = Y
  361.         QUEUE(COUNTER%, 3) = Z: QUEUE(COUNTER%, 4) = SCALED.RADIUS
  362.  
  363.     NEXT T%
  364.  
  365.     '   --- INDEX THE QUEUE ARRAY ON THE 4TH ELEMENT (Z)
  366.     CALL DISPMSG("Sorting Array...")
  367.     CALL QUICKSORT(QUEUE(),4,INDEX%())   ' SORTS THE INDEX, NOT THE QUEUE
  368.  
  369.     '   --- DRAW THE GRAPHICS IMAGE
  370.     CALL DISPMSG("Drawing...")
  371.     COLOR ,BG%                                    ' RESTORE BG COLOR
  372.     QTY%=SPHERES%
  373.     CALL DISPLAY(QUEUE(),INDEX%(),TRUE%,QTY%)
  374.     IF QTY% > 0 THEN SPHERES%=QTY%
  375.  
  376.     A$=""
  377.     DO WHILE A$ <> ESC$ AND A$ <> CHR$(13)
  378.         CALL DISPMSG("Finished: [D]=DKB Script  [R]=Rotate  [CR]=More  [Esc]=Quit")
  379.         A$="" : CALL KEYFLUSH : CALL GETKEY(A$) : CALL CLEARMSG
  380.         IF A$= ESC$ THEN EXIT DO
  381.         IF INSTR("Dd",A$) > 0 THEN GOSUB MAKE.DKB
  382.         IF INSTR("Rr",A$) > 0 THEN CALL ROTATE (QUEUE(),INDEX%(),SPHERES%)
  383.     LOOP
  384. LOOP
  385.  
  386.  
  387. ENDIT:
  388. SCREEN 0: WIDTH 80: CLS
  389. PRINT
  390. PRINT "LISSAJOU.EXE  Version 1.1"
  391. PRINT "Copyright 1991 by Dan Farmer."
  392. PRINT "All rights reserved."
  393. PRINT
  394. END
  395.  
  396. MAXALGO = 5          ' CHANGE IF ALGORITHM VARIATIONS ARE ADDED
  397. ALGO.ONE:
  398.     X = R1*(SIN(A*T%)*COS(B*T%) ^EXPONENT.X)
  399.     Y = R1*(SIN(A*T%)*SIN(B*T%) ^EXPONENT.Y)
  400.     Z = R1*(COS(A*T%)           ^EXPONENT.Z)
  401. RETURN
  402. ALGO.TWO:
  403.     X = R1*(SIN(A*T%)*COS(B*T%) ^EXPONENT.X)
  404.     Y = R1*(COS(A*T%)*COS(B*T%) ^EXPONENT.Y)
  405.     Z = R1*(SIN(A*T%)           ^EXPONENT.Z)
  406. RETURN
  407. ALGO.THREE:
  408.     X = R1*(SIN(A*T%)*SIN(B*T%) ^EXPONENT.X)
  409.     Y = R1*(SIN(A*T%)*COS(B*T%) ^EXPONENT.Y)
  410.     Z = R1*(SIN(A*T%)           ^EXPONENT.Z)
  411. RETURN
  412. ALGO.FOUR:       ' THIS ONE'S A KEEPER
  413.     PI = 3.1415
  414.     X = R1/4 *  (A*SIN(2*(T%-PI/13)) ^EXPONENT.X)
  415.     Y = R1/4 *  (-B*COS(T%)          ^EXPONENT.Y)
  416.     Z = R1   * ((SIN(A*T%))          ^EXPONENT.Z)
  417. RETURN
  418. ALGO.FIVE:       ' THIS ONE'S A *KEEPER*!
  419.     X = R1*(SIN(A*T%)*COS(A*T%) ^EXPONENT.X)
  420.     Y = R1*(SIN(B*T%)*SIN(B*T%) ^EXPONENT.Y)
  421.     Z = R1*(SIN(T%)             ^EXPONENT.Z)
  422. RETURN
  423.  
  424.  
  425. EDIT.PARMS:
  426.  
  427. '  --- DISPLAY THE DATA FROM THE FILE
  428.     SHOW.DATA:
  429.     CALL KEYFLUSH
  430.     FOR FIELDPTR%=1 TO PARMFIELDS%
  431.         LOCATE S(FIELDPTR%,2),3
  432.         COLOR 14                            ' YELLOW TEXT
  433.         PRINT LABEL$(FIELDPTR%)
  434.         COLOR 8                             ' GRAY TEXT
  435.         FILL$= "_"
  436.         CALL DISPFIELD (FIELDPTR%,DATA$(FIELDPTR%),FILL$)
  437.     NEXT FIELDPTR%
  438.     CALL DISPMSG("Press F10 to reset default values.")
  439.  
  440. '  --- DO THE EDITING OF THE FIELDS
  441.     FIELDPTR%=1
  442.     DONE% = FALSE%
  443.  
  444. IF FIRST.TIME% GOTO END.EDIT.LOOP   ' OK, OK, C-BEES, YOU HAVE THEM, TOO!
  445.  
  446.     WHILE NOT DONE%
  447.         EXIT$="":PEND$=""
  448.         PRINT
  449.         COLOR 15                              ' BRITE WHITE TEXT
  450.         CALL FIELDINPUT(FIELDPTR%,DATA$(FIELDPTR%),PEND$,EXIT$)
  451.         COLOR 8                               ' GRAY TEXT
  452.         CALL DISPFIELD (FIELDPTR%,DATA$(FIELDPTR%),FILL$)
  453.  
  454.         IF EXIT$ = CU$  THEN
  455.             FIELDPTR% = FIELDPTR% -1
  456.             IF FIELDPTR% < 1 THEN FIELDPTR% = 1        'WRAP-AROUND
  457.         ELSEIF EXIT$ = PGDN$ THEN DONE% = TRUE%
  458.         ELSEIF EXIT$ = ESC$ THEN
  459.             MSG$ = " Quit now "
  460.             A$="Y"
  461.             CALL VERIFY (MSG$,A$)
  462.             IF A$ <>"" THEN
  463.                 CLS
  464.                 GOTO ENDIT
  465.             END IF
  466.             CALL DISPMSG("Press F10 to reset default values.")
  467.         ELSEIF EXIT$ = F10$ THEN                 ' RESET TO DEFAULT VALUES
  468.             CALL SET.DATA.DEFAULTS(DATA$())
  469.             FIELDPTR%=1
  470.             GOTO SHOW.DATA
  471.         ELSE                                     ' ANY OTHER CASE
  472.             FIELDPTR%=FIELDPTR% + 1
  473.             IF FIELDPTR% >PARMFIELDS% THEN DONE% = TRUE%
  474.         END IF
  475.     WEND
  476.  
  477. END.EDIT.LOOP:
  478.  
  479. ' Assign the data input string values to their related variables
  480.     R1         = VAL(DATA$(1))
  481.     A          = VAL(DATA$(2))
  482.     B          = VAL(DATA$(3))
  483.     EXPONENT.X = VAL(DATA$(4))
  484.     EXPONENT.Y = VAL(DATA$(5))
  485.     EXPONENT.Z = VAL(DATA$(6))
  486.     RADIUS     = VAL(DATA$(7))
  487.     SPHERES%   = VAL(DATA$(8))
  488.     ALGO       = VAL(DATA$(10))
  489.     AXIS$= DATA$(9)
  490.     IF INSTR("Zz",AXIS$) > 0 THEN
  491.         AXIS% = 1
  492.     ELSEIF INSTR("Yy",AXIS$) > 0 THEN
  493.         AXIS% = 2
  494.     ELSEIF INSTR("Xx",AXIS$) > 0 THEN
  495.         AXIS% = 3
  496.     ELSE
  497.         AXIS% = 1                            ' DEFAULT Z-AXIS VIEW
  498.     END IF
  499.  
  500.  
  501.     ' Use default values if nothing entered
  502.     IF R1=0 THEN R1=100
  503.     IF A=0 THEN A=0.1
  504.     IF B=0 THEN B=0.25
  505.     IF EXPONENT.X = 0 THEN EXPONENT.X = 1
  506.     IF EXPONENT.Y = 0 THEN EXPONENT.Y = 1
  507.     IF EXPONENT.Z = 0 THEN EXPONENT.Z = 1
  508.     IF RADIUS=0 THEN RADIUS=5
  509.     IF SPHERES%=0 THEN SPHERES%=500
  510.     IF ALGO = 0 THEN ALGO = 1: IF ALGO > MAXALGO THEN ALGO=1
  511. RETURN
  512.  
  513. SUB SET.DATA.DEFAULTS (DATA$(1)) STATIC   ' takes a one-element array DATA$()
  514.     ' SET DEFAULT VALUES
  515.     DATA$(1) = "100"      ' R1
  516.     DATA$(2) = "0.10"     ' A
  517.     DATA$(3) = "0.25"     ' B
  518.     DATA$(4) = "1"        ' X-EXPONENT
  519.     DATA$(5) = "1"        ' Y-EXPONENT
  520.     DATA$(6) = "1"        ' Z-EXPONENT
  521.     DATA$(7) = " 8"       ' RADIUS
  522.     DATA$(8) = " 500"     ' QTY SPHERES
  523.     DATA$(9) = "Z"        ' AXIS
  524.     DATA$(10)= "1"        ' ALGORITHM
  525.     DATA$(11) = "  45"      ' ANGLE OF ROTATION
  526. END SUB
  527.  
  528.  
  529. '   --- Perform a simple 90 degrees rotation by swapping axis on
  530. '   --- the object.
  531. SUB ORIENT.XYZ (X,Y,Z,AXIS%) STATIC
  532. STATIC X1,Y1,Z1
  533.  
  534.     X1=X : Y1=Y: Z1=Z            ' Work variables
  535.  
  536.     IF AXIS% = 1 THEN            ' AXIS$="Z"
  537.     ELSEIF AXIS% = 2 THEN        ' AXIS$="Y"
  538.         X = Z1 : Z = X1          ' SWAP X & Z AXIS (ROTATE 90 ON Y AXIS)
  539.     ELSEIF AXIS% = 3 THEN          AXIS$="X"
  540.         Y = Z1 : Z = Y1          ' SWAP Y & Z AXIS (ROTATE 90 ON X AXIS)
  541.     END IF
  542. END SUB
  543.  
  544. '
  545. SUB ROTATE (QUEUE(2),INDEX%(1),SPHERES%) STATIC
  546.  
  547.     ' Get input from user (angle to rotate)
  548.     LOCATE S(11,2),33,1 : PRINT LABEL$(11);
  549.     CALL DISPFIELD(11%,DATA$(11),"-")
  550.     CALL FIELDINPUT(11%,DATA$(11),"","")
  551.     ANGLE = VAL(DATA$(11))
  552.  
  553.  
  554.     FOR I% = 1 TO SPHERES%
  555.         X = QUEUE(I%, 1) : Y = QUEUE(I%, 2)
  556.         Z = QUEUE(I%, 3)
  557.  
  558.         YY=Y*COS(ANGLE) - Z*SIN(ANGLE)
  559.         ZZ=Y*SIN(ANGLE) + Z*COS(ANGLE)
  560.         Y = YY
  561.         Z = ZZ
  562.  
  563.         ' Gotta rescale the radii now.
  564.         SCALED.RADIUS=FNZSCALE(RADIUS,Z,VIEWER)
  565.  
  566.         '   Queue parameters for sorting for display (hidden line removal)
  567.         QUEUE(I%, 1) = X: QUEUE(I%, 2) = Y
  568.         QUEUE(I%, 3) = Z: QUEUE(I%, 4) = SCALED.RADIUS
  569.     NEXT I%
  570.  
  571.     ' Sort the index (not the queue)
  572.     CALL QUICKSORT(QUEUE(),4,INDEX%())
  573.     QTY%=SPHERES%
  574.  
  575.     ' Show the new arrangement
  576.     CALL DISPLAY(QUEUE(),INDEX%(),TRUE%,QTY%)
  577. END SUB
  578.  
  579. '   ---
  580. '   --- Sort the circles on Z, from most distant to closest for simple
  581. '       "hidden line removal".  Farthest will be drawn first and overlapped
  582. '       by the nearer circles.
  583. '       Parms: ARRAY(2) = two element array of values needed sorting.
  584. '              ELEMENT% = key element of ARRAY() to use for the sort.
  585. '                         In this program the 4th element (z values) are
  586. '                         used as the sort key.
  587. '              INDEX%(1)= single dimension array of integers indexing ARRAY().
  588. '   ---
  589. SUB QUICKSORT (ARRAY(2),ELEMENT%,INDEX%(1)) STATIC
  590. STATIC LEFT%,RIGHT%,I%,J%,MEDIAN,STACK%,MAXDATA%
  591. DIM LSTACK%(50),RSTACK%(50)
  592.  
  593.     MAXDATA% = UBOUND(INDEX%)
  594.     STACK.HEIGHT% =1 : LSTACK%(1) =1: RSTACK%(1) = MAXDATA%
  595.     DO
  596.         LEFT% = LSTACK%(STACK.HEIGHT%)
  597.         RIGHT% = RSTACK%(STACK.HEIGHT%)
  598.         STACK.HEIGHT% = STACK.HEIGHT%-1
  599.         DO
  600.             I% = LEFT% : J% = RIGHT%
  601.             MEDIAN = ARRAY(INDEX%((LEFT%+RIGHT%)\2), ELEMENT%)
  602.             DO
  603.                 WHILE ARRAY(INDEX%(I%),ELEMENT%) < MEDIAN
  604.                     I% = I% +1
  605.                 WEND
  606.  
  607.                 WHILE MEDIAN < ARRAY(INDEX%(J%),ELEMENT%)
  608.                     J% = J% -1
  609.                 WEND
  610.  
  611.                 IF I% <= J% THEN
  612.                     SWAP INDEX%(I%), INDEX%(J%)
  613.                     I% = I% +1 : J% = J% -1
  614.                 END IF
  615.  
  616.             LOOP WHILE I% <= J%
  617.  
  618.             IF I% < RIGHT% THEN
  619.                 STACK.HEIGHT% = STACK.HEIGHT% +1
  620.                 LSTACK%(STACK.HEIGHT%) = I%
  621.                 RSTACK%(STACK.HEIGHT%) = RIGHT%
  622.             END IF
  623.  
  624.             RIGHT% = J%
  625.         LOOP WHILE LEFT% < RIGHT%
  626.  
  627.     LOOP WHILE STACK.HEIGHT% <> 0
  628. END SUB
  629.  
  630.  
  631. '   ---
  632. '   --- Here is where we draw the image, using sorted index of Z elements
  633. '       to draw most distant circles first.
  634. '   ---
  635. SUB DISPLAY (QUEUE(2),INDEX%(1),PAINTFLAG%, QTY.DRAWN%) STATIC
  636. STATIC I%
  637.     CALL DISPMSG("Press any key to pause drawing")
  638.     CLS 1                                    ' CLEAR GRAPHICS WINDOW
  639.     FOR I% = 1 TO UBOUND (INDEX%)            ' DISPLAY IN INDEXED ORDER
  640.  
  641.         X = QUEUE(INDEX%(I%), 1) : Y = QUEUE(INDEX%(I%), 2)
  642.         Z = QUEUE(INDEX%(I%), 3) : R = QUEUE(INDEX%(I%), 4)
  643.  
  644.         KOLOR% = I% MOD MAXCOLORS% +1
  645.  
  646.         XPOINT = WINXCENTER% + X: YPOINT = WINYCENTER% + Y
  647.  
  648.         CIRCLE (XPOINT, YPOINT), R+1, 8        ' GRAY OUTLINE
  649.         CIRCLE (XPOINT, YPOINT), R,   KOLOR%   ' BOUNDS FOR PAINT
  650.  
  651.         IF PAINTFLAG% = TRUE% THEN
  652.             PAINT (XPOINT, YPOINT), KOLOR%
  653.         END IF
  654.  
  655.         EXIT$=INKEY$
  656.         IF EXIT$ <> "" THEN
  657.             CALL VERIFY ("Paused: Stop at" + STR$(I%) + " spheres",EXIT$)
  658.             IF EXIT$<>"" THEN QTY.DRAWN%=I%: EXIT SUB
  659.             CALL CLEARMSG
  660.         END IF
  661.  
  662.     NEXT I%
  663. END SUB
  664.  
  665. ' --- Write the DKB script
  666. '
  667. MAKE.DKB:
  668.     SCREEN GRMODE%,1,1,1                  ' SWITCH SCREEN PAGES
  669.     COLOR ,7                              ' LIGHT GRAY (WHITE) BACKGROUND
  670.     CLS
  671.  
  672.     '   --- Get Output filename
  673.   GET.OUTPUT.FILE:
  674.     CALL DISPMSG ("Press <ENTER> to cancel")
  675.     LOCATE 2,4
  676.     PRINT "Name of output file: [.DAT] "
  677.     LOCATE 2,32 :LINE INPUT OUTFILE$
  678.     IF OUTFILE$="" THEN GOTO END.MAKE.DKB
  679.     IF INSTR(OUTFILE$,".") = 0 THEN OUTFILE$=OUTFILE$ + ".DAT"
  680.  
  681.   GETCOLORS:
  682.         '   --- GET COLOR NAMES FROM USER
  683.         LOCATE 4,4: PRINT "How many colors would you like to use? ";
  684.         LINE INPUT KOLOR.COUNT$ : KOLOR.COUNT = VAL(KOLOR.COUNT$)
  685.         IF KOLOR.COUNT=0 THEN GOTO END.MAKE.DKB
  686.  
  687.         GET.COLORS:
  688.         REDIM KOLOR$(KOLOR.COUNT)
  689.         REDIM COLORNAME$(KOLOR.COUNT)
  690.         LOCATE 5,4
  691.         PRINT "Enter either standard DKB RGB values or a DECLARED color name."
  692.         LOCATE 6,4: PRINT "(Leave a color blank to exit early)"
  693.         ACTUAL.COLOR.COUNT=0
  694.         ALINE% = 7
  695.         FOR I% = 1 TO KOLOR.COUNT
  696.             ALINE%=ALINE% + 1
  697.             IF ALINE% = 24 THEN
  698.                 FOR J% = 6 TO 23
  699.                     LOCATE J%,1 : PRINT SPACE$(80);   ' CLEAR THE LINE
  700.                 NEXT J%
  701.                 ALINE% = 8
  702.             END IF
  703.             LOCATE ALINE%,8: PRINT "Color #"; I%; " = COLOR ";
  704.             LINE INPUT KOLOR$(I%)
  705.             IF KOLOR$(I%)="" THEN
  706.                 GOTO EXIT.GET.COLORS            ' LEAVE THE LOOP
  707.             END IF
  708.             ACTUAL.COLOR.COUNT=ACTUAL.COLOR.COUNT+1
  709.         NEXT I%
  710.         EXIT.GET.COLORS:
  711.             KOLOR.COUNT=ACTUAL.COLOR.COUNT
  712.  
  713.         IF KOLOR.COUNT = 0 THEN GOTO END.MAKE.DKB
  714.  
  715.     '   --- Begin to write the data file
  716.     OPEN OUTFILE$ FOR OUTPUT AS #1
  717.  
  718.     '   --- Write the VIEW, LIGHT SOURCE, and info data
  719.     GOSUB WRITE.HEADER
  720.  
  721.     PRINT #1,"COMPOSITE"                         ' FOR EASY POSITIONING
  722.  
  723.     '   --- Write one SPHERE at a time
  724.     LOW.X = VAL(X$) : HI.X = VAL(X$)
  725.     LOW.Y = VAL(Y$) : HI.Y = VAL(Y$)
  726.     LOW.Z = VAL(Z$) : HI.Z = VAL(Z$)
  727.     FOR I%=1 TO SPHERES%
  728.         X$ = FNFMT$(QUEUE(INDEX%(I%), 1))
  729.         Y$ = FNFMT$(QUEUE(INDEX%(I%), 2))
  730.         Z$ = FNFMT$(QUEUE(INDEX%(I%), 3))
  731.  
  732.         '   --- TRACK MINIMUM AND MAXIMUM VECTORS
  733.         THIS.X = VAL(X$) : THIS.Y = VAL(Y$) : THIS.Z = VAL(Z$)
  734.         IF THIS.X < LOW.X THEN LOW.X = THIS.X
  735.         IF THIS.Y < LOW.Y THEN LOW.Y = THIS.Y
  736.         IF THIS.Z < LOW.Z THEN LOW.Z = THIS.Z
  737.         IF THIS.X > HI.X THEN HI.X = THIS.X
  738.         IF THIS.Y > HI.Y THEN HI.Y = THIS.Y
  739.         IF THIS.Z > HI.Z THEN HI.Z = THIS.Z
  740.  
  741.         RADIUS$=FNFMT$(RADIUS)
  742. '       AKOLOR$=KOLOR$(I% MOD KOLOR.COUNT)         'COLOR VALUES
  743.         COLORALIAS$=COLORNAME$(I% MOD KOLOR.COUNT+1) 'COLORNAME TO WRITE TO OBJECT
  744.         GOSUB WRITE.DATA
  745.     NEXT I%
  746.  
  747.     '   --- Write the end of the COMPOSITE
  748.     PRINT #1, ""
  749.     PRINT #1, "END_COMPOSITE"
  750.     PRINT #1, "{"
  751.     PRINT #1, "  Parameters used for this generation:"
  752.     PRINT #1, "    R1 =";R1; "   A =";A;"   B =";B
  753.     PRINT #1, "    X-Exponent =";EXPONENT.X
  754.     PRINT #1, "    Y-Exponent =";EXPONENT.Y
  755.     PRINT #1, "    Z-Exponent =";EXPONENT.Z
  756.     PRINT #1, "    Sphere Radius =";RADIUS
  757.     PRINT #1, "    Number of Spheres generated: ";SPHERES%
  758.     PRINT #1, "    Axis = "; AXIS$
  759.     PRINT #1, "    Algorithm = #"; ALGO
  760.     PRINT #1, ""
  761.     PRINT #1, "    Minimum X = ";LOW.X ; " Maximum X = ";HI.X
  762.     PRINT #1, "    Minimum Y = ";LOW.Y ; " Maximum Y = ";HI.Y
  763.     PRINT #1, "    Minimum Z = ";LOW.Z ; " Maximum Z = ";HI.Z
  764.     PRINT #1, ""
  765.     PRINT #1, "    (Min/Max XYZs with RADIUS figured in:)"
  766.     PRINT #1, "    Leftmost Point = ";LOW.X-RADIUS ; " Rightmost Point = ";HI.X+RADIUS
  767.     PRINT #1, "      Lowest Point = ";LOW.Y-RADIUS ; "   Highest Point = ";HI.Y+RADIUS
  768.     PRINT #1, "     Nearest Point = ";LOW.Z-RADIUS ; "  Farthest Point = ";HI.Z+RADIUS
  769.     PRINT #1, "}"
  770.     PRINT #1, "{ *** End of ";OUTFILE$;" *** }"
  771.     CLOSE #1
  772.  
  773.     CALL DISPMSG("DKB Script written as "+OUTFILE$+".  Press any key to resume." )
  774.     CALL KEYFLUSH
  775.     CALL GETKEY("")
  776.     CALL CLEARMSG
  777.  
  778.   END.MAKE.DKB:
  779.     CLOSE
  780.     CLS 0
  781.     SCREEN GRMODE%,1,0,0                              ' SWAP SCREEN PAGE
  782.     COLOR ,BG%                                ' RESTORE BACKGROUND COLOR
  783. RETURN
  784.  
  785.  
  786. WRITE.HEADER:
  787.     PRINT #1, "{ Lissajous figure DKB datafile "; OUTFILE$
  788.     PRINT #1, "  Generated on ";DATE$;" at ";TIME$
  789.     PRINT #1, "}"
  790.     PRINT #1, ""
  791.     PRINT #1, "INCLUDE ";CHR$(34);"shapes.dat" ;CHR$(34)
  792.     PRINT #1, "INCLUDE ";CHR$(34);"colors.dat" ;CHR$(34)
  793.     PRINT #1, "INCLUDE ";CHR$(34);"textures.dat" ;CHR$(34)
  794.     PRINT #1, ""
  795.     PRINT #1, "DECLARE Atexture = TEXTURE"
  796.     PRINT #1, "    Shiny"
  797.     PRINT #1, "    {Put further texture mods as needed here}"
  798.     PRINT #1, "END_TEXTURE"
  799.     PRINT #1, ""
  800.     PRINT #1, "VIEW_POINT"
  801.     PRINT #1, "   LOCATION <0.0  0.0  -250.0> {Modify as needed}"
  802.     PRINT #1, "   DIRECTION <0.0 0.0  1.0>"
  803.     PRINT #1, "   UP  <0.0  1.0  0.0>"
  804.     PRINT #1, "   RIGHT <1.33333 0.0 0.0>"
  805.     PRINT #1, "   LOOK_AT <0.0 0.0 0.0>"
  806.     PRINT #1, "END_VIEW_POINT"
  807.     PRINT #1, ""
  808.     PRINT #1, "{ Basic Light source }"
  809.     PRINT #1, "OBJECT"
  810.     PRINT #1, "   SPHERE <0.0  0.0  0.0>  2.0 END_SPHERE"
  811.     PRINT #1, "   TRANSLATE <100.0  100.0  -500.0>"
  812.     PRINT #1, "   TEXTURE"
  813.     PRINT #1, "      COLOUR White"
  814.     PRINT #1, "      AMBIENT 1.0"
  815.     PRINT #1, "      DIFFUSE 0.0"
  816.     PRINT #1, "   END_TEXTURE"
  817.     PRINT #1, "   LIGHT_SOURCE"
  818.     PRINT #1, "   COLOUR White"
  819.     PRINT #1, "END_OBJECT"
  820.     PRINT #1, ""
  821.     PRINT #1, "{ Put all colors into declarations for ease of changing }"
  822.     FOR K=1 TO KOLOR.COUNT
  823.         COLORNAME$(K)="Color" + FNUNPAD$(STR$(K))
  824.         PRINT #1, "DECLARE " + COLORNAME$(K) + " = COLOR " + KOLOR$(K)
  825.     NEXT K
  826.     PRINT #1, ""
  827.     FOR K=1 TO KOLOR.COUNT
  828.         COLORNAME$(K)="Color" + FNUNPAD$(STR$(K))
  829.         PRINT #1, "DECLARE " + COLORNAME$(K) + "_Tex = TEXTURE Atexture COLOR " + COLORNAME$(K) + " END_TEXTURE"
  830.     NEXT K
  831.     PRINT #1, ""
  832. RETURN
  833.  
  834. WRITE.DATA:
  835.     PRINT #1,"    OBJECT"
  836.     PRINT #1,"        SPHERE <";X$;" ";Y$;" ";Z$;"> " RADIUS$;" END_SPHERE
  837.     PRINT #1,"        TEXTURE " + COLORALIAS$ + "_Tex END_TEXTURE"
  838.     PRINT #1,"        COLOR " + COLORALIAS$
  839.     PRINT #1,"    END_OBJECT"
  840. RETURN
  841.  
  842. TOO.BIG:
  843.     LOCATE 24,1 : PRINT CHR$(7);
  844.     PRINT "OOPS! Unable to allocate memory for that many spheres.";
  845.     CALL DISPMSG("Press any key to continue")
  846.     WHILE INKEY$="":WEND
  847.     LOCATE 24,1: PRINT SPACE$(80);
  848.     CALL CLEARMSG
  849.     RESUME TOP                     ' TRY AGAIN
  850. '          ***                          ***
  851. '          ***  DATA ENTRY SUBROUTINES  ***
  852. '          ***                          ***
  853. '
  854. '          ***  INPUT A STRING  ***
  855. SUB FIELDINPUT(FIELDNO%,ST$,PEND$,EXIT$) STATIC
  856. '               ST$    := INPUT FIELD
  857. '               PEND$  := PENDING KEYSTROKE
  858.     IF PEND$="" THEN
  859.         A$=""
  860.         CALL KEYFLUSH
  861.        ELSE A$=PEND$
  862.         PEND$=""
  863.     END IF
  864.     FI1:                                        ' HOME CURSOR IN FIELD
  865.     CALL DISPFIELD(FIELDNO%,ST$+STRING$(S(FIELDNO%,0)-LEN(ST$),P$),FILL$)
  866.     CALL HOMECURSOR(FIELDNO%)
  867.     ST=0
  868.     IF A$<>"" THEN GOTO FI4                 ' PROCESS PENDING KEYSTROKE
  869.     PRESS=FALSE%
  870.     LOCATE ,,1                              ' TURN ON CURSOR
  871.     CALL GETKEY(A$)
  872.     IF ASC(A$)>=32 THEN ST$=""
  873.     GOTO FI1
  874.     FI2:
  875.     LOCATE ,,1                              ' TURN ON CURSOR
  876.     CALL GETKEY(A$)
  877.     FI4:                                        ' FILTER CONTROL KEYS
  878.     IF ASC(A$)<32 THEN GOTO CONTROLINPUT    ' CHECK CHR, PRINT IT, UPDATE
  879.     FI5:
  880.     IF ST=S(FIELDNO%,0) THEN
  881.         CALL KEYFLUSH
  882.        ELSE GOSUB CHECKCHAR
  883.         IF ERRMSG$<>"" THEN
  884.             GOTO FI4
  885.            ELSE PRINT A$;
  886.             ST=ST+1
  887.             PRESS=TRUE%
  888.         END IF
  889.     END IF
  890.     GOTO FI2
  891. '          ---  HANDLE CONTROL AND FUNCTION KEYS
  892.     CONTROLINPUT:
  893.     IF A$=CR$ THEN                          ' CURSOR RIGHT
  894.         IF ST<S(FIELDNO%,0) THEN
  895.             A$=CHR$(SCREEN(CSRLIN,POS(0)))
  896.             IF A$<>P$ THEN
  897.                 PRINT A$;
  898.                 ST=ST+1
  899.             END IF
  900.         END IF
  901.        ELSEIF A$=CL$ THEN                          ' CURSOR LEFT
  902.         IF ST>0 THEN
  903.             PRINT CSRL$;
  904.             ST=ST-1
  905.         END IF
  906.        ELSEIF A$=BS$ THEN                          ' DESTRUCTIVE BACKSPACE
  907.         IF ST>0 AND (ST=S(FIELDNO%,0) _
  908.            OR CHR$(SCREEN(CSRLIN,POS(0)))=P$) THEN
  909.             PRINT CSRL$;P$;CSRL$;
  910.             ST=ST-1
  911.             PRESS=TRUE%
  912.         END IF
  913.        ELSEIF A$=ESC$ THEN                         ' ERASE FIELD
  914.            EXIT$=A$
  915.            EXIT SUB
  916.         'ST$="" : ST=0 : A$=""
  917.         'GOTO FI1
  918.     END IF
  919. '          ---  VALIDATE FIELD END EXIT
  920.     IF PRESS THEN
  921.         GOSUB CHECKWORD
  922.         IF ERRMSG$<>"" THEN GOTO FI4
  923.     END IF
  924.     EXIT$=A$
  925.     LOCATE ,,0
  926.     EXIT SUB
  927. '          ***  CHARACTER CHECKER  ***
  928. CHECKCHAR:
  929.     ERRMSG$=""
  930.     ON S(FIELDNO%,1) GOSUB_
  931.                  CHECKCHARALPHAORNUM,_
  932.                  CHECKCHARNUM,_
  933.                  CHECKCHARALPHA,_
  934.                  CHECKCHARSIGNED,_
  935.                  CHECKCHARBUX
  936.     IF ERRMSG$<>"" THEN CALL DISPERR(ERRMSG$,A$)
  937.     RETURN
  938.     CHECKCHARALPHAORNUM:                        ' 1 := NUMERIC OR ALPHA
  939.     IF ST$<>"" THEN
  940.         IF VAL(ST$)>0 OR LEFT$(ST$,1)="0" THEN
  941.             GOTO CHECKCHARNUM       ' FIELD ALREADY NUMERIC
  942.            ELSE GOTO CHECKCHARALPHA     ' FIELD ALREADY ALPHA
  943.         END IF
  944.         ELSEIF INSTR(NUMBERS$,A$)=0 AND INSTR(ALPHAS$,A$)=0 THEN
  945.         ERRMSG$="Please press <A to Z> or <0 to 9>"
  946.     END IF
  947.     RETURN
  948.  
  949.     CHECKCHARNUM:                               ' 2 := NUMERIC
  950.     IF INSTR(NUMBERS$,A$)=0 THEN_
  951.         ERRMSG$="Please press <0 to 9>"
  952.     RETURN
  953.  
  954.     CHECKCHARAN:                                ' 3 := ALPHA/NUMERIC
  955.     IF A$="?" THEN_
  956.         ERRMSG$="Please press <A to Z> or <0 to 9>"
  957.     RETURN
  958.  
  959.     CHECKCHARBUX:                               ' 4 := DOLLARS
  960.     IF INSTR(NUMBERS$,A$)=0 AND A$<>"." THEN _
  961.         IF NOT(A$="#" AND ST=0) THEN _
  962.             ERRMSG$="Please press <0 to 9> or a period"
  963.     RETURN
  964.  
  965.     CHECKCHARALPHA:                             ' 6 := ALPHA
  966.     IF INSTR(ALPHAS$,A$)=0 THEN _
  967.         ERRMSG$="Please press <A to Z>"
  968.     RETURN
  969.  
  970.     CHECKCHARSIGNED:                            ' 9 := SIGNED NUMERIC
  971.     IF INSTR("+-",A$)=0 OR ST>1 THEN _
  972.         GOTO CHECKCHARNUM
  973.     RETURN
  974. '
  975. '          ***  WORD CHECKER  ***
  976. '          ---  ENTER WORD
  977. CHECKWORD:
  978.     CALL HOMECURSOR(FIELDNO%)
  979.     ST$="" : ST=0
  980.     FOR I=1 TO S(FIELDNO%,0)                 ' READ FIELD FROM SCREEN
  981.         AA$=CHR$(SCREEN(CSRLIN,POS(0)))
  982.         IF AA$<>P$ THEN
  983.             IF S(FIELDNO%,1)<>7 OR INSTR(NUMBERS$,AA$)<>0 THEN
  984.                 ST$=ST$+AA$
  985.                 ST=ST+1
  986.             END IF
  987.             PRINT AA$;
  988.            ELSE I=I+999
  989.         END IF
  990.     NEXT I
  991.     ST=0
  992.     CALL HOMECURSOR(FIELDNO%)
  993. '          ---  VALIDATE WORD
  994.     ERRMSG$=""
  995.     IF ST$<>"" THEN_
  996.         ON S(FIELDNO%,1) GOSUB_
  997.                        CHECKWORDTYPE,_
  998.                        CHECKWORDTYPE,_
  999.                        CHECKWORDTYPE,_
  1000.                        CHECKWORDTYPE,_
  1001.                        CHECKPRICETYPE
  1002.     IF ERRMSG$<>"" THEN CALL DISPERR(ERRMSG$,A$)
  1003.     RETURN
  1004.     CHECKPRICETYPE:
  1005.       '  ST$=FNFORMAT$(VAL(ST$),RIGHT$("##########.##",S(FIELDNO%,0)))
  1006.         RETURN
  1007.     CHECKWORDTYPE:
  1008.         RETURN
  1009. END SUB
  1010.  
  1011.  
  1012.  
  1013. '          ***                     ***
  1014. '          ***  MISC. SUBROUTINES  ***
  1015. '          ***                     ***
  1016. '
  1017. '          ---  HOME CURSOR IN FIELD
  1018. SUB HOMECURSOR(FIELDNO%) STATIC
  1019.     LOCATE S(FIELDNO%,2),S(FIELDNO%,3)
  1020. END SUB
  1021. '
  1022. '          ---   CLEAR DATA ENTRY FIELD
  1023. SUB CLEARFIELD(FIELDNO%) STATIC
  1024.     CALL HOMECURSOR(FIELDNO%)
  1025.     PRINT SPACE$(S(FIELDNO%,0));
  1026. END SUB
  1027. '
  1028. '          ---   DISPLAY DATA ENTRY FIELD
  1029. SUB DISPFIELD(FIELDNO%,A$,FILL$) STATIC
  1030.     CALL CLEARFIELD(FIELDNO%)
  1031.     CALL HOMECURSOR(FIELDNO%)
  1032.     IF NOT FNISBLANK(A$) THEN               ' DON'T BOTHER WITH BLANK
  1033.         PRINT A$;
  1034.     ELSE PRINT STRING$(LEN(A$),FILL$)
  1035.     END IF
  1036. END SUB
  1037. '          ---  REMEMBER CURSOR POSITION
  1038. SUB SAVECURS(V,H) STATIC
  1039.     V=CSRLIN
  1040.     H=POS(0)
  1041. END SUB
  1042. '
  1043. '          ---  FLUSH KEYBOARD BUFFER
  1044. SUB KEYFLUSH STATIC
  1045.     WHILE INKEY$<>""
  1046.     WEND
  1047. END SUB
  1048. '
  1049. '          ---  GET KEYSTROKE
  1050. SUB GETKEY(A$) STATIC
  1051.     A$=""
  1052.     WHILE A$=""
  1053.         A$=FNLOOKKEY$(0)
  1054.      WEND
  1055. END SUB
  1056. '
  1057. '          ---  DISPLAY A MESSAGE
  1058. SUB DISPMSG(MSG$) STATIC
  1059. STATIC LEFT%,MAXLEN%
  1060.     MAXLEN%=70%
  1061.     LEFT%=(80-MAXLEN%)/2
  1062.     MSG$=FNUNPAD$(MSG$)
  1063.     IF LEN(MSG$) > MAXLEN% THEN MSG$=LEFT$(MSG$,MAXLEN%)  ' TRUNCATE IF NEEDED
  1064.  
  1065.     CALL SAVECURS(V,H)                      ' SAVE CURSOR POSITION
  1066.     LOCATE 24,LEFT%
  1067.     PRINT SPC(MAXLEN%);
  1068.     LOCATE 24,40-LEN(MSG$)/2
  1069.     PRINT MSG$;
  1070.     LOCATE V,H,1
  1071. END SUB
  1072. '
  1073. '          ---  CLEAR MESSAGE AREA
  1074. SUB CLEARMSG STATIC
  1075.         CALL DISPMSG("")
  1076. END SUB
  1077. '          ---  DISPLAY ERROR MESSAGE
  1078. SUB DISPERR(MSG$,A$) STATIC
  1079.             '  MSG$ := MESSAGE TO DISPLAY
  1080.             '  A$   := CARRYOVER KEYSTROKE
  1081.         CALL DISPMSG(MSG$)
  1082.     PRINT BELL$;
  1083.     CALL KEYFLUSH
  1084.     CALL GETKEY(A$)
  1085.     CALL CLEARMSG
  1086. END SUB
  1087. '
  1088. '          ---  ASK OPERATOR A YES/NO QUESTION, RESET EXIT$ IF NO
  1089. SUB VERIFY(MSG$,EXIT$) STATIC
  1090.         CALL DISPERR(MSG$+" (Y or N)?",B$)
  1091.         IF B$<>"y" AND B$<>"Y" THEN EXIT$=""
  1092. END SUB
  1093.  
  1094. SUB GUIPANEL (WLEFT%,WTOP%,WRIGHT%,WBOTTOM%,TOGGLE%) STATIC
  1095. STATIC DEPTH, I,INSET
  1096. ' Parameter TOGGLE := -1 FOR INSET, 1 FOR OUTSET
  1097. '                     -2 FOR INSET 2 DEEP, 3 TO OUTSET 3 DEEP, ETC.
  1098. DEPTH%=ABS(TOGGLE%)
  1099. INSET%=(TOGGLE% < 0)
  1100.  
  1101. FOR I% = 0 TO DEPTH% -1
  1102.     IF INSET% THEN                                 ' INSET PANEL
  1103.         LINE (WLEFT%+I%,  WTOP%+I%)    - (WLEFT%+I%,WBOTTOM%-I%),  8  ' LEFT SIDE
  1104.         LINE (WLEFT%+I%,  WTOP%+I%)    - (WRIGHT%-I%,WTOP%+I%),    8  ' TOP LINE
  1105.         LINE (WLEFT%+I%,  WBOTTOM%-I%) - (WRIGHT%-I%,WBOTTOM%-I%),15  ' BOTTOM LINE
  1106.         LINE (WRIGHT%-I%, WTOP%+I%)    - (WRIGHT%-I%,WBOTTOM%-I%),15  ' RIGHT SIDE
  1107.     ELSE                                             ' OUTSET PANEL
  1108.         LINE (WLEFT%+I%,  WTOP%+I%)    - (WLEFT%+I%,WBOTTOM%-I%) ,15  ' LEFT SIDE
  1109.         LINE (WLEFT%+I%,  WTOP%+I%)    - (WRIGHT%-I%,WTOP%+I%)   ,15  ' TOP LINE
  1110.         LINE (WLEFT%+I%,  WBOTTOM%-I%) - (WRIGHT%-I%,WBOTTOM%-I%), 8  ' BOTTOM LINE
  1111.         LINE (WRIGHT%-I%, WTOP%+I%)    - (WRIGHT%-I%,WBOTTOM%-I%), 8  ' RIGHT SIDE
  1112.     END IF
  1113. NEXT I%
  1114. END SUB
  1115.  
  1116. SUB GUIBOLT(X%,Y%,R%,TOGGLE%) STATIC
  1117. STATIC DEPTH, I,INSET
  1118. ' Parameter TOGGLE := -1 FOR INSET, 1 FOR OUTSET
  1119. '                     -2 FOR INSET 2 DEEP, 3 TO OUTSET 3 DEEP, ETC.
  1120. DEPTH%=ABS(TOGGLE%)
  1121. INSET%=(TOGGLE% < 0)
  1122. PI#=4*ATN(1!)
  1123.  
  1124. FOR I% = 0 TO DEPTH% -1
  1125.     IF INSET% THEN                                 ' INSET BOLT
  1126.         CIRCLE (X%,Y%),R%-I%, 15, 0.5*PI#, 1.5*PI#
  1127.         CIRCLE (X%,Y%),R%-I%,  8, 1.5*PI#, 0
  1128.     ELSE
  1129.         CIRCLE (X%,Y%),R%-I%,  8, 0.5*PI#, 1.5*PI#
  1130.         CIRCLE (X%,Y%),R%-I%, 15, 1.5*PI#, 0
  1131.     END IF
  1132. NEXT I%
  1133. END SUB
  1134.  
  1135. NOT.EGA:       ' ERROR TRAP
  1136.     SCREEN 0 : WIDTH 80
  1137.     PRINT ""
  1138.     PRINT "Sorry, but Lissajou requires EGA minimum to run."
  1139.     PRINT ""
  1140.     END
  1141. RETURN
  1142. ' --- END OF LISSAJUO.BAS
  1143.  
  1144.