home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / USCX / DOSUT-03.ZIP / HIQUE.BAS < prev    next >
BASIC Source File  |  1983-07-20  |  5KB  |  143 lines
  1. 1 '             *** HIQUE ***
  2. 2 '             by Wes Meier (70215,1017)
  3. 3 '
  4. 4 '             Written for IBM PC with 80 Column Color.
  5. 5 '             Requires BASICA.
  6. 6 '             Supports Light Pen Operation.
  7. 7 '
  8. 8 SCREEN 0,1:KEY OFF:LOCATE ,,0,0,7:COLOR 6,1,1:CLS
  9. 9 DEFINT B-Z:DEFSTR A:DIM P(33),L(33),T(33),L2T(33)
  10. 10 DEF SEG=0:POKE &H417,96:DEF SEG
  11. 11 A=STRING$(4,219)+STRING$(4,29)+CHR$(31)+STRING$(4,219)+CHR$(30)+"  "
  12. 12 AB=CHR$(218)+STRING$(2,196)+CHR$(191)+STRING$(4,29)+CHR$(31)
  13. 13 AB=AB+CHR$(192)+STRING$(2,196)+CHR$(217)+CHR$(30)+"  "
  14. 14 MOVE=0:PEGS=32
  15. 15 A(1)="       1  2  3"
  16. 16 A(2)="       4  5  6"
  17. 17 A(3)=" 7  8  9 10 11 12 13"
  18. 18 A(4)="14 15 16 17 18 19 20"
  19. 19 A(5)="21 22 23 24 25 26 27"
  20. 20 A(6)="      28 29 30"
  21. 21 A(7)="      31 32 33"
  22. 22 A(8)="  Board Numbering"
  23. 23 FULL=-1:EMPTY=NOT FULL
  24. 24 GOSUB 25:GOTO 26
  25. 25 FOR X=1 TO 33:P(X)=FULL:NEXT:P(17)=EMPTY:RETURN
  26. 26 DATA 1,1,1,4,4,4,7,7,7,7,7,7,7,10,10,10,10,10,10,10,13,13,13,13,13,13,13
  27. 27 DATA 16,16,16,19,19,19
  28. 28 DATA 32,38,44,32,38,44,20,26,32,38,44,50,56,20,26,32,38,44,50,56,20,26,32
  29. 29 DATA 38,44,50,56,32,38,44,32,38,44
  30. 30 FOR X=1 TO 33:READ L(X):NEXT
  31. 31 FOR X=1 TO 33:READ T(X):L2T(X)=L(X)^2-T(X):NEXT
  32. 32 PEN ON
  33. 33 ON PEN GOSUB 63
  34. 34 USE.PEN=-1
  35. 35 PRINT TAB(30);:COLOR 20,7:PRINT" *** HIQUE *** ":COLOR 6,1:PRINT
  36. 36 PRINT"HIQUE is a puzzle that has 32 pegs or blocks arranged in a cross shape with the"
  37. 37 PRINT"center position of the cross empty. Your task is to is to remove as many pegs"
  38. 38 PRINT"as you can. A fantastic solution is one that has only one peg remaining."
  39. 39 PRINT"The PERFECT game ends with the one peg remaining in the center position!"
  40. 40 PRINT
  41. 41 PRINT"Rules:"
  42. 42 PRINT"     - Pegs are removed ONLY when they are JUMPED by another peg."
  43. 43 PRINT"     - You may jump ONLY One peg at a time."
  44. 44 PRINT"     - You may jump ONLY vertically or horizontally...NOT diagonally."
  45. 45 PRINT"     - You may jump ONLY into an EMPTY space."
  46. 46 PRINT
  47. 47 PRINT"Don't worry about making a mistake, HIQUE won't let you!"
  48. 48 PRINT:PRINT"Now, press any key to start the puzzle or, if you have a light pen,"
  49. 49 PRINT"touch the screen........";:COLOR 20,7:PRINT"   GOOD LUCK !!   ";
  50. 50 PENFLAG=-1
  51. 51 AX=INKEY$:IF AX="" THEN 51
  52. 52 USE.PEN=0:PEN OFF
  53. 53 GOTO 75
  54. 54 'Draw the Cross Subroutine
  55. 55 FOR X=1 TO 33
  56. 56 LOCATE L(X),T(X)
  57. 57 IF P(X)=FULL THEN PRINT A; ELSE PRINT AB;
  58. 58 NEXT
  59. 59 IF USE.PEN THEN RETURN
  60. 60 LOCATE 1,1
  61. 61 FOR X=1 TO 8:PRINT A(X);:PRINT:NEXT
  62. 62 RETURN
  63. 63 'Light Pen Subroutine
  64. 64 IF PENFLAG THEN PENFLAG=0:RETURN 75
  65. 65 IF PEN(8)=24 THEN MOVE=0:PEGS=32:GOSUB 25:CLS:RETURN 75
  66. 66 L=0:FOR X=1 TO 33:IF PEN(8)=L(X) OR PEN(8)=L(X)+1 THEN L=L(X):X=34
  67. 67 NEXT:IF L=0 THEN RETURN
  68. 68 T=0:FOR X=1 TO 33
  69. 69 IF PEN(9)>=T(X) AND PEN(9)<=T(X)+3 THEN T=T(X):X=34
  70. 70 NEXT:IF T=0 THEN RETURN
  71. 71 L2T=L^2-T
  72. 72 FOR X=1 TO 33
  73. 73 IF L2T=L2T(X) THEN PEN.MOVE=X:X=34
  74. 74 NEXT:RETURN
  75. 75 COLOR 6,1:CLS:GOSUB 55
  76. 76 IF USE.PEN THEN 77 ELSE 80
  77. 77 LOCATE 24,20:COLOR 4,7
  78. 78 PRINT"     Touch This Area To Re-Start       ";
  79. 79 GOTO 81
  80. 80 LOCATE 24,32:PRINT"Enter 99 to Re-Start";
  81. 81 LOCATE 16,50:COLOR 4,7
  82. 82 MOVE=MOVE+1
  83. 83 PRINT" Move #"MOVE;
  84. 84 LOCATE 17,50:PRINT" Pegs Remaining ="PEGS;
  85. 85 COLOR 6,1
  86. 86 LOCATE 22,32:PRINT STRING$(25,32);
  87. 87 LOCATE 22,32:PRINT"Move from ";
  88. 88 IF NOT USE.PEN THEN 92
  89. 89 PRINT"(Touch Pen)";:PEN.MOVE=0
  90. 90 IF PEN.MOVE=0 THEN 90
  91. 91 MOVE.FROM=PEN.MOVE:GOTO 95
  92. 92 INPUT MOVE.FROM:IF MOVE.FROM<>99 THEN 95
  93. 93 MOVE=0:PEGS=32:GOSUB 25:GOTO 75
  94. 94 SOUND 37,5:GOTO 86
  95. 95 IF MOVE.FROM<1 OR MOVE.FROM>33 THEN 94
  96. 96 IF P(MOVE.FROM)=EMPTY THEN 94
  97. 97 COLOR 22:LOCATE L(MOVE.FROM),T(MOVE.FROM):PRINT A;:COLOR 6
  98. 98 LOCATE 22,32:PRINT STRING$(25,32);
  99. 99 LOCATE 22,32:PRINT"Move to ";
  100. 100 IF NOT USE.PEN THEN 104
  101. 101 PRINT"(Touch Pen)";:PEN.MOVE=0
  102. 102 IF PEN.MOVE=0 THEN 102
  103. 103 MOVE.TO=PEN.MOVE:GOTO 105
  104. 104 INPUT MOVE.TO:IF MOVE.TO=99 THEN 93
  105. 105 IF MOVE.TO>=1 AND MOVE.TO<=33 THEN 108
  106. 106 COLOR 6:LOCATE L(MOVE.FROM),T(MOVE.FROM):PRINT A;
  107. 107 GOTO 94
  108. 108 IF P(MOVE.TO)=FULL THEN 106
  109. 109 IF MOVE.FROM<4 THEN MF=MOVE.FROM-6:GOTO 114
  110. 110 IF MOVE.FROM<7 THEN MF=MOVE.FROM-2:GOTO 114
  111. 111 IF MOVE.FROM>30 THEN MF=MOVE.FROM+6:GOTO 114
  112. 112 IF MOVE.FROM>27 THEN MF=MOVE.FROM+2:GOTO 114
  113. 113 MF=MOVE.FROM
  114. 114 IF MOVE.TO<4 THEN MT=MOVE.TO-6:GOTO 119
  115. 115 IF MOVE.TO<7 THEN MT=MOVE.TO-2:GOTO 119
  116. 116 IF MOVE.TO>30 THEN MT=MOVE.TO+6:GOTO 119
  117. 117 IF MOVE.TO>27 THEN MT=MOVE.TO+2:GOTO 119
  118. 118 MT=MOVE.TO
  119. 119 IF ABS(MT-MF)<>2 AND ABS(MT-MF)<>14 THEN 106
  120. 120 OP=(MF+MT)/2
  121. 121 IF OP<2 THEN OP=OP+6:GOTO 125
  122. 122 IF OP<7 THEN OP=OP+2:GOTO 125
  123. 123 IF OP>32 THEN OP=OP-6:GOTO 125
  124. 124 IF OP>27 THEN OP=OP-2
  125. 125 IF P(OP)=EMPTY THEN 106
  126. 126 P(MOVE.FROM)=EMPTY
  127. 127 P(OP)=EMPTY
  128. 128 P(MOVE.TO)=FULL
  129. 129 PEGS=PEGS-1
  130. 130 LOCATE L(MOVE.FROM),T(MOVE.FROM):PRINT AB;
  131. 131 LOCATE L(OP),T(OP):PRINT AB;
  132. 132 LOCATE L(MOVE.TO),T(MOVE.TO):PRINT A;
  133. 133 IF PEGS>1 THEN 81
  134. 134 LOCATE 22,30:PRINT STRING$(25,32);
  135. 135 LOCATE 22,26:COLOR 20,7
  136. 136 PRINT" **** You DID it !!! **** ";
  137. 137 IF P(17)=EMPTY THEN 139
  138. 138 LOCATE 23,24:PRINT" **** A PERFECT Game !!! **** ";
  139. 139 COLOR 6,1
  140. 140 FOR X=1 TO 3:FOR Y=20 TO 70:PLAY"MBT255L48N=Y;":NEXT:NEXT
  141. 141 LOCATE 23,1
  142. 142 END'of program.
  143.