home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / gwbasic / designer / designer.bas < prev    next >
Encoding:
BASIC Source File  |  1994-05-24  |  25.8 KB  |  602 lines
  1. 10000 REM **************************************************************
  2. 10010 REM **                  THE DESIGNER V1.0                       **
  3. 10020 REM **           Copyright 1983, by Jan B. Young                **
  4. 10030 REM **************************************************************
  5. 10035 REM changed for QBasic by jb/'94
  6. 10040 KEY OFF: ON ERROR GOTO 14930: CAPS = 1: PURGE = 0
  7. 10050 OPEN "DESIGNER.DRV" FOR INPUT AS #1
  8. 10060 INPUT #1, DRIVE$
  9. 10070 CLOSE #1
  10. 10080 KEY(1) ON: ON KEY(1) GOSUB 10440
  11. 10090 KEY(2) ON: ON KEY(2) GOSUB 10450
  12. 10100 KEY(3) ON: ON KEY(3) GOSUB 10460
  13. 10110 KEY(4) ON: ON KEY(4) GOSUB 10470
  14. 10120 KEY(5) ON: ON KEY(5) GOSUB 10480
  15. 10130 KEY(6) ON: ON KEY(6) GOSUB 10490
  16. 10140 KEY(7) ON: ON KEY(7) GOSUB 10500
  17. 10150 KEY(8) ON: ON KEY(8) GOSUB 10510
  18. 10160 KEY(9) ON: ON KEY(9) GOSUB 10520
  19. 10170 KEY(10) ON: ON KEY(10) GOSUB 10530
  20. 10180 REM **************************************************************
  21. 10190 REM **                    Mainline                              **
  22. 10200 REM **************************************************************
  23. 10210 SKIP$ = "INS": NOW$ = "INS"
  24. 10220 REC = 1: GOSUB 15490
  25. 10230 IF SKIP$ = "INS" THEN GOSUB 10540
  26. 10240 IF SKIP$ = "NEW" THEN GOSUB 11000
  27. 10250 IF SKIP$ = "TXT" THEN GOSUB 12170
  28. 10260 IF SKIP$ = "SCL" THEN GOSUB 12680
  29. 10270 IF SKIP$ = "SSP" THEN GOSUB 13470
  30. 10280 IF SKIP$ = "RSP" THEN GOSUB 14330
  31. 10290 IF SKIP$ = "ANI" THEN GOSUB 13870
  32. 10300 IF SKIP$ = "RSC" THEN GOSUB 14610
  33. 10310 IF SKIP$ = "SSC" THEN GOSUB 14740
  34. 10320 IF SKIP$ <> "" GOTO 10230
  35. 10330 SCREEN 0, 0, 0: WIDTH 80: END
  36. 10340 REC = 5: GOSUB 15490
  37. 10350 GOSUB 15220: IF TYPE$ <> "C" THEN GOTO 10350
  38. 10360 IF X$ < "A" OR X$ > "D" THEN GOTO 10350
  39. 10370 OPEN "DESIGNER.DRV" FOR OUTPUT AS #1
  40. 10380 WRITE #1, X$: CLOSE #1: DRIVE$ = X$: GOTO 10080
  41. 10390 REC = 19: GOSUB 15490: GOSUB 15220: SCREEN 0, 0, 0: END' no color/graph card
  42. 10400 REC = 24: GOSUB 15490: GOSUB 15220: SCREEN 0, 0, 0: END' no printer
  43. 10410 REM *************************************************************
  44. 10420 REM **                   Key Settings                          **
  45. 10430 REM *************************************************************
  46. 10440 SKIP$ = "NEW": RETURN
  47. 10450 SKIP$ = "SCL": RETURN
  48. 10460 SKIP$ = "SSP": RETURN
  49. 10470 SKIP$ = "SSC": RETURN
  50. 10480 SKIP$ = "RSP": RETURN
  51. 10490 SKIP$ = "RSC": RETURN
  52. 10500 SKIP$ = "TXT": RETURN
  53. 10510 SKIP$ = "ANI": RETURN
  54. 10520 SKIP$ = "INS": RETURN
  55. 10530 SKIP$ = "": RETURN
  56. 10540 REM *************************************************************
  57. 10550 REM **  F9     INS = Instructions / Command List               **
  58. 10560 REM *************************************************************
  59. 10570 NOW$ = "INS"
  60. 10580 REC = 28: GOSUB 15490
  61. 10590 LOCATE 21, 10: PRINT DRIVE$ + "."
  62. 10600 GOSUB 15220: IF SKIP$ <> "INS" THEN RETURN
  63. 10610 IF ASC(X$) = 8 THEN GOTO 10600
  64. 10620 IF TYPE$ <> "C" THEN GOTO 10600
  65. 10630 LOCATE 8, 62: PRINT USING "\         \"; "          " + X$: Y$ = X$
  66. 10640 GOSUB 15220: IF SKIP$ <> "INS" THEN RETURN
  67. 10650 IF TYPE$ <> "C" THEN GOTO 10640
  68. 10660 IF ASC(X$) <> 8 THEN GOTO 10690
  69. 10670 LOCATE 8, 62: PRINT USING "\          \"; "            "
  70. 10680 GOTO 10600
  71. 10690 LOCATE 8, 73: PRINT X$: Y$ = Y$ + X$
  72. 10700 GOSUB 15220: IF SKIP$ <> "INS" THEN RETURN
  73. 10710 IF TYPE$ <> "C" THEN GOTO 10700
  74. 10720 IF ASC(X$) <> 8 THEN GOTO 10750
  75. 10730 LOCATE 8, 73: PRINT " "
  76. 10740 GOTO 10640
  77. 10750 LOCATE 8, 74: PRINT X$: X$ = Y$ + X$
  78. 10760 REC = 0
  79. 10770 IF X$ = "INS" THEN GOTO 10580
  80. 10780 IF X$ = "GEN" THEN REC = 46
  81. 10790 IF X$ = "NEW" THEN REC = 140
  82. 10800 IF X$ = "SCL" THEN REC = 189
  83. 10810 IF X$ = "RSP" THEN REC = 271
  84. 10820 IF X$ = "SSP" THEN REC = 301
  85. 10830 IF X$ = "RSC" THEN REC = 328
  86. 10840 IF X$ = "SSC" THEN REC = 352
  87. 10850 IF X$ = "ANI" THEN REC = 363
  88. 10860 IF X$ = "TXT" THEN REC = 389
  89. 10870 IF X$ = "CRD" THEN REC = 435
  90. 10880 IF X$ = "DRV" THEN GOTO 10920
  91. 10890 IF REC <> 0 THEN GOTO 10910
  92. 10900 LOCATE 8, 62: PRINT "Try Again:   ": GOTO 10600
  93. 10910 GOSUB 15490: RETURN
  94. 10920 OPEN "DESIGNER.DRV" FOR OUTPUT AS #1
  95. 10930 IF DRIVE$ = "A" THEN GOTO 10980
  96. 10940 IF DRIVE$ = "D" THEN DRIVE$ = "A"
  97. 10950 IF DRIVE$ = "C" THEN DRIVE$ = "D"
  98. 10960 IF DRIVE$ = "B" THEN DRIVE$ = "C"
  99. 10970 GOTO 10990
  100. 10980 DRIVE$ = "B"
  101. 10990 WRITE #1, DRIVE$: CLOSE #1: RETURN
  102. 11000 REM *************************************************************
  103. 11010 REM **   F1      NEW = New Figure or Screen                    **
  104. 11020 REM *************************************************************
  105. 11030 NOW$ = "NEW": REC = 471: GOSUB 15490
  106. 11040 GOSUB 15220: IF SKIP$ <> "NEW" THEN RETURN
  107. 11050 IF TYPE$ <> "C" THEN 11040
  108. 11060 IF X$ = "H" THEN GOTO 11090
  109. 11070 IF X$ = "M" THEN GOTO 11100
  110. 11080 GOTO 11040
  111. 11090 RES1 = 2: BAK = 0: GOTO 11230
  112. 11100 REC = 474: RES1 = 1
  113. 11110 GOSUB 15490
  114. 11120 GOSUB 15220: IF SKIP$ <> "NEW" THEN RETURN
  115. 11130 IF X$ = "1" THEN GOTO 11160
  116. 11140 IF X$ = "0" THEN GOTO 11170
  117. 11150 GOTO 11120
  118. 11160 REC = 478: PAL = 1: GOTO 11180
  119. 11170 REC = 489: PAL = 0
  120. 11180 GOSUB 15490
  121. 11190 GOSUB 15220: IF SKIP$ <> "NEW" THEN RETURN
  122. 11200 IF TYPE$ <> "C" THEN 11190
  123. 11210 BAK = ASC(X$) - 65
  124. 11220 IF BAK < 0 OR BAK > 15 THEN GOTO 11190
  125. 11230 RES = RES1: CLS : CLR = 1: GRID = 0: SCREEN RES: LAST = 0
  126. 11240 IF RES = 1 THEN COLOR BAK, PAL
  127. 11250 REM ********* intermediate entry point ***********
  128. 11260 HLOC = 160 * RES: VLOC = 100
  129. 11270 PSET (HLOC, VLOC)
  130. 11280 IF LAST = 1 THEN PRESET (HLOC, VLOC + 1), CLR
  131. 11290 IF LAST = 2 THEN PRESET (HLOC - 1, VLOC), CLR
  132. 11300 IF LAST = 3 THEN PRESET (HLOC, VLOC - 1), CLR
  133. 11310 IF LAST = 4 THEN PRESET (HLOC + 1, VLOC), CLR
  134. 11320 PURGE = 1: GOSUB 15220: IF SKIP$ <> "NEW" THEN RETURN
  135. 11330 IF TYPE$ = "G" THEN GOTO 11530
  136. 11340 IF X$ = "G" THEN GOTO 11380
  137. 11350 IF X$ >= "A" AND X$ <= "Z" THEN HOLD$ = X$
  138. 11360 IF X$ >= "0" AND X$ <= "9" THEN GOTO 11580
  139. 11370 GOTO 11320
  140. 11380 IF GRID = 1 THEN GOTO 11460
  141. 11390 FOR I = 9 TO 200 STEP 10
  142. 11400 LINE (0, I)-(4 * RES, I), 1: LINE (315 * RES, I)-(320 * RES, I), 1
  143. 11410 NEXT I
  144. 11420 FOR I = 9 TO 320 * RES STEP 10
  145. 11430 LINE (I, 0)-(I, 4), 1: LINE (I, 195)-(I, 200), 1
  146. 11440 NEXT I
  147. 11450 GRID = 1: GOTO 11320
  148. 11460 FOR I = 9 TO 200 STEP 10
  149. 11470 LINE (0, I)-(4 * RES, I), 0: LINE (315 * RES, I)-(320 * RES, I), 0
  150. 11480 NEXT I
  151. 11490 FOR I = 9 TO 320 * RES STEP 10
  152. 11500 LINE (I, 0)-(I, 4), 0: LINE (I, 195)-(I, 200), 0
  153. 11510 NEXT I
  154. 11520 GRID = 0: GOTO 11320
  155. 11530 IF X$ = "H" THEN GOTO 12140
  156. 11540 IF X$ = "M" THEN GOTO 12120
  157. 11550 IF X$ = "P" THEN GOTO 12100
  158. 11560 IF X$ = "K" THEN GOTO 12080
  159. 11570 GOTO 11320
  160. 11580 IF HOLD$ <> "P" THEN GOTO 11630
  161. 11590 IF X$ < "0" OR X$ > "3" OR (RES = 2 AND X$ > "1") THEN GOTO 11630
  162. 11600 PRESET (HLOC, VLOC)
  163. 11610 PAINT (HLOC, VLOC), (ASC(X$) - 48), CLR
  164. 11620 PRESET (HLOC, VLOC), CLR
  165. 11630 IF HOLD$ = "F" AND X$ = "0" THEN CLR = 0
  166. 11640 IF HOLD$ = "F" AND X$ = "1" THEN CLR = 1
  167. 11650 IF HOLD$ = "F" AND X$ = "2" THEN CLR = 2
  168. 11660 IF HOLD$ = "F" AND X$ = "3" THEN CLR = 3
  169. 11670 IF HOLD$ = "F" THEN HOLD$ = ""
  170. 11680 IF HOLD$ <> "D" OR X$ <> "1" THEN GOTO 11710
  171. 11690 VSET = VLOC: HSET = HLOC: HOLD$ = ""
  172. 11700 GOTO 11320
  173. 11710 IF HOLD$ <> "D" OR X$ <> "2" THEN GOTO 11740
  174. 11720 LINE (HSET, VSET)-(HLOC, VLOC), CLR: HOLD$ = ""
  175. 11730 GOTO 11320
  176. 11740 IF HOLD$ <> "C" OR X$ <> "1" THEN GOTO 11770
  177. 11750 VSET = VLOC: HSET = HLOC: HOLD$ = ""
  178. 11760 GOTO 11320
  179. 11770 IF HOLD$ <> "C" OR X$ <> "2" THEN GOTO 11830
  180. 11780 IF RES = 2 THEN RAD = SQR(5.7 * (VSET - VLOC) ^ 2 + (HSET - HLOC) ^ 2)
  181. 11790 IF RES = 1 THEN RAD = SQR(1.45 * (VSET - VLOC) ^ 2 + (HSET - HLOC) ^ 2)
  182. 11800 CIRCLE (HSET, VSET), RAD, CLR
  183. 11810 HOLD$ = ""
  184. 11820 GOTO 11320
  185. 11830 IF HOLD$ <> "A" OR X$ <> "1" THEN GOTO 11860
  186. 11840 VSET = VLOC: HSET = HLOC: HOLD$ = ""
  187. 11850 GOTO 11320
  188. 11860 IF HOLD$ <> "A" OR X$ <> "2" THEN GOTO 11890
  189. 11870 VSET2 = VLOC: HSET2 = HLOC: HOLD$ = ""
  190. 11880 GOTO 11320
  191. 11890 IF HOLD$ <> "A" OR X$ <> "3" THEN GOTO 11320
  192. 11900 IF RES = 2 THEN GOTO 11990
  193. 11910 RAD = SQR(1.4 * (VSET - VSET2) ^ 2 + (HSET - HSET2) ^ 2)
  194. 11920 ANG1 = ATN(1.25 * (VSET - VSET2) / (HSET2 - HSET))
  195. 11930 ANG2 = ATN(1.25 * (VSET - VLOC) / (HLOC - HSET))
  196. 11940 IF HSET > HLOC THEN ANG2 = 3.14 + ANG2
  197. 11950 IF HLOC > HSET AND VLOC > VSET THEN ANG2 = 6.28 + ANG2
  198. 11960 IF HSET > HSET2 THEN ANG1 = 3.14 + ANG1
  199. 11970 IF HSET2 > HSET AND VSET2 > VSET THEN ANG1 = 6.28 + ANG1
  200. 11980 GOTO 12060
  201. 11990 RAD = SQR(5.7 * (VSET - VSET2) ^ 2 + (HSET - HSET2) ^ 2)
  202. 12000 ANG1 = ATN(2.5 * (VSET - VSET2) / (HSET2 - HSET))
  203. 12010 ANG2 = ATN(2.5 * (VSET - VLOC) / (HLOC - HSET))
  204. 12020 IF HSET > HLOC THEN ANG2 = 3.14 + ANG2
  205. 12030 IF HLOC > HSET AND VLOC > VSET THEN ANG2 = 6.28 + ANG2
  206. 12040 IF HSET > HSET2 THEN ANG1 = 3.14 + ANG1
  207. 12050 IF HSET2 > HSET AND VSET2 > VSET THEN ANG1 = 6.28 + ANG1
  208. 12060 CIRCLE (HSET, VSET), RAD, CLR, ANG1, ANG2
  209. 12070 HOLD$ = "": GOTO 11320
  210. 12080 IF HLOC > 0 THEN HLOC = HLOC - 1
  211. 12090 LAST = 4: GOTO 11270
  212. 12100 IF VLOC < 199 THEN VLOC = VLOC + 1
  213. 12110 LAST = 3: GOTO 11270
  214. 12120 IF HLOC < RES * 320 - 1 THEN HLOC = HLOC + 1
  215. 12130 LAST = 2: GOTO 11270
  216. 12140 IF VLOC > 0 THEN VLOC = VLOC - 1
  217. 12150 LAST = 1: GOTO 11270
  218. 12160 RETURN
  219. 12170 REM *************************************************************
  220. 12180 REM **  F7      TXT = Add Text Characters                      **
  221. 12190 REM *************************************************************
  222. 12200 IF RES <> 0 THEN GOTO 12220
  223. 12210 NOW$ = "TXT": REC = 500: GOSUB 15490: GOSUB 15220: RETURN
  224. 12220 NOW$ = "TXT": CAPS = 0: START = 1: MSG = 0: GOSUB 15920
  225. 12230 PRESET (HLOC, VLOC), CLR
  226. 12240 OPEN "TEXTCHAR" FOR RANDOM AS #1 LEN = 12: GOTO 12250
  227. 12250 FIELD #1, 12 AS BUFFER$
  228. 12260 DIM HOLDC(2), HOLDB(2 * (3 - RES))
  229. 12270 PURGE = 1: GOSUB 15220: IF SKIP$ = "NEW" THEN GOTO 12650
  230. 12280 IF SKIP$ <> "TXT" THEN GOTO 12640
  231. 12290 IF TYPE$ = "C" AND ASC(X$) > 31 AND ASC(X$) < 126 THEN GOTO 12500
  232. 12300 IF TYPE$ = "C" THEN GOTO 12270
  233. 12310 IF X$ <> "H" AND X$ <> "M" AND X$ <> "P" AND X$ <> "K" THEN GOTO 12270
  234. 12320 IF START = 1 THEN GOTO 12270
  235. 12330 PUT (HLOC, VLOC), HOLDB, PSET
  236. 12340 IF X$ = "H" THEN GOTO 12390
  237. 12350 IF X$ = "M" THEN GOTO 12410
  238. 12360 IF X$ = "P" THEN GOTO 12430
  239. 12370 IF X$ = "K" THEN GOTO 12450
  240. 12380 GOTO 12270
  241. 12390 IF VLOC > 0 THEN VLOC = VLOC - 1
  242. 12400 GOTO 12470
  243. 12410 IF HLOC < RES * 320 - 7 THEN HLOC = HLOC + 1
  244. 12420 GOTO 12470
  245. 12430 IF VLOC < 192 THEN VLOC = VLOC + 1
  246. 12440 GOTO 12470
  247. 12450 IF HLOC > 0 THEN HLOC = HLOC - 1
  248. 12460 GOTO 12470
  249. 12470 GET (HLOC, VLOC)-(HLOC + 6, VLOC + 7), HOLDB
  250. 12480 PUT (HLOC, VLOC), HOLDC, PSET
  251. 12490 GOTO 12270
  252. 12500 IF ASC(X$) > 32 THEN GOTO 12550
  253. 12510 FOR I = HLOC TO HLOC + 3 * RES: FOR J = VLOC TO VLOC + 7
  254. 12520 PSET (I, J), 0
  255. 12530 NEXT J, I
  256. 12540 GOTO 12270
  257. 12550 GET #1, ASC(X$) - 32 + (2 - RES) * 93
  258. 12560 OUTPUT$ = BUFFER$
  259. 12570 FOR J = 0 TO 2
  260. 12580 HOLDC(J) = CVS(MID$(OUTPUT$, 4 * J + 1, 4))
  261. 12590 NEXT J
  262. 12600 HLOC = RES * 160 - 3: VLOC = 97: START = 0
  263. 12610 GET (HLOC, VLOC)-(HLOC + 6, VLOC + 7), HOLDB
  264. 12620 PUT (HLOC, VLOC), HOLDC, PSET
  265. 12630 GOTO 12270
  266. 12640 ERASE HOLDC, HOLDB: CLOSE #1: CAPS = 1: RETURN
  267. 12650 ERASE HOLDC, HOLDB: CLOSE #1: CAPS = 1: SKIP$ = "NEW": NOW$ = "NEW"
  268. 12660 MSG = 0: GOSUB 15920: GOTO 11260
  269. 12670 REC = 503: GOSUB 15490: GOSUB 15220: RETURN
  270. 12680 REM *************************************************************
  271. 12690 REM **  F2        SCL = Scale a Drawing     Color 0,14         **
  272. 12700 REM *************************************************************
  273. 12710 IF RES <> 0 THEN GOTO 12730
  274. 12720 NOW$ = "SCL": REC = 510: GOSUB 15490: GOSUB 15220: RETURN
  275. 12730 NOW$ = "SCL": MSG = 0: GOSUB 15920
  276. 12740 SPEED = 0: PRESET (HLOC, VLOC), CLR
  277. 12750 GOSUB 15220: IF SKIP$ = "NEW" THEN GOTO 13460
  278. 12760 IF SKIP$ <> "SCL" THEN RETURN
  279. 12770 IF TYPE$ = "G" THEN GOTO 12750
  280. 12780 IF X$ > "0" AND X$ <= "9" AND HOLD$ <> " " THEN SPEED = 1 - (ASC(X$) - 48) / 25
  281. 12790 IF X$ = "E" THEN HOLD$ = "E"
  282. 12800 IF X$ = "C" THEN HOLD$ = "C"
  283. 12810 IF SPEED = 0 OR HOLD$ = " " THEN GOTO 12750
  284. 12820 IF HOLD$ = "E" THEN GOTO 13140
  285. 12830 REM ***** contract - left side *****
  286. 12840 FOR I = 160 * RES TO 0 STEP -1
  287. 12850 IF SKIP$ <> "SCL" THEN RETURN
  288. 12860 PSET (I, 0), 1: PSET (I, 199), 1
  289. 12870 K = 160 * RES - (160 * RES - I) / SPEED
  290. 12880 FOR J = 100 TO 1 STEP -1
  291. 12890 L = 100 - (100 - J) / SPEED
  292. 12900 IF K >= 0 AND L >= 0 THEN PSET (I, J), POINT(K, L) ELSE PSET (I, J), 0
  293. 12910 NEXT J
  294. 12920 FOR J = 101 TO 198
  295. 12930 L = 100 + (J - 100) / SPEED
  296. 12940 IF K >= 0 AND L <= 199 THEN PSET (I, J), POINT(K, L) ELSE PSET (I, J), 0
  297. 12950 NEXT J
  298. 12960 PSET (I, 0), 0: PSET (I, 199), 0
  299. 12970 NEXT I
  300. 12980 REM *****  contract - right side *****
  301. 12990 FOR I = 160 * RES + 1 TO 320 * RES - 1
  302. 13000 IF SKIP$ <> "SCL" THEN RETURN
  303. 13010 PSET (I, 0), 1: PSET (I, 199), 1
  304. 13020 K = 160 * RES + (I - 160 * RES) / SPEED
  305. 13030 FOR J = 100 TO 1 STEP -1
  306. 13040 L = 100 - (100 - J) / SPEED
  307. 13050 IF K <= 320 * RES - 1 AND L >= 0 THEN PSET (I, J), POINT(K, L) ELSE PSET (I, J), 0
  308. 13060 NEXT J
  309. 13070 FOR J = 101 TO 198
  310. 13080 L = 100 + (J - 100) / SPEED
  311. 13090 IF K <= 320 * RES - 1 AND L <= 199 THEN PSET (I, J), POINT(K, L) ELSE PSET (I, J), 0
  312. 13100 NEXT J
  313. 13110 PSET (I, 0), 0: PSET (I, 199), 0
  314. 13120 NEXT I
  315. 13130 SPEED = 0: HOLD$ = " ": MSG = 0: GOSUB 15920: GOTO 12750
  316. 13140 REM ***** expand - left side *****
  317. 13150 SPEED = 2 - SPEED
  318. 13160 FOR I = 0 TO 160 * RES
  319. 13170 IF SKIP$ <> "SCL" THEN RETURN
  320. 13180 PSET (I, 0), 1: PSET (I, 199), 1
  321. 13190 K = 160 * RES - ((160 * RES - I) / SPEED)
  322. 13200 FOR J = 1 TO 100
  323. 13210 L = 100 - ((100 - J) / SPEED)
  324. 13220 PSET (I, J), POINT(K, L)
  325. 13230 NEXT J
  326. 13240 FOR J = 198 TO 101 STEP -1
  327. 13250 L = 100 - ((100 - J) / SPEED)
  328. 13260 PSET (I, J), POINT(K, L)
  329. 13270 NEXT J
  330. 13280 PSET (I, 0), 0: PSET (I, 199), 0
  331. 13290 NEXT I
  332. 13300 REM *****  expand - right side *****
  333. 13310 FOR I = 320 * RES - 1 TO 160 * RES + 1 STEP -1
  334. 13320 IF SKIP$ <> "SCL" THEN RETURN
  335. 13330 PSET (I, 0), 1: PSET (I, 199), 1
  336. 13340 K = (I - 160 * RES) / SPEED + 160 * RES
  337. 13350 FOR J = 1 TO 100
  338. 13360 L = 100 - (100 - J) / SPEED
  339. 13370 PSET (I, J), POINT(K, L)
  340. 13380 NEXT J
  341. 13390 FOR J = 198 TO 101 STEP -1
  342. 13400 L = (J - 100) / SPEED + 100
  343. 13410 PSET (I, J), POINT(K, L)
  344. 13420 NEXT J
  345. 13430 PSET (I, 0), 0: PSET (I, 199), 0
  346. 13440 NEXT I
  347. 13450 SPEED = 0: HOLD$ = " ": MSG = 0: GOSUB 15920: GOTO 12750
  348. 13460 SKIP$ = "NEW": NOW$ = "NEW": MSG = 0: GOSUB 15920: GOTO 11260
  349. 13470 REM *************************************************************
  350. 13480 REM **  F3       SSP = Store a Sprite                          **
  351. 13490 REM *************************************************************
  352. 13500 IF RES <> 0 THEN GOTO 13520
  353. 13510 NOW$ = "SSP": REC = 513: GOSUB 15490: GOSUB 15220: RETURN
  354. 13520 RES1 = RES: NOW$ = "SSP"
  355. 13530 L = 1: R = 320 * RES1: T = 1: B = 200: SPEED = 1
  356. 13540 LINE (L, T)-(R, B), 1, B
  357. 13550 PURGE = 1: GOSUB 15220: IF SKIP$ <> "SSP" THEN RETURN
  358. 13560 IF TYPE$ = "G" THEN GOTO 13780
  359. 13570 IF X$ < "1" OR X$ > "9" THEN GOTO 13600
  360. 13580 SPEED = ASC(X$) - 48
  361. 13590 GOTO 13550
  362. 13600 IF X$ <> "G" THEN GOTO 13550
  363. 13610 R = R - 1: L = L + 1: T = T + 1: B = B - 1
  364. 13620 I = 4 + INT(((R - L + 1) * (3 - RES1) + 7) / 8) * (B - T + 1)
  365. 13630 I = INT((3 + I) / 4) + 1: J = FRE(" ")
  366. 13640 IF J > ((I * 4) + 500) THEN GOTO 13660
  367. 13650 MSG = 1001: GOSUB 15920: GOTO 13550
  368. 13660 DIM HOLD(I)
  369. 13670 GET (L, T)-(R, B), HOLD
  370. 13680 REC = 516: VLOC = 6: GOSUB 15340: IF SKIP$ <> "SSP" THEN GOTO 13760
  371. 13690 OPEN Y$ + ".SPR" FOR OUTPUT AS #1
  372. 13700 WRITE #1, RES1, PAL, I, R - L + 1, B - T + 1
  373. 13710 FOR J = 0 TO I
  374. 13720 K = VARPTR(HOLD(J))
  375. 13730 WRITE #1, PEEK(K), PEEK(K + 1), PEEK(K + 2), PEEK(K + 3)
  376. 13740 NEXT J
  377. 13750 REC = 520: GOSUB 15490: GOSUB 15220: SKIP$ = "INS"
  378. 13760 CLOSE #1: ERASE HOLD
  379. 13770 RETURN
  380. 13780 LINE (L, T)-(R, B), 0, B
  381. 13790 IF X$ = "H" THEN B = B - SPEED
  382. 13800 IF X$ = "M" THEN L = L + SPEED
  383. 13810 IF X$ = "P" THEN T = T + SPEED
  384. 13820 IF X$ = "K" THEN R = R - SPEED
  385. 13830 IF B < T + 2 THEN B = T + 2
  386. 13840 IF L > R - 2 THEN L = R - 2
  387. 13850 GOTO 13540
  388. 13860 RETURN
  389. 13870 REM *************************************************************
  390. 13880 REM **  F8          ANI = Test Animation                       **
  391. 13890 REM *************************************************************
  392. 13900 NOW$ = "ANI": REC = 521: VLOC = 4: GOSUB 15340: IF SKIP$ <> "ANI" THEN RETURN
  393. 13910 REC = 524: Z$ = Y$: VLOC = 6: GOSUB 15340: IF SKIP$ <> "ANI" THEN RETURN
  394. 13920 OPEN Z$ + ".RES" FOR INPUT AS #1: GOTO 13930
  395. 13930 INPUT #1, RES1, BAK, PAL1
  396. 13940 CLOSE #1
  397. 13950 OPEN Y$ + ".SPR" FOR INPUT AS #1: GOTO 13960
  398. 13960 INPUT #1, RES, PAL, I, WID, HGHT
  399. 13970 ' DIM HOLDC(I)
  400. 13971 DIM HOLDB(I): GOTO 13980
  401. 13980 FOR J = 0 TO I
  402. 13990 K = VARPTR(HOLDC(J)): INPUT #1, H(0), H(1), H(2), H(3)
  403. 14000 FOR L = 0 TO 3: POKE K + L, H(L): NEXT L
  404. 14010 NEXT J
  405. 14020 CLOSE #1
  406. 14030 HLOC = (320 * RES - WID) / 2: VLOC = (200 - HGHT) / 2
  407. 14040 SCREEN RES
  408. 14050 IF RES = 1 THEN COLOR BAK, PAL
  409. 14060 DEF SEG = &HB800
  410. 14070 BLOAD Z$, 0
  411. 14080 DEF SEG
  412. 14090 GET (HLOC, VLOC)-(HLOC + WID - 1, VLOC + HGHT - 1), HOLDB
  413. 14100 Y$ = "P": PUT (HLOC, VLOC), HOLDC, PSET
  414. 14110 PURGE = 1: GOSUB 15220: IF SKIP$ <> "ANI" THEN GOTO 14290
  415. 14120 IF TYPE$ <> "G" THEN GOTO 14240
  416. 14130 PUT (HLOC, VLOC), HOLDB, PSET
  417. 14140 IF X$ = "H" AND VLOC > 0 THEN VLOC = VLOC - 1
  418. 14150 IF X$ = "M" AND HLOC < RES * 319 - WID + 1 THEN HLOC = HLOC + 1
  419. 14160 IF X$ = "P" AND VLOC < 200 - HGHT THEN VLOC = VLOC + 1
  420. 14170 IF X$ = "K" AND HLOC > 0 THEN HLOC = HLOC - 1
  421. 14180 GET (HLOC, VLOC)-(HLOC + WID - 1, VLOC + HGHT - 1), HOLDB
  422. 14190 IF Y$ = "P" THEN PUT (HLOC, VLOC), HOLDC, PSET
  423. 14200 IF Y$ = "A" THEN PUT (HLOC, VLOC), HOLDC, AND
  424. 14210 IF Y$ = "O" THEN PUT (HLOC, VLOC), HOLDC, OR
  425. 14220 IF Y$ = "X" THEN PUT (HLOC, VLOC), HOLDC, XOR
  426. 14230 GOTO 14110
  427. 14240 IF X$ = "X" THEN Y$ = "X"
  428. 14250 IF X$ = "A" THEN Y$ = "A"
  429. 14260 IF X$ = "O" THEN Y$ = "O"
  430. 14270 IF X$ = "P" THEN Y$ = "P"
  431. 14280 GOTO 14110
  432. 14290 CLOSE #1: ERASE HOLDB: ERASE HOLDC: RETURN
  433. 14300 REC = 525: GOSUB 15490: GOSUB 15220: RETURN
  434. 14310 REC = 528: GOSUB 15490: GOSUB 15220: RETURN
  435. 14320 REC = 531: GOSUB 15490: GOSUB 15220: RETURN
  436. 14330 REM *************************************************************
  437. 14340 REM **  F5        RSP = Retrieve a Sprite                      **
  438. 14350 REM *************************************************************
  439. 14360 NOW$ = "RSP": REC = 534: VLOC = 4: GOSUB 15340: IF SKIP$ <> "RSP" THEN RETURN
  440. 14370 OPEN Y$ + ".SPR" FOR INPUT AS #1
  441. 14380 INPUT #1, RES1, PAL, I, WID, HGHT
  442. 14390 ' DIM HOLDC(I)
  443. 14400 IF RES1 <> 1 THEN GOTO 14460
  444. 14410 REC = 537: GOSUB 15490
  445. 14420 GOSUB 15220: IF SKIP$ <> "RSP" THEN GOTO 14580
  446. 14430 IF TYPE$ <> "C" THEN 14420
  447. 14440 BAK = ASC(X$) - 65
  448. 14450 IF BAK < 0 OR BAK > 15 THEN GOTO 14420
  449. 14460 SCREEN RES1: RES = RES1
  450. 14470 CLS
  451. 14480 IF RES = 1 THEN COLOR BAK, PAL
  452. 14490 FOR J = 0 TO I
  453. 14500 K = VARPTR(HOLDC(J)): INPUT #1, H(0), H(1), H(2), H(3)
  454. 14510 FOR L = 0 TO 3: POKE K + L, H(L): NEXT L
  455. 14520 NEXT J
  456. 14530 HLOC = (320 * RES - WID) / 2: VLOC = (200 - HGHT) / 2
  457. 14540 PUT (HLOC, VLOC), HOLDC: ERASE HOLDC
  458. 14550 CLOSE #1
  459. 14560 SKIP$ = "NEW": NOW$ = "NEW"
  460. 14570 GOTO 11260
  461. 14580 CLOSE #1: ERASE HOLD: RETURN
  462. 14590 REC = 572: GOSUB 15490: GOSUB 15220: RETURN
  463. 14600 REC = 548: GOSUB 15490: GOSUB 15220: RETURN
  464. 14610 REM *************************************************************
  465. 14620 REM **  F6       RSC = Retrieve a Screen                       **
  466. 14630 REM *************************************************************
  467. 14640 NOW$ = "RSC": REC = 551: VLOC = 4: GOSUB 15340: IF SKIP$ <> "RSC" THEN RETURN
  468. 14650 OPEN Y$ + ".RES" FOR INPUT AS #1: INPUT #1, RES, BAK, PAL: CLOSE #1
  469. 14660 SCREEN RES
  470. 14670 IF RES = 1 THEN COLOR BAK, PAL
  471. 14680 DEF SEG = &HB800
  472. 14690 BLOAD Y$, 0
  473. 14700 DEF SEG
  474. 14710 SKIP$ = "NEW": NOW$ = "NEW"
  475. 14720 GOTO 11260
  476. 14730 REC = 554: GOSUB 15490: GOSUB 15220: RETURN
  477. 14740 REM *************************************************************
  478. 14750 REM **  F4          SSC = Store a Screen       Color 0,3       **
  479. 14760 REM *************************************************************
  480. 14770 IF RES <> 0 THEN GOTO 14790
  481. 14780 NOW$ = "SSC": REC = 557: GOSUB 15490: GOSUB 15220: RETURN
  482. 14790 RES1 = RES: NOW$ = "SSC": PRESET (HLOC, VLOC), CLR
  483. 14800 DEF SEG = &HB800
  484. 14810 BSAVE DRIVE$ + ":SCREEN", 0, &H4000: DEF SEG
  485. 14820 REC = 560: VLOC = 19: GOSUB 15340: IF SKIP$ <> "SSC" THEN RETURN
  486. 14830 IF LEN(Y$) > 2 THEN NAME DRIVE$ + ":SCREEN.BAS" AS Y$ + ".BAS": GOTO 14840
  487. 14840 IF LEN(Y$) = 2 THEN Y$ = DRIVE$ + ":SCREEN"
  488. 14850 OPEN Y$ + ".RES" FOR OUTPUT AS #1
  489. 14860 WRITE #1, RES1, BAK, PAL
  490. 14870 CLOSE #1: CLS : REC = 569
  491. 14880 NOW$ = "INS": SKIP$ = "INS": GOSUB 15490
  492. 14890 RETURN
  493. 14900 REC = 571: GOSUB 15490: LOCATE 19, 37: PRINT "        ": GOTO 14820
  494. 14910 REC = 576: GOSUB 15490: LOCATE 19, 37: PRINT "        ": RETURN
  495. 14920 REC = 581: GOSUB 15490: LOCATE 19, 37: PRINT "        ": RETURN
  496. 14930 REM *************************************************************
  497. 14940 REM **              Error Handling                             **
  498. 14950 REM *************************************************************
  499. 14960 MSG = ERR: GOSUB 15920
  500. 14970 IF ERR = 7 AND ERL = 13970 THEN RESUME 14320
  501. 14980 IF ERR = 7 AND ERL = 14390 THEN RESUME 14600
  502. 14990 IF (ERR = 24 OR ERR = 25) AND ERL = 15790 THEN RESUME 15850
  503. 15000 IF ERR = 61 AND ERL = 14810 THEN RESUME 14910
  504. 15010 IF ERR = 61 AND ERL = 14870 THEN RESUME 14920
  505. 15020 IF ERR = 68 AND ERL = 15790 THEN RESUME 10400
  506. 15030 IF (ERR = 53 OR ERR = 52) AND ERL = 10050 THEN RESUME 10340
  507. 15040 IF (ERR = 53 OR ERR = 52) AND ERL = 12240 THEN RESUME 12670
  508. 15050 IF (ERR = 53 OR ERR = 52) AND ERL = 13920 THEN RESUME 14300
  509. 15060 IF (ERR = 53 OR ERR = 52) AND ERL = 13950 THEN RESUME 14310
  510. 15070 IF (ERR = 53 OR ERR = 52) AND ERL = 14370 THEN RESUME 14590
  511. 15080 IF (ERR = 53 OR ERR = 52) AND ERL = 14650 THEN RESUME 14730
  512. 15090 IF ERR = 58 AND ERL = 14830 THEN RESUME 14900
  513. 15100 IF ERR = 71 AND ERL = 15530 THEN RESUME 15860
  514. 15110 IF ERR = 72 AND ERL = 15530 THEN RESUME 15910
  515. 15120 CLS
  516. 15130 PRINT "Error number ", ERR, " at line number ", ERL
  517. 15140 PRINT
  518. 15150 PRINT "Please notify: Jan Young"
  519. 15160 PRINT "               767 N. Holden St."
  520. 15170 PRINT "               Port Washington, Wi.  53074"
  521. 15180 PRINT
  522. 15190 PRINT "Please include the error number and line number above and"
  523. 15200 PRINT "as much information about what you were doing as possible."
  524. 15210 END
  525. 15220 REM *************************************************************
  526. 15230 REM **               Read From Keyboard                        **
  527. 15240 REM *************************************************************
  528. 15250 IF PURGE = 0 THEN 15270
  529. 15260 DEF SEG = &H40: POKE &H1A, PEEK(&H1C): DEF SEG
  530. 15270 X$ = INKEY$: IF SKIP$ <> NOW$ THEN PURGE = 0: RETURN
  531. 15280 IF X$ = "" THEN 15270
  532. 15290 IF LEN(X$) <> 2 THEN 15320
  533. 15300 X$ = MID$(X$, 2, 1)
  534. 15310 TYPE$ = "G": PURGE = 0: RETURN
  535. 15320 IF ASC(X$) > 96 AND CAPS = 1 THEN X$ = CHR$(ASC(X$) - 32)
  536. 15330 TYPE$ = "C": PURGE = 0: RETURN
  537. 15340 REM *************************************************************
  538. 15350 REM **              Read 8 Characters From Keyboard            **
  539. 15360 REM *************************************************************
  540. 15370 Y$ = DRIVE$ + ":": GOSUB 15490
  541. 15380 FOR J = 1 TO 8
  542. 15390 GOSUB 15220: IF SKIP$ <> NOW$ THEN RETURN
  543. 15400 IF TYPE$ <> "C" THEN 15390
  544. 15410 IF ASC(X$) <> 8 THEN GOTO 15440
  545. 15420 IF J = 1 THEN GOTO 15390
  546. 15430 J = J - 1: X$ = " ": LOCATE VLOC, 62 + J: PRINT X$: Y$ = MID$(Y$, 1, J + 1): GOTO 15390
  547. 15440 IF ASC(X$) = 13 THEN GOTO 15480
  548. 15450 IF ASC(X$) = 46 THEN GOTO 15390
  549. 15460 LOCATE VLOC, 62 + J: PRINT X$: Y$ = Y$ + X$
  550. 15470 NEXT J
  551. 15480 RETURN
  552. 15490 REM *************************************************************
  553. 15500 REM **         Print Verbiage Screens                          **
  554. 15510 REM *************************************************************
  555. 15520 WIDTH 80: SCREEN 0, 1: RES = 0
  556. 15530 OPEN "VERBIAGE" FOR RANDOM AS #2 LEN = 85
  557. 15540 FIELD #2, 85 AS BUFFER$
  558. 15550 GET 2, REC: OUTREC$ = BUFFER$
  559. 15560 IF SKIP$ <> NOW$ THEN GOTO 15770
  560. 15570 IF MID$(OUTREC$, 1, 3) <> "c01" THEN GOTO 15600
  561. 15580 COLOR (VAL(MID$(OUTREC$, 4, 2))), (VAL(MID$(OUTREC$, 6, 2))), (VAL(MID$(OUTREC$, 8, 2)))
  562. 15590 CLS : REC = REC + 1: GOTO 15550
  563. 15600 IF MID$(OUTREC$, 1, 3) = "p01" THEN GOTO 15780
  564. 15610 LOCATE (VAL(MID$(OUTREC$, 4, 2))), (VAL(MID$(OUTREC$, 6, 2))), 0
  565. 15620 IF VAL(MID$(OUTREC$, 6, 2)) > 8 THEN PRINT MID$(OUTREC$, 8, 78 - (VAL(MID$(OUTREC$, 6, 2))))
  566. 15630 IF VAL(MID$(OUTREC$, 6, 2)) < 9 THEN PRINT MID$(OUTREC$, 8, 70)
  567. 15640 IF MID$(OUTREC$, 82, 1) <> " " AND MID$(OUTREC$, 82, 1) <> "I" THEN GOTO 15680
  568. 15650 REC = REC + 1
  569. 15660 IF VAL(MID$(OUTREC$, 78, 4)) <> 0 THEN REC = VAL(MID$(OUTREC$, 78, 4))
  570. 15670 GOTO 15550
  571. 15680 IF MID$(OUTREC$, 82, 1) <> "P" THEN GOTO 15740
  572. 15690 LOCATE 23, 28, 0: PRINT "Press Any Key to Continue"
  573. 15700 GOSUB 15220: IF SKIP$ <> NOW$ THEN GOTO 15770
  574. 15710 CLS : REC = REC + 1
  575. 15720 IF VAL(MID$(OUTREC$, 78, 4)) <> 0 THEN REC = VAL(MID$(OUTREC$, 78, 4))
  576. 15730 GOTO 15550
  577. 15740 IF MID$(OUTREC$, 82, 1) <> "E" THEN GOTO 15770
  578. 15750 LOCATE 23, 28, 0: PRINT "Press Any Key to Continue"
  579. 15760 GOSUB 15220
  580. 15770 CLOSE #2: RETURN
  581. 15780 IF MID$(OUTREC$, 4, 1) = "1" THEN LPRINT
  582. 15790 LPRINT USING "&     &"; MID$(OUTREC$, 8, 35); MID$(OUTREC$, 43, 35)
  583. 15800 IF MID$(OUTREC$, 82, 1) <> " " AND MID$(OUTREC$, 82, 1) <> "I" THEN GOTO 15840
  584. 15810 REC = REC + 1
  585. 15820 IF VAL(MID$(OUTREC$, 78, 4)) <> 0 THEN REC = VAL(MID$(OUTREC$, 78, 4))
  586. 15830 GOTO 15550
  587. 15840 CLOSE #2: RETURN
  588. 15850 REC = 615: GOSUB 15490: GOSUB 15220: GOTO 15790   ' printer not ready
  589. 15860 CLS : PRINT "Your disk drive is not ready.  Please insert The Designer's"
  590. 15870 PRINT "disk in Drive A and close the door."
  591. 15880 PRINT
  592. 15890 PRINT "Press any key to Continue"
  593. 15900 GOSUB 15220: GOTO 15530
  594. 15910 REC = 623: GOSUB 15490: GOSUB 15220: GOTO 15530   ' disk i/o error
  595. 15920 REM *************************************************************
  596. 15930 REM **                 Sound Effects                           **
  597. 15940 REM *************************************************************
  598. 15950 IF MSG = 0 THEN PLAY "t255mso3c8c8c8"
  599. 15960 IF MSG > 0 THEN PLAY "t255o1c8e-8c8e-8"
  600. 15970 RETURN
  601.  
  602.