home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / COMMODOR / LUSCHER.SFX / luscher.c.prg (.txt) next >
Commodore BASIC  |  2000-06-30  |  9KB  |  234 lines
  1. 1000 REM LUSCHER COLOUR TEST
  2. 1010 REM
  3. 1020 REM BASED ON THE ENGLISH TRANS-
  4. 1030 REM LATION OF THE ORIGINAL GERMAN
  5. 1040 REM TEXT BY DR. MAX LUSCHER.
  6. 1050 REM
  7. 1060 REM READ THE FOLLOWING PAPERBACK:
  8. 1070 REM "THE LUSCHER COLOUR TEST"
  9. 1080 REM TRANSLATED AND EDITTED BY IAN SCOTT
  10. 1090 REM SBN 671-78073-5
  11. 1100 REM POCKET BOOK EDITION SEPT.1971
  12. 1110 REM
  13. 1120 REM PROGRAM WRITTEN BY:
  14. 1130 REM         GLEN C. BODIE
  15. 1140 REM         90 KINGSMOUNT PK RD
  16. 1150 REM         TORONTO, ONTARIO
  17. 1160 REM         (416)461-3483
  18. 1170 REM
  19. 1180 REM ******************************
  20. 1190 REM * PERMISSION GRANTED TO USE, *
  21. 1200 REM * COPY AND DISTRIBUTE BUT NOT*
  22. 1210 REM * FOR PROFIT OF ANY KIND.    *
  23. 1220 REM ******************************
  24. 1230 REM
  25. 1240 REM INITIALIZATION
  26. 1250 POKE 53280,1: POKE 53281,1: Z=0
  27. 1260 DIM BC(1,7)
  28. 1270 FOR I=0 TO 7: READ BC(0,I): NEXT
  29. 1280 DATA 152,31,30,129,158,156,149,144
  30. 1290 PRINT "[147][144]DO YOU WANT OUTPUT ON THE SCREEN (S)"
  31. 1300 PRINT "OR ON THE TYPER (T)? ";: D=4
  32. 1310 GET K$: IF K$="" THEN GOTO 1310
  33. 1320 IF K$="S" THEN D=3: GOTO 1340
  34. 1330 IF K$<>"T" THEN GOTO 1310
  35. 1340 PRINT K$: OPEN 1,D: GOSUB 3000
  36. 1350 PRINT "DO YOU NEED INSTRUCTIONS (Y OR N)? ";
  37. 1360 GET K$: IF K$="" THEN GOTO 1360
  38. 1370 IF K$="Y" THEN GOSUB 2350: GOTO 1400
  39. 1380 IF K$<>"N" THEN GOTO 1360
  40. 1390 PRINT K$
  41. 1400 INPUT "ENTER YOUR NAME, PLEASE:";N$
  42. 1410 POKE 198,1: POKE 631,34: INPUT "AND THE DATE:";D$
  43. 1420 GOSUB 3040: T=0: X=RND(-TI)
  44. 1430 REM WRITE THE EIGHT COLOUR BARS
  45. 1440 GOSUB 3000
  46. 1450 FOR I=0 TO 7: BC(1,I)=-1: T(T,I)=-1: NEXT
  47. 1460 PRINT "[147]";: FOR I=0 TO 7
  48. 1470 X=INT(RND(1)*8): IF BC(1,X)>=0 THEN GOTO 1470
  49. 1480 BC(1,X)=I: J=FNJ(I): K=FNK(I)
  50. 1490 PRINT "";: FOR N=1 TO K: PRINT "";: NEXT N
  51. 1500 FOR N=1 TO 6: PRINT TAB(J)CHR$(BC(0,X))"      ": NEXT N
  52. 1510 PRINT TAB(J+2)"[144]"CHR$(65+I): NEXT I
  53. 1520 REM GET THE USER'S SELECTION
  54. 1530 PRINT "[144]CHOOSE THE COLOUR (LETTER A TO H) FOR"
  55. 1540 PRINT "WHICH YOU HAVE THE MOST SYMPATHY"
  56. 1550 FOR I=0 TO 7
  57. 1560 POKE 198,0
  58. 1570 GET K$: IF K$="" THEN GOTO 1570
  59. 1580 IF K$<"A" OR K$>"H" THEN GOTO 1560
  60. 1590 K=ASC(K$)-65: FOR X=0 TO 7: IF BC(1,X)=K THEN GOTO 1610
  61. 1600 NEXT X: GOTO 1560
  62. 1610 T(T,I)=X: BC(1,X)=-1: J=FNJ(K): K=FNK(K)
  63. 1620 PRINT "";: FOR N=1 TO K: PRINT "";: NEXT N
  64. 1630 FOR N=1 TO 8: PRINT TAB(J)"      ": NEXT N
  65. 1640 NEXT I: IF T=1 THEN GOTO 1710
  66. 1650 T=1: PRINT "[147][144]LET'S TRY IT ONCE MORE........"
  67. 1660 PRINT "REMEMBER - DON'T TRY TO CONSCIOUSLY"
  68. 1670 PRINT "REPEAT OR NOT REPEAT THE FIRST CHOICES."
  69. 1680 PRINT "TREAT THIS AS IF IT WAS THE FIRST TIME."
  70. 1690 FOR I=1 TO 7500: NEXT: GOTO 1440
  71. 1700 REM ECHO COLOUR NUMBERS CHOSEN
  72. 1710 Z=1: GOSUB 3000: FOR T=0 TO 1: PRINT#1,"TEST #"(T+1)":   ";
  73. 1720 FOR I=0 TO 7: PRINT#1,T(T,I);: NEXT: PRINT
  74. 1730 PRINT#1,SPC(13)"[173][195][195][195][195][189][173][195][195][195][195][189][173][195][195][195][195][189][173][195][195][195][195][189]": NEXT
  75. 1740 PRINT#1,SPC(13)"   +     X     =     -"
  76. 1750 PRINT#1,"COLOURS:  0 = GREY  "SPC(6)"1 = BLUE"
  77. 1760 PRINT#1,SPC(10)"2 = GREEN "SPC(6)"3 = RED"
  78. 1770 PRINT#1,SPC(10)"4 = YELLOW"SPC(6)"5 = PURPLE"
  79. 1780 PRINT#1,SPC(10)"6 = BROWN "SPC(6)"7 = BLACK"
  80. 1790 PRINT#1,"THE DIFFERENT GROUPINGS ARE DESIGNATED:"
  81. 1800 FOR A=0 TO 3: PRINT#1,"  "I$(0,A)"    "D$(A): NEXT
  82. 1810 PRINT#1,"  +/-  "D$(4)           
  83. 1820 OPEN 15,8,15
  84. 1830 FOR A=0 TO 4: FL$="LUSCHER.TEXT"+CHR$(48+A)
  85. 1840 OPEN 2,8,2,"0:"+FL$+",S,R": INPUT#15,EN: IF EN<>0 THEN GOTO 3320
  86. 1850 FOR I=0 TO 63: FOR L=0 TO 3: INPUT#2,A$(L,I): NEXT L: NEXT I
  87. 1860 CLOSE 2
  88. 1870 FOR T=0 TO 1: IF A=4 THEN C1=T(T,0): C2=T(T,7): GOTO 1890
  89. 1880 C1=T(T,A*2): C2=T(T,A*2+1)
  90. 1890 GOSUB 2970: PRINT#1,""D$(A)":"
  91. 1900 PRINT#1,SPC(10)"TEST #"(T+1)": "I$(0,A)C1;I$(1,A)C2""
  92. 1910 I=C1*8+C2: FOR L=0 TO 3: IF A$(L,I)="*" THEN A$(L,I)=" "
  93. 1920 PRINT#1,A$(L,I): NEXT
  94. 1930 ON A+1 GOTO 1940,1960,1990,1940,1990
  95. 1940 PRINT#1,"PERCENTAGE OF POPULATION WHICH CHOSE"
  96. 1950 PRINT#1,"THIS COLOUR PAIR IN THIS POSITION:"P(A/3,I)"[157]%": GOTO 1990
  97. 1960 PRINT#1,"THE PREVIOUSLY DESCRIBED +/+ FUNCTION"
  98. 1970 PRINT#1,"IS AN ATTEMPT TO COMPENSATE FOR THE"
  99. 1980 PRINT#1,"CONFLICT WHICH MAY BE DESCRIBED HERE."
  100. 1990 NEXT T: NEXT A
  101. 2000 GOSUB 2970: PRINT#1,""SPC(10)"STRESS CALCULATIONS"
  102. 2010 FOR T=0 TO 1: IF T=1 THEN X=S
  103. 2020 S=0: IF T(T,0)=0 OR T(T,0)>=6 THEN S=S+3
  104. 2030 IF T(T,1)=0 OR T(T,1)>=6 THEN S=S+2
  105. 2040 IF T(T,2)=0 OR T(T,2)>=6 THEN S=S+1
  106. 2050 IF T(T,5)>=1 AND T(T,5)<=4 THEN S=S+1
  107. 2060 IF T(T,6)>=1 AND T(T,6)<=4 THEN S=S+2
  108. 2070 IF T(T,7)>=1 AND T(T,7)<=4 THEN S=S+3
  109. 2080 PRINT#1,"TEST #"(T+1)":"ST(S)"[157]% OF THE POPULATION"
  110. 2090 PRINT#1,SPC(17)"HAD LESS STRESS.": NEXT
  111. 2100 IF S<=X THEN GOTO 2140
  112. 2110 PRINT#1,"THIS INCREASE IN STRESS BETWEEN THE TWO"
  113. 2120 PRINT#1,"TESTS MAY INDICATE A PROBLEM WHICH WILL"
  114. 2130 PRINT#1,"BE QUITE DIFFICULT TO RESOLVE."
  115. 2140 GOSUB 2970
  116. 2150 PRINT#1,"WHERE THE TWO TESTS PRODUCED SIGNIF-"
  117. 2160 PRINT#1,"ICANTLY DIFFERENT RESULTS, THE SECOND"
  118. 2170 PRINT#1,"ONE IS EXPECTED TO BE MORE CORRECT."
  119. 2180 PRINT#1,"IN ALL CASES, THE ANALYSIS OF THE"
  120. 2190 PRINT#1,"COLOURS SELECTED SHOULD ONLY BE TREATED"
  121. 2200 PRINT#1,"AS INDICATORS OF AREAS WHERE PROFESS-"
  122. 2210 PRINT#1,"IONAL ASSISTANCE SHOULD BE CONSIDERED."
  123. 2220 PRINT#1,"THIS PROGRAM HAS ONLY BEEN GIVEN THE"
  124. 2230 PRINT#1,"ABILITY TO DO VERY SIMPLEX ANALYSES."
  125. 2240 PRINT#1,"WHERE MORE DETAIL IS DESIRED IN TERMS"
  126. 2250 PRINT#1,"OF THE INTERACTIONS OF THE COLOURS SEL-"
  127. 2260 PRINT#1,"ECTED OR THE DIFFERENCES BETWEEN THE"
  128. 2270 PRINT#1,"TWO SELECTIONS, THE USER IS ADVISED TO"
  129. 2280 PRINT#1,"READ THE FOLLOWING BOOK:"
  130. 2290 PRINT#1,"   THE LUSCHER COLOUR TEST"
  131. 2300 PRINT#1,"   TRANSLATED & EDITTED BY IAN SCOTT"
  132. 2310 PRINT#1,"   RANDOM HOUSE, NOV. 1969"
  133. 2320 PRINT#1,"   SBN 671-78073-5"
  134. 2330 CLOSE1: END
  135. 2340 REM INSTRUCTIONS.............
  136. 2350 GOSUB 3000
  137. 2360 PRINT#1,"WHEN THE EIGHT COLOUR BARS APPEAR ON"
  138. 2370 PRINT#1,"THE SCREEN, LOOK THEM OVER AND DECIDE"
  139. 2380 PRINT#1,"WHICH COLOUR YOU LIKE THE BEST.  DO"
  140. 2390 PRINT#1,"NOT TRY TO ASSOCIATE THE COLOUR WITH"
  141. 2400 PRINT#1,"SOMETHING ELSE[146], SUCH AS A CAR OR A "
  142. 2410 PRINT#1,"DRESS. JUST CHOOSE THE COLOUR FOR WHICH"
  143. 2420 PRINT#1,"YOU FEEL THE MOST SYMPATHY.  PRESS THE"
  144. 2430 PRINT#1,"KEY CORRESPONDING TO THE LETTER UNDER"
  145. 2440 PRINT#1,"YOUR SELECTED COLOUR AND THE COLOUR BAR"
  146. 2450 PRINT#1,"WILL BE ERASED TO SHOW THAT YOU HAVE"
  147. 2460 PRINT#1,"CHOSEN THAT COLOUR.  NOW LOOK AT THE"
  148. 2470 PRINT#1,"REMAINING COLOURS. CHOOSE THE ONE WHICH"
  149. 2480 PRINT#1,"YOU NOW LIKE THE BEST AND SELECT IT AS"
  150. 2490 PRINT#1,"BEFORE. CONTINUE CHOOSING COLOURS UNTIL"
  151. 2500 PRINT#1,"THEY ARE ALL GONE."
  152. 2510 GOSUB 2970
  153. 2520 PRINT#1,"WHEN YOU HAVE COMPLETED THE FIRST SEL-"
  154. 2530 PRINT#1,"ECTION, YOU WILL BE ASKED TO DO IT ALL"
  155. 2540 PRINT#1,"OVER AGAIN.  DO NOT CONSCIOUSLY TRY TO"
  156. 2550 PRINT#1,"REPRODUCE YOUR FIRST SELECTION.  DO NOT"
  157. 2560 PRINT#1,"CONSCIOUSLY TRY NOT TO REPRODUCE YOUR"
  158. 2570 PRINT#1,"FIRST SELECTION.  JUST CHOOSE THE"
  159. 2580 PRINT#1,"COLOURS AS IF YOU WERE SEEING THEM FOR"
  160. 2590 PRINT#1,"THE FIRST TIME. WHEN YOU HAVE COMPLETED"
  161. 2600 PRINT#1,"THE SECOND SELECTION, YOU WILL BE GIVEN"
  162. 2610 PRINT#1,"A VERY ROUGH ANALYSIS OF YOUR COLOUR"
  163. 2620 PRINT#1,"PREFERENCES."
  164. 2630 GOSUB 2970
  165. 2640 PRINT#1,"THE PRICIPLE OF THE LUSCHER COLOUR TEST"
  166. 2650 PRINT#1,"IS THAT ACCURATE PSYCHOLOGICAL INFORM-"
  167. 2660 PRINT#1,"ATION CAN BE GAINED ABOUT A PERSON THRU"
  168. 2670 PRINT#1,"HIS CHOICES AND REJECTIONS OF COLOURS."
  169. 2680 PRINT#1,"A SIMPLIFIED VERSION OF THE TEST MAY BE"
  170. 2690 PRINT#1,"TAKEN AND INTERPRETED QUICKLY.  HOWEVER"
  171. 2700 PRINT#1,"DESPITE THE EASE AND SPEED WITH WHICH"
  172. 2710 PRINT#1,"IT CAN BE ADMINISTERED, IT IS A 'DEEP'"
  173. 2720 PRINT#1,"PSYCHOLOGICAL TEST DEVELOPED FOR THE"
  174. 2730 PRINT#1,"USE OF PSYCHIATRISTS, PSYCHOLOGISTS,"
  175. 2740 PRINT#1,"PHYSICIANS AND THOSE WHO ARE PROFESS-"
  176. 2750 PRINT#1,"IONALLY INVOLVED WITH THE CONSCIOUS AND"
  177. 2760 PRINT#1,"UNCONSCIOUS CHARACTERISTICS AND MOTIV-"
  178. 2770 PRINT#1,"ATIONS OF OTHERS.  IT IS NOT[146] A"
  179. 2780 PRINT#1,"PARLOUR GAME, AND MOST EMPHATICALLY IT"
  180. 2790 PRINT#1,"IS NOT A WEAPON TO BE USED IN A GENERAL"
  181. 2800 PRINT#1,"CONTEST OF 'ONE-UPMANSHIP'."
  182. 2810 GOSUB 2970
  183. 2820 PRINT "FOR ACCURACY OF RESULTS, PLEASE ADJUST"
  184. 2830 PRINT "THE TINT, COLOUR, BRIGHTNESS & CONTRAST"
  185. 2840 PRINT "CONTROLS OF YOUR TELEVISION SO THAT THE"
  186. 2850 PRINT "FOLLOWING COLOURS APPEAR CORRECTLY."
  187. 2860 PRINT CHR$(BC(0,0))"GREY    "SPC(5)"                   "
  188. 2870 PRINT CHR$(BC(0,1))"BLUE    "SPC(5)"                   "
  189. 2880 PRINT CHR$(BC(0,2))"GREEN   "SPC(5)"                   "
  190. 2890 PRINT CHR$(BC(0,3))"RED     "SPC(5)"                   "
  191. 2900 PRINT CHR$(BC(0,4))"YELLOW  "SPC(5)"                   "
  192. 2910 PRINT CHR$(BC(0,5))"PURPLE  "SPC(5)"                   "
  193. 2920 PRINT CHR$(BC(0,6))"BROWN   "SPC(5)"                   "
  194. 2930 PRINT CHR$(BC(0,7))"BLACK   "SPC(5)"                   [144]"
  195. 2940 GOSUB 2970
  196. 2950 RETURN
  197. 2960 REM CONTINUE & WRITE HEADING
  198. 2970 IF D=4 THEN GOTO 3000
  199. 2980 PRINT#1,"PRESS ANY KEY TO CONTINUE........": POKE 198,0
  200. 2990 GET K$: IF K$="" THEN GOTO 2990
  201. 3000 PRINT#1,"[147][144]"SPC(10)"LUSCHER COLOUR TEST"
  202. 3010 PRINT#1,SPC(10)"[183][183][183][183][183][183][183][183][183][183][183][183][183][183][183][183][183][183][183]": IF Z=0 THEN RETURN
  203. 3020 PRINT#1,"RESULTS FOR "N$SPC(5)D$: RETURN
  204. 3030 REM DEFINE DATA
  205. 3040 PRINT "WAIT WHILE DATA IS INITIALIZED."
  206. 3050 DIM T(1,7),ST(13),I$(1,4),D$(4),A$(3,63),P(1,63)
  207. 3060 DEF FN J(I)=(I-INT(I/4)*4)*10+2
  208. 3070 DEF FN K(I)=INT(I/4)*9+3
  209. 3080 FOR I=0 TO 4: READ D$(I): NEXT
  210. 3090 DATA "DESIRED OBJECTIVES","EXISTING SITUATION"
  211. 3100 DATA "RESTRAINED CHARACTERISTICS","REJECTED CHARACTERISTICS"
  212. 3110 DATA "THE ACTUAL PROBLEM"
  213. 3120 FOR I=0 TO 4: FOR J=0 TO 1: READ I$(J,I): NEXT J: NEXT I
  214. 3130 DATA "+","+","X","X","=","=","-","-","+","-"
  215. 3140 FOR I=0 TO 12: READ ST(I): NEXT
  216. 3150 DATA 0,25.9,38.1,52.4,64.1,72.7,81.8,87.3,92.1,95.5,97.9,99.3,99.9
  217. 3160 REM +?+? FUNCTIONS PROBABILITIES
  218. 3170 FOR J=0 TO 7: FOR K=0 TO 7: L=J*8+K: READ P(0,L): NEXT K: NEXT J
  219. 3180 DATA 2.7,0.6,0.4,0.5,0.3,0.2,0.6,0.2,1.2,15.9,3.8,3.6,1.4,4.4,1.1,0.5
  220. 3190 DATA 0.7,3.5,18.1,5.2,2.3,4.2,1.8,0.5,0.9,4.4,6.6,28.9,11.0,3.5,2.1,0.3
  221. 3200 DATA 0.5,1.2,2.2,6.7,12.5,1.2,0.6,0.3,0.3,4.1,4.8,3.3,1.8,15.3,0.6,0.4
  222. 3210 DATA 0.6,0.7,1.2,1.1,0.5,0.4,4.7,0.2,0.3,0.4,0.3,0.2,0.3,0.2,0.1,1.8
  223. 3220 REM X?X? FUNCTIONS - NO DATA
  224. 3230 REM =?=? FUNCTIONS - NO DATA
  225. 3240 REM -?-? FUNCTIONS
  226. 3250 FOR J=0 TO 7: FOR K=0 TO 7: L=J*8+K: READ P(1,L): NEXT K: NEXT J
  227. 3260 DATA 23.1,0.9,0.4,0.5,1.7,1.7,3.8,15.3,1.5,4.7,0.2,0.2,0.3,2.0,0.6,4.9
  228. 3270 DATA 0.7,0.3,2.8,0.2,0.4,1.0,0.7,1.7,0.8,0.2,0.1,3.4,1.5,0.8,0.7,0.9
  229. 3280 DATA 2.1,0.2,0.2,0.9,8.6,1.2,1.1,3.4,1.7,0.9,0.5,0.3,0.9,11.0,1.0,3.6
  230. 3290 DATA 5.8,0.5,0.2,0.6,1.3,1.5,11.4,5.3,10.5,1.7,0.8,0.7,2.5,3.0,3.5,35.1
  231. 3300 REM +?-? FUNCTIONS - NO DATA
  232. 3310 RETURN
  233. 3320 PRINT "DISK ERROR #"EN: CLOSE1: CLOSE2: CLOSE15: END
  234.