home *** CD-ROM | disk | FTP | other *** search
/ 17 Bit Software 1: Collection A / 17Bit_Collection_A.iso / files / 37.dms / 37.adf / fr.bas < prev    next >
BASIC Source File  |  1988-05-22  |  4KB  |  130 lines
  1. 810   scnclr
  2. 815   drawmode 1
  3. 820   dim d(128,64)
  4. 825   input "number of levels 1 through 7" ; le
  5. 830   ?"hit c for coustom colours"
  6. 835   ?"return for default"
  7. 840   get a$ : if a$ = "" then 840
  8. 845   if a$ = chr$ (13) then lc = 7 : sc = 10
  9. 850   if a$ = "c" then gosub 1435
  10. 855   ds = 2 : for n =1 to le : ds = ds + 2 ^ (n-1) : next n
  11. 860   mx = ds-1 : my = mx / 2
  12. 865   rh = pi*30/180 :vt = rh *1.2
  13. 870   for n = 1 to le : l = 10000 / 1.8^n
  14. 875   ?"working on level" ; n
  15. 880   ib = mx / 2^n : sk = ib *2
  16. 885   gosub 930
  17. 890   gosub 965
  18. 895   gosub 1000
  19. 900   next n
  20. 905   scnclr
  21. 910   pena 1
  22. 915   paint (10,10) ,0
  23. 920   goto 1175
  24. 925   rem******
  25. 930   for ye = 0 to mx-1 step sk
  26. 935   for xe = ib + ye to mx step sk
  27. 940   ax = xe - ib : ay = ye : gosub 1040 : d1 = d : ax = xe + ib : gosub 1040 : d2 = d
  28. 945   d = (d1+d2)/2 + rnd(5) * l / 2 - l / 4 : ax = xe : ay =ye : gosub 1065
  29. 950   next xe
  30. 955   next ye : return
  31. 960   rem *************
  32. 965   for xe = mx to 1 step -sk
  33. 970   for ye = ib to xe step sk
  34. 975   ax = xe : ay = ye + ib : gosub 1040 : d1 = d : ay = ye -ib : gosub 1040 : d2 = d
  35. 980   d = (d1+d2) / 2 + rnd(1)* l / 2 - l / 4 : ax = xe : ay =ye : gosub 1065
  36. 985   next ye
  37. 990   next xe : return
  38. 995   rem******************
  39. 1000  for xe= 0 to mx - 1 step sk
  40. 1005  for ye = ib to mx - xe step sk
  41. 1010  ax= xe +ye - ib : ay = ye - ib : gosub 1040 : d1 = d
  42. 1015  ax = xe + ye +ib : ay = ye + ib : gosub 1040 : d2 = d
  43. 1020  ax = xe + ye : ay = ye : d= (d1 + d2 )/ 2 + rnd ( 1 ) * l / 2 - l / 4 : gosub 1065 
  44. 1025  next ye 
  45. 1030  next xe : return
  46. 1035  rem****************
  47. 1040  if ay > my then 1050
  48. 1045  by = ay : bx= ax : goto 1055
  49. 1050  by = mx +1 - ay : bx = mx -ax
  50. 1055  d= d ( bx , by ) : return
  51. 1060  rem*************
  52. 1065  if ay > my then 1075
  53. 1070  by = ay : bx = ax : goto 1080
  54. 1075  by = mx + 1 - ay : bx = mx - ax
  55. 1080  d( bx , by ) = d : return
  56. 1085  rem**********************
  57. 1090  if xo <> -999 then 1105
  58. 1095  if zz < 0 then gosub 1400 : z2 = zz : zz = 0 : goto 1165
  59. 1100  gosub 1410 : goto 1160
  60. 1105  if z2 > 0 and zz > 0 then 1160
  61. 1110  if z2 <0 and zz < 0 then z2 = zz : zz = 0 : goto 1165
  62. 1115  w3 = zz / (zz-z2) : x3 = (x2-xx)*w3+xx : y3 = (y2-yy)*w3+yy : z3 = 0
  63. 1120  zt = zz : yt = yy : xt = xx
  64. 1125  if zz > 0 then 1150
  65. 1130  rem*****************
  66. 1135  zz = z3 : yy = y3 : xx = x3 : gosub 1330
  67. 1140  gosub 1400 : zz = 0 : yy = yt : xx = xt : z2 = zt : goto 1165
  68. 1145  rem ******************
  69. 1150  zz = z3 : yy = y3 : xx = x3 : gosub 1330
  70. 1155  gosub 1410 : zz = zt : yy = yt : xx = xt
  71. 1160  z2 = zz
  72. 1165  x2 = xx : y2 = yy : return
  73. 1170  rem ****************
  74. 1175  gosub 1415
  75. 1180  xs = .04 : ys = .04 : zs = .04
  76. 1185  for ax = 0 to mx : xo=-999 : for ay = 0 to ax
  77. 1190  gosub 1040 : zz = d : yy = ay / mx * 10000 : xx = ax / mx *10000 -yy / 2
  78. 1195  gosub 1325 : next ay : next ax
  79. 1200  for ay = 0 to mx : xo = -999 : for ax = ay to mx
  80. 1205  gosub 1040 : zz = d : yy = ay / mx *10000 : xx = ax / mx *10000 -yy / 2
  81. 1210  gosub 1325 : next ax : next ay
  82. 1215  for ex = 0 to mx : xo = -999 : for ey = 0 to mx - ex
  83. 1220  ax = ex + ey : ay = ey : gosub 1040 : zz = d : yy = ay / mx *10000
  84. 1225  xx = ax / mx *10000 - yy / 2 : gosub 1325 : next ey : next ex
  85. 1230  goto 1425
  86. 1235  rem********
  87. 1240  if xx <> 0 then 1255
  88. 1245  if yy <=0 then ra = - pi / 2 : goto 1265
  89. 1250  ra = pi / 2 : goto 1265
  90. 1255  ra = atn(yy/xx)
  91. 1260  if xx < 0 then ra = ra + pi
  92. 1265  r1 = ra + rh : rd = sqr(xx*xx+yy*yy)
  93. 1270  xx = rd *cos(r1) : yy = rd * sin(r1)
  94. 1275  return
  95. 1280  rem******
  96. 1285  rd = sqr(zz*zz+xx*xx)
  97. 1290  if xx = 0 then ra = pi / 2 : goto 1305
  98. 1295  ra = atn (zz/xx)
  99. 1300  if xx <0 then ra = ra+pi
  100. 1305  r1 = ra-vt
  101. 1310  xx = rd *  cos(r1)+xx : zz = rd * sin(r1)
  102. 1315  return
  103. 1320  rem *************
  104. 1325  gosub 1090
  105. 1330  xx = xx * xs : yy = yy * ys : zz = zz *zs
  106. 1335  gosub 1240
  107. 1340  gosub 1285
  108. 1345  if xo = - 999 then pr$ = "m"
  109. 1350  if xo <> -999 then pr$ = "d"
  110. 1355  xp = int(yy)+cx : yp = int(zz)
  111. 1360  gosub 1375
  112. 1365  return
  113. 1370  rem*********
  114. 1375  xp = xp * 0.625 : yp = 33.14-0.663 *yp
  115. 1380  if pr$ = "m" then x8 = xp : y8 = yp : xo = x
  116. 1385  if y8 > 179 or y8 < 0 or yp > 179 or yp< 0 then return
  117. 1390  draw (x8,y8 to xp,yp)
  118. 1395  x8 = xp : y8 = yp : return
  119. 1400  pena sc : return
  120. 1405  rem***********
  121. 1410  pena lc : return
  122. 1415  return
  123. 1420  rem *******
  124. 1425  sleep 5*10^6 : goto 1460
  125. 1430  end
  126. 1435  rem*****
  127. 1440  input "choose high colour 2 to 16" ; lc
  128. 1445  input "choose high colour 2 to 16" ; sc
  129. 1450  return
  130.