API tools faq
paste
Advertisement
Guest User

Untitled

a guest
May 12th, 2019
149
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
QBasic 23.45 KB | None | 0 0
raw download clone embed print report
  1. DECLARE SUB piples (h$)
  2. DECLARE SUB cube (s$(), n1, n2, n3, n4, m$, m1$, m2$)
  3. DECLARE SUB sets (s$, s1$, n2, mx)
  4. DECLARE SUB scrn (s$, s1$, n2, ff)
  5. DECLARE SUB cph (n1, n2)
  6. DECLARE SUB sy (m$, m1$, n)
  7. DECLARE SUB road (LOC$(), locx, locy, ddd$, nn)
  8. DECLARE SUB tree (LOC$(), locx, locy, d$, n)
  9. DECLARE SUB wr (h$, d$, x, y)
  10. DECLARE SUB hous (h$, f, r)
  11. DECLARE SUB wrh (h$, find$, lx, door, fin)
  12. DECLARE SUB opr (n, c$, n1, n2)
  13. DECLARE SUB prs (LOC$(), locx, locy, xx, yy, nx1, nx2, ny1, ny2, posx, posy, x, y, lll, col9)
  14. DECLARE SUB sp (n)
  15. DECLARE SUB sex (sex1, h1$, n2$, sx$)
  16. DECLARE SUB setwr (h$, n, d$, n1, n2)
  17. DECLARE SUB say (n$, n1$, n2$)
  18. DECLARE SUB wrl (u, d, l, r, c, LOC$(), locx, locy)
  19. DECLARE SUB sety (s$(), s1$, x, y, n, mx)
  20.         RANDOMIZE TIMER
  21.         CLEAR 2000000
  22.          CLS
  23.          col8 = 7
  24.         DIM mon$(12), days(12)
  25.         year = 679: mont = 3: day = 22
  26.         min = 59: hour = 11: sec = 100
  27.         DATA "Tetorus","Norhus","Mandra","Gorgad","Andrida","Ereston","Fongus","Rohus","Dearit","Cripfon","Kripos","Standor"
  28.         DATA 26,25,26,26,25,26,25,26,26,25,26,26
  29.         DATA 3,9,5,10,12,15,13
  30.         FOR i = 1 TO 12: READ mon$(i): NEXT i
  31.         FOR i = 1 TO 12: READ days(i): NEXT i
  32.         FOR i = 1 TO 7: READ soon(i): NEXT i
  33.         sw = 1
  34.         SCREEN 0
  35.         CLS
  36.         NAME$ = "Jim"
  37.         sex1 = 1
  38.         GOTO m101
  39. locgen: nn1 = 2
  40.         locx = 180
  41.         locy = 60
  42.         DIM LOC$(locy)
  43.         FOR i = 1 TO locx: loc11$ = loc11$ + ".": NEXT i
  44.         FOR j = 1 TO locy: LOC$(j) = loc11$: NEXT j
  45.              
  46.         npip = INT((RND * (locx * locy / 80)) + (locx * locy / 80))
  47.         DIM pp$(npip, 3)
  48.         mag = INT(((npip / 8)) / (RND * 2 + 4)) + 2
  49.         DIM mg$(mag, nn1)
  50.         taw = INT(npip / 60) + 1
  51.         DIM tw(taw, nn1)
  52.         hot = INT(((npip / 12)) / (RND * 2 + 5)) + 1
  53.         DIM ht$(hot, nn1)
  54.         hos = INT(npip / 4)
  55.         DIM hs$(hos, nn1)
  56.         enm = INT(npip * (RND * .5)) + 1
  57.         DIM en$(enm, 2)
  58.         itm = INT((npip / 5) * (RND * 2 + 2)) + 1
  59.        ' DIM item$(itm, nn1)
  60.         hra = INT(RND * 1.99): IF hra = 1 THEN DIM hram(5)
  61.         cas = INT(RND * 1.99): IF cas = 1 THEN DIM casi(5)
  62.         kld = INT(npip / (RND * 2 + 8))
  63.         DIM kld$(kld)
  64.         IF npip > 150 THEN wall = INT(RND * 1.99) + 4: GOTO wrwall
  65.         IF npip > 120 THEN wall = INT(RND * 2.99) + 2: GOTO wrwall
  66.         IF npip > 100 THEN wall = INT(RND * 2.99): GOTO wrwall
  67.         IF npip > 70 THEN wall = INT(RND * 1.99): GOTO wrwall
  68.         GOTO endwr
  69.  
  70. m101:   lll = 0
  71.         posx = 1: posy = 1
  72.         hp = 20
  73.         GOSUB locgen
  74.         DATA 2, -1, 5, -1, 7, 1, 10, 1
  75.         nx1 = 16: nx2 = 79: ny1 = 4: ny2 = 22
  76.  
  77.         DIM kys(10), pr(20)
  78.         s$ = ".": col = 8
  79.         FOR i = 1 TO 20
  80.         pr(i) = INT(RND * 100.99): NEXT i
  81.         FOR i = 1 TO 4: READ ky1: READ kys(ky1): NEXT i
  82.         n$ = "@"
  83. m100:   wsh1 = INT(wsh / 60): wsh2 = (wsh / 60 - wsh1) * 60
  84.         zhd1 = INT(zhd / 60): zhd2 = (zhd / 60 - zhd1) * 60
  85.         nzet = -1.039: wsh = 462 - nzet: zhd = 1182 + nzet
  86.         x = INT(RND * 40) + 26: y = INT(RND * 10) + 9
  87.         dd$ = CHR$(SCREEN(y, x)): IF dd$ <> "." THEN GOTO m100
  88.         COLOR 15
  89.         LOCATE y, x: PRINT n$
  90. ink:    sec = sec + 1: IF sec = 10001 THEN GOSUB status: sec = 1: min1 = min1 + 1: min = min + 1: IF min = 60 THEN min = 0: hour = hour + 1: IF hour = 24 THEN hour = 0: day = day + 1: min1 = 0: min2 = 0: min3 = 0: min4 = 0: min5 = 0: wsh = wsh + nzet: wsh1 = INT(wsh / 60): wsh2 = (wsh / 60 - wsh1) * 60: col8 = 1: zhd = zhd - nzet: zhd1 = INT(zhd / 60): zhd2 = (zhd / 60 - zhd1) * 60: IF day = days(mont) + 1 THEN mont = mont + 1: day = 0: IF mont = 13 THEN mont = 1: year = year + 1
  91.         IF hour = wsh1 AND min = INT(wsh2) AND sec = 2 THEN min2 = min1: gg = 1
  92.         min3 = min1 - min2: IF min3 / 10 = INT(min3 / 10) AND gg = 1 AND sec = 1 THEN col8 = col8 + 1: GOSUB prscr: IF min3 > 40 THEN gg = 0
  93.         IF hour = zhd1 AND min = INT(zhd2) AND sec = 2 THEN min4 = min1: zz = 1
  94.         min5 = min1 - min4: IF min5 / 10 = INT(min5 / 10) AND zz = 1 AND sec = 2 THEN col8 = col8 - 1: GOSUB prscr: IF min5 > 40 THEN zz = 0
  95.         IF hour = wsh1 + 3 AND min = INT(wsh2) AND sec = 2 THEN col8 = 7: GOSUB prscr
  96.         IF hour = zhd1 + 2 AND min = INT(zhd2) AND sec = 2 THEN col8 = 1: GOSUB prscr
  97.         IF monh = 6 OR monh = 12 AND day = 22 THEN nzet = -nzet
  98.         a$ = INKEY$
  99.         IF a$ = "q" THEN END
  100.         IF a$ = "s" THEN RUN
  101.         IF LEN(a$) = 2 THEN a1$ = RIGHT$(a$, 1): a1 = ASC(a1$) ELSE GOTO ekey
  102.         IF a1 = 72 OR a1 = 80 THEN dy = kys(a1 - 70)
  103.         IF a1 = 75 OR a1 = 77 THEN dx = kys(a1 - 70)
  104. ekey:   IF a$ = "" THEN GOTO ink
  105.            xx1 = x + dx1: yy1 = y + dy1
  106.            xx = x + dx: yy = y + dy
  107.         s1$ = s9$: s9$ = CHR$(SCREEN(yy, xx))
  108.         IF dx <> 0 OR dy <> 0 THEN s8$ = CHR$(SCREEN(yy, xx))
  109.         IF s9$ >= "0" AND s9$ <= "9" THEN GOSUB opros: GOTO g00
  110.         IF a$ = "w" THEN sw = -sw
  111.         IF sw = -1 THEN LOCATE 1, 1: PRINT "  s8:" + s8$ + "s:" + s$ + " s9:" + s9$ + " ss:" + ss$ + " s1:" + s1$ + " a:" + a$ + "  "
  112.         IF s9$ = "+" OR s9$ = "#" OR s9$ >= "@" AND s9$ <= "Z" OR s9$ >= "a" AND s9$ <= "z" OR s9$ > "Ї" THEN dx = 0: dy = 0: IF ld = 0 THEN ld = 1: PLAY "n0l64": hp = hp - .01: 'CALL sy("rg s n", so$, pr(1)): LOCATE 1, 1: PRINT name$ + ": " + so$: GOSUB status
  113.         IF s9$ = " " THEN dx = 0: dy = 0: ON locnn GOSUB endho
  114. g00:    IF s8$ = "<" AND a$ = "<" THEN ador = 1: ON locnn GOSUB hofl: ador = 0
  115.         IF s8$ = ">" AND a$ = ">" THEN ador = -1: ON locnn GOSUB hofl: ador = 0
  116.         IF s8$ = "+" AND a$ = "o" THEN ON locnn GOSUB hodoor
  117.         IF dx <> 0 OR dy <> 0 THEN ld = 0
  118.         IF xx < nx1 OR xx > nx2 THEN lll = 1: GOSUB prscr: lll = 0: dx = 0
  119.         IF yy < ny1 OR yy > ny2 THEN lll = 2: GOSUB prscr: lll = 0: dy = 0
  120.         LOCATE y, x: COLOR soon(col8): PRINT s$
  121.         x = x + dx: y = y + dy
  122.         IF dx <> 0 OR dy <> 0 THEN : ss$ = s$
  123.         s$ = CHR$(SCREEN(y, x))
  124.         LOCATE y, x: COLOR 15: PRINT n$
  125.         dx1 = dx: dx = 0: dy1 = dy: dy = 0
  126. ink2:   GOTO ink
  127. wrwall: IF wall = 5 THEN nn$ = "±": nnr = 0: GOTO begwr
  128.         IF wall = 4 THEN nn$ = "°": nnr = .08: GOTO begwr
  129.         IF wall = 3 THEN nn$ = "І": nnr = .18: GOTO begwr
  130.         IF wall = 2 THEN nn$ = "І": nnr = .35: GOTO begwr
  131.         IF wall = 1 THEN nn$ = "^": nnr = .56: GOTO begwr
  132. begwr:  FOR i = 1 TO locy
  133.         lx = INT(RND * 1.99) + 2: nn1$ = nn$
  134.         IF RND < nnr THEN IF RND < nnr THEN nn1$ = "^":  ELSE nn1$ = "."
  135.         CALL sets(LOC$(i), nn1$, lx, locx)
  136.         lx1 = INT(RND * 1.99) + 2: nn2$ = nn$
  137.         IF RND < nnr THEN IF RND < nnr THEN nn2$ = "^":  ELSE nn2$ = "."
  138.         CALL sets(LOC$(i), nn2$, locx - lx1, locx)
  139.         NEXT i
  140.         FOR i = 1 TO locx
  141.         nny1 = 1: nn1$ = nn$
  142.         IF RND > .5 THEN nny1 = 2
  143.         IF RND < nnr THEN IF RND < nnr THEN nn1$ = "^":  ELSE nn1$ = "."
  144.         CALL sets(LOC$(nny1), nn1$, i, locx)
  145.         nny2 = locy
  146.         IF RND > .5 THEN nny2 = locy - 1:
  147.         nn2$ = nn$
  148.         IF RND < nnr THEN IF RND < nnr THEN nn2$ = "^":  ELSE nn2$ = "."
  149.         CALL sets(LOC$(nny2), nn2$, i, locx)
  150.         NEXT i
  151.  
  152.        
  153.         CALL wrl(6, 3, 4, 5, 0, LOC$(), locx, locy)
  154.  
  155. endwr:  ' „ Ћ ђ Ћ ѓ €
  156.        CH$ = CHR$(249): CH$ = CH$ + CH$ + CH$ + CH$ + CH$ + CH$
  157.        'ch$ = "ъъъъъъ"
  158.        'CALL road(loc$(), locx, locy, CH$, .35)
  159.        
  160.  
  161.         IF hra = 0 THEN GOTO en
  162.         LET magx = 10 + INT((RND * 2.99) / 2) * 2
  163.         LET magy = 6
  164.         sym$ = "О": 's12$ = CHR$(ASC("A"))
  165.         CALL cube(LOC$(), magx, magy, locx, locy, "І", sym$, "І")
  166.         hs$(1, 1) = "n" + sym$ + s12$
  167.  
  168. en:    ' ‹ ћ „ €
  169.         FOR j = 1 TO npip
  170.         CALL piples(pp$(i, 1))
  171.  
  172.         NEXT j
  173.  
  174.         ' Њ Ђ ѓЂ ‡ € Ќ ›
  175.         FOR j = 1 TO mag
  176.         LET magx = INT(((RND * 5) + 4) / 2) * 2
  177.         LET magy = 2: s12$ = CHR$(ASC("A") + j - 1)
  178.         sym$ = "1"
  179.         CALL cube(LOC$(), magx, magy, locx, locy, "±", sym$, s12$)
  180.         mg$(j, 1) = "n" + sym$ + s12$
  181.         NEXT j
  182.  '      ’ Ђ ‚ … ђ Ќ ›
  183.         FOR j = 1 TO taw
  184.         LET magx = 6: s12$ = CHR$(ASC("A") + j - 1)
  185.         LET magy = 2
  186.         sym$ = "5"
  187.         CALL cube(LOC$(), magx, magy, locx, locy, "Ы", sym$, s12$)
  188.         tw$(j, 1) = "n" + sym$ + s12$
  189.         NEXT j
  190. '      Ћ ’ … ‹ €
  191.         FOR j = 1 TO hot
  192.         LET magx = 8: s12$ = CHR$(ASC("A") + j - 1)
  193.         LET magy = 4
  194.         sym$ = "2"
  195.         CALL cube(LOC$(), magx, magy, locx, locy, "°", sym$, s12$)
  196.         ht$(j, 1) = "n" + sym$ + s12$
  197.         NEXT j
  198. '       „ Ћ Њ Ђ
  199.         FOR j = 1 TO hos
  200.         LET magx = 4
  201.         LET magy = 2
  202.         sym$ = "0": s12$ = CHR$(ASC("!") + j - 1)
  203.         CALL cube(LOC$(), magx, magy, locx, locy, "°", sym$, s12$)
  204.         hs$(j, 1) = s12$
  205.         CALL hous(hs$(j, 2), INT(RND * 3) + 2, INT(RND * .35) + .65)
  206.         NEXT j
  207. xnn1:     CALL tree(LOC$(), locx, locy, CHR$(6), .25)
  208.            CALL tree(LOC$(), locx, locy, CHR$(5), .2)
  209.            CALL tree(LOC$(), locx, locy, CHR$(24), .2)
  210.            CALL tree(LOC$(), locx, locy, ",", .45)
  211.         col9 = 15
  212.         GOSUB prscr
  213.         RETURN
  214.        
  215. prscr:  IF locnn <> 0 THEN ON locnn GOSUB opros11: RETURN
  216.         CLS
  217.         GOSUB status
  218.        
  219.        IF no = 0 THEN CALL prs(LOC$(), locx, locy, xx, yy, nx1, nx2, ny1, ny2, posx, posy, x, y, lll, soon(col8))
  220.        RETURN
  221. endg:
  222.         RUN
  223. opros:  ON VAL(s9$) + 1 GOSUB opros1
  224.         RETURN
  225. opros1: PRINT xx, yy, dx, dy
  226.         nh$ = CHR$(SCREEN(yy + dy, xx + dx + dx))
  227.         PRINT "  "; nh$
  228.         FOR i = 1 TO hos
  229.         IF hs$(i, 1) = nh$ THEN ri = i: GOTO opros11
  230.         NEXT i
  231. opros11: CLS : GOSUB status
  232.          COLOR soon(col8)
  233.          CALL wrh(hs$(ri, 2), "", lx, door, fin)
  234.          locnn = 1
  235.          ox = x - dx: oy = yy - dy
  236.          s09$ = s9$
  237.          x = lx - 1: y = 8
  238.          RETURN
  239. endho:  IF sec < sec1 THEN CALL sp(2): RETURN
  240.          x = ox: y = oy: s9$ = s09$: locnn = 0
  241.          CLS
  242.          GOSUB status
  243.          CALL prs(LOC$(), locx, locy, xx, yy, nx1, nx2, ny1, ny2, posx, posy, x, y, lll, soon(col8))
  244.         RETURN
  245.  
  246. hofl:   LOCATE 1, 1
  247.         IF ador = 1 THEN CALL sex(sex1, " бЇгбвЁ«бп", " бЇгбвЁ« бм", sx$):  ELSE CALL sex(sex1, " Ї®¤­п«бп", " Ї®¤­п« бм", sx$)
  248.         CALL sp(3)
  249.         CALL wrh(hs$(ri, 2), "f", g12, g13, fin): IF g12 < 2 AND ador = 1 THEN g12 = 2:  GOTO hhhh
  250.         CALL wrh(hs$(ri, 2), "r", g13, g14, fin): IF g12 > g13 AND ador = -1 THEN g12 = g13: GOTO hhhh
  251.         CALL setwr(hs$(ri, 2), 2, "f", g12 + (-ador), 0)
  252.             flor1$ = " ўлиҐ."
  253.             IF ador = 1 THEN flor1$ = " ­Ё¦Ґ."
  254.             PRINT "   " + NAME$ + sx$ + " нв ¦Ґ¬ "; flor1$
  255.         COLOR soon(col8): find$ = ""
  256. hhhh:   CALL wrh(hs$(ri, 2), find$, lx, door, fin)
  257.         s$ = find$: s8$ = find$
  258.         RETURN
  259.  
  260. hodoor: CALL sex(sex1, " pushed", " pushed", sx$)
  261.         LOCATE 1, 1: CALL sp(3)
  262. door1:  PRINT "  " + NAME$ + sx$ + " door";
  263.         IF door = 1 THEN CALL say(", and door opened.", ", and door was open.", ", and door opened."): GOTO ll4
  264.         IF door = 2 THEN IF RND < .9 THEN CALL say(" door didn't open", " door didn't open", " door didn't open"): PLAY "n12l64":  ELSE CALL sp(3): door = 1: GOTO door1
  265.         IF door = 3 THEN CALL say(", but door was lock.", ", but door was lock.", ", but door was lock.")
  266.  
  267. ll4:    COLOR soon(col8)
  268.         CALL wrh(hs$(ri, 2), "d", g12, g13, fin)
  269.         IF door = 1 THEN CALL setwr(hs$(ri, 2), fin, "d", 0, 0): PLAY "n12l64"
  270.         CALL wrh(hs$(ri, 2), "", lx, door, fin)
  271.        
  272. status: COLOR 13
  273.         LOCATE 7, 3: PRINT "HP:"; INT(hp)
  274.         'LOCATE 4, 3: PRINT "px:"; posx
  275.         'LOCATE 5, 3: PRINT "py:"; posy
  276.         'LOCATE 6, 3: PRINT "ly:"; locy
  277.         LOCATE 4, 3: PRINT year; " year"
  278.         LOCATE 5, 3: PRINT mon$(mont) + ","; day; "  ";
  279.         LOCATE 6, 3: PRINT hour; ":"; min; "   "
  280.         COLOR soon(col8)
  281.         RETURN
  282.         dx = 1
  283.         rn = RND:
  284.         IF rn < .2 THEN dx = -1
  285.         IF nx < lk AND rn < .9 THEN dy = 1:  ELSE IF ny > 1 THEN dy = -1
  286.         IF nx < lk2 AND rn < .99 THEN dy = 0:  ELSE IF rn < .5 THEN dy = -1 ELSE dy = 1
  287.         IF nx > lk2 AND rn < .8 AND ny > 2 THEN dy = -1:  ELSE IF nx > locx - 4 THEN dy = 1
  288.         IF ny + dy < 1 THEN dy = 0
  289.         IF ny > 1 AND nx = locx THEN dy = -1: dx = -1
  290.         nx = nx + dx: ny = ny + dy
  291.         LOCATE 4, 5: PRINT nx, ny:
  292.         hx = INT(nx / 5) + 2: hy = INT(ny / 2) + 2
  293.          LOCATE hy, hx: PRINT "±"
  294.         FOR i = 1 TO 1100: NEXT i
  295.         IF nx < 1 THEN nx = 0
  296.         IF nx > locx THEN nx = locx
  297.         IF ny + m(1) > locy THEN ny = locy - m(1)
  298.         m1 = m(1)
  299.         IF dy = -1 THEN s$ = "/" ELSE s$ = "\": IF dy = 0 THEN s$ = " "
  300.         's$ = "!"
  301.         IF dx = -1 THEN m1 = 1
  302.         CALL sety(LOC$(), s$, nx, ny, m1, locx)
  303.  
  304. SUB cph (n1, n2)
  305.         IF INT(RND * 100.99) < n1 THEN n2 = 1
  306.         IF INT(RND * 100.99) > n1 THEN n2 = 2
  307.         END SUB
  308.  
  309.         SUB cube (s$(), n1, n2, n3, n4, m$, m1$, m2$)
  310. m1:     nnn = 0: nnn1 = 0
  311.         LET n5 = INT((RND * (n3 - (n1 + 2))) / 2) * 2: IF n5 < 3 THEN GOTO m1
  312.         LET n6 = INT((RND * (n4 - (n2 + 2))) / 2) * 2 + 1: IF n6 < 3 THEN GOTO m1
  313.         LET wx = INT(RND * 3.99) + 1
  314.        CALL scrn(s$(n6), d$, n5, 1)
  315.         IF d$ <> "." THEN GOTO m1
  316.         CALL scrn(s$(n6), d$, n5 + n1 + 1, 1)
  317.         IF d$ <> "." THEN GOTO m1
  318.         CALL scrn(s$(n6 - 1), d$, n5 + n1, 1)
  319.         IF d$ <> "." THEN GOTO m1
  320.         CALL scrn(s$(n6), d$, n5 - 1, 1)
  321.         IF d$ <> "." THEN GOTO m1
  322.         CALL scrn(s$(n6 - 1), d$, n5, 1)
  323.         IF d$ <> "." THEN GOTO m1
  324.         CALL scrn(s$(n6 + n2 + 1), d$, n5, 1)
  325.         IF d$ <> "." THEN GOTO m1
  326.         CALL scrn(s$(n6 + n2), d$, n5 - 1, 1)
  327.         IF d$ <> "." THEN GOTO m1
  328.         CALL scrn(s$(n6 + n2), d$, n5 + n1 + 1, 1)
  329.         IF d$ <> "." THEN GOTO m1
  330.         CALL scrn(s$(n6 + n2 - 1), d$, n5 + n1, 1)
  331.         IF d$ <> "." THEN GOTO m1
  332.         CALL scrn(s$(n6 + 1), d$, n5 + 1, 1)
  333.         IF d$ <> "." THEN GOTO m1
  334.         CALL scrn(s$(n6 + n2 + 1), d$, n5 + n1 + 1, 1)
  335.         IF d$ <> "." THEN GOTO m1
  336.        ' CALL scrn(s$(n6 + n2 + 1), d$, n5, 1)
  337.       '  IF d$ <> "." THEN GOTO m1
  338.        
  339.         FOR i = 1 TO n1
  340.         s1$ = s1$ + m$: ON wx GOTO m2, m3, m4, m5
  341. m0:     NEXT i: s1$ = s1$ + m$: IF nnn1 <> 1 THEN s5$ = s5$ + m$
  342.         FOR i = n6 TO n6 + n2
  343.         s2$ = LEFT$(s$(i), n5): s3$ = RIGHT$(s$(i), n3 - n5 - n1)
  344.          IF wx = 1 AND i = n6 THEN s$(i) = s2$ + s5$ + s3$: GOTO m10
  345.          IF wx = 2 AND i = n6 + n2 THEN s$(i) = s2$ + s5$ + s3$: GOTO m10
  346.          IF wx = 3 AND i = n6 + INT(n2 / 2) THEN s$(i) = s2$ + s5$ + s3$: GOTO m10
  347.          IF wx = 4 AND i = n6 + INT(n2 / 2) THEN s$(i) = s2$ + s5$ + s3$: GOTO m10
  348.         s$(i) = s2$ + s1$ + s3$
  349.        
  350. m10:    NEXT i
  351.         GOTO m7
  352. m2:     IF i = INT(n1 / 2) + 1 AND nnn = 0 THEN s5$ = s5$ + m1$: nnn = 1: GOTO m0
  353.         s5$ = s5$ + m$: GOTO m0
  354. m3:     IF i = INT(n1 / 2) + 1 AND nnn = 0 THEN s5$ = s5$ + m1$: nnn = 1: GOTO m0
  355.         s5$ = s5$ + m$: GOTO m0
  356. m4:     IF i = n1 AND nnn = 0 THEN s5$ = s5$ + m$ + m1$: nnn = 1: nnn1 = 1: GOTO m0
  357.         s5$ = s5$ + m$: GOTO m0
  358. m5:     IF i = 1 AND nnn = 0 THEN s5$ = s5$ + m1$: nnn = 1: GOTO m0
  359.         s5$ = s5$ + m$: GOTO m0
  360.  
  361.  
  362. m7:     'CALL sets(s$(INT(n6 + (n2 / 2))), m2$, n5 + INT(n1 / 2), n3)
  363.         CALL sets(s$(n6 + INT(n2 / 2)), m2$, n5 + (n1 / 2), n3)
  364.         END SUB
  365.  
  366. SUB hous (h$, f, r)
  367.         CALL wr(h$, "r", f, 0)
  368.         CALL wr(h$, "f", 2, 0)
  369.         x = INT(((RND * 20) + 10) * r)
  370.         y = INT(((RND * 8) + 8) * r)
  371.        
  372.         lx = INT(RND * (x - 6)) + 3
  373.         ly = INT(RND * (y - 4)) + 2
  374.         CALL wr(h$, "l", lx, ly)
  375.         door = INT(RND * 2.99): IF RND < .2 THEN door = 3
  376.         CALL wr(h$, "d", door, 0)
  377.         sym = INT(RND * 6.99) + 1
  378.         CALL wr(h$, "s", sym, 0)
  379.         FOR i = 1 TO f
  380.         CALL wr(h$, "o", x, y)
  381.         NEXT i
  382. END SUB
  383.  
  384. SUB opr (n, c$, n1, n2)
  385.         ON n GOTO mopr1, mopr2
  386. mopr1:  IF c$ = "h" THEN cx = n1
  387. mopr2:
  388. END SUB
  389.  
  390. SUB piples (h$)
  391.         IF RND < .5 THEN n = 1:  ELSE n = 2
  392.         CALL wr(h$, "p", n, 0)
  393.  
  394. END SUB
  395.  
  396. SUB prs (LOC$(), locx, locy, xx, yy, nx1, nx2, ny1, ny2, posx, posy, x, y, lll, col9)
  397. mpr:    IF lll = 0 THEN GOTO prs0
  398.         ON lll GOSUB prs1, prs2
  399. prs0:   COLOR col9
  400.         FOR i = 3 TO 21
  401.         LOCATE i + 1, 16
  402.         PRINT MID$(LOC$((i - 3) + posy), posx, 64)
  403.         NEXT i
  404. j1:     GOTO mret
  405. prs1:   IF xx < nx1 THEN posx = posx - 16: x = x + 16: IF posx < 1 THEN nll = -(1 - posx): posx = 1: x = x + nll: RETURN:  ELSE RETURN
  406.         IF xx > nx2 THEN posx = posx + 16: x = x - 16: IF posx > locx - 64 THEN nll = posx - (locx - 64): posx = locx - 64: x = x + nll: RETURN:  ELSE RETURN
  407. prs2:   IF yy > ny2 THEN posy = posy + 6: y = y - 6: IF posy > locy - 18 THEN nll = posy - (locy - 18): posy = locy - 18: y = y + nll: RETURN:  ELSE RETURN
  408.         IF yy < ny1 THEN posy = posy - 6: y = y + 6: IF posy < 1 THEN nll = -(1 - posy): posy = 1: y = y + nll: RETURN:  ELSE RETURN
  409. '
  410. mret:   END SUB
  411.  
  412. SUB road (LOC$(), locx, locy, ddd$, nn)
  413.      '   ON INT(RND * 1.99) + 1 GOTO mr1, mr2
  414.          dx = 1: x = INT(locx / 2): y = 1
  415. mr1:    b = LEN(ddd$)
  416.         IF RND < nn THEN dx = -dx
  417.          CALL sets(LOC$(y), ddd$, x, locx)
  418.          IF x > locx - b OR x < 1 THEN GOTO mrstop
  419.          IF y > INT(locy / 2) THEN GOTO mrplace
  420.         x = x + dx: y = y + 1
  421.         GOTO mr1
  422. mrplace: ND = INT(b * 1.5)
  423.         FOR i = 1 TO ND
  424.         CALL sets(LOC$(y + i - 1), ddd$ + ddd$ + ddd$, x - b, locx)
  425.         NEXT i
  426. '        FOR i = 1 TO 3
  427. '        lx2 = INT(locx * .1)
  428. '        ON i GOTO mrr1, mrr2, mrr3
  429. 'mrr1:   dx = -1: y = y + INT((nd - 1) / 2): x = x - b: x1 = x: y1 = y: xy = locx - ((locx - x) + lx2): GOTO mrre
  430. 'mrr2:   dx = 1: y = y1: x = x1 + b * 3: xy = INT((locx - (locx * .2)) / 2) - (b * 3) + 1: GOTO mrre
  431. 'mrr3:   dy = 1: dx = 0: x = x1 + INT(b / 2): y = y1: xy = INT((locy - (locy * .2)) / 2): GOTO mrre
  432. 'mrre:   FOR j = 1 TO xy - 1
  433. '         dd$ = LEFT$(ddd$, 4)
  434. '         CLS
  435. '         PRINT "j:"; j; " x:"; x; " lx:"; locx; " y:"; y; " ly:"; locy, xy
  436. '         CALL sets(loc$(y), dd$, x, locx)
  437. '        IF dx <> 0 THEN CALL sets(loc$(y + 1), dd$, x, locx)
  438. '         x = x + dx: y = y + dy
  439. '         NEXT j: NEXT i
  440. mrstop: END SUB
  441.  
  442. SUB say (n$, n2$, n3$)
  443.         ON INT(RND * 2.99) + 1 GOSUB msay1, msay2, msay3
  444.         GOTO msaye
  445. msay1:  PRINT n$: RETURN
  446. msay2:  PRINT n1$: RETURN
  447. msay3:  PRINT n2$
  448. msaye:  END SUB
  449.  
  450. SUB scrn (s$, s1$, n2, ff)
  451.  s1$ = MID$(s$, n2, ff)
  452. END SUB
  453.  
  454. SUB sets (s$, s1$, n2, mx)
  455. ln = LEN(s1$)
  456. s3$ = LEFT$(s$, n2): s4$ = RIGHT$(s$, mx - (n2 - 1 + ln))
  457. s$ = s3$ + s1$ + s4$
  458. END SUB
  459.  
  460. SUB setwr (h$, n, d$, n1, n2)
  461.         lh = LEN(h$)
  462.         x = ((n - 1) * 7)
  463.         CALL wr(r$, d$, n1, n2)
  464.         CALL sets(h$, r$, x, lh - 1)
  465.        
  466. END SUB
  467.  
  468. SUB sety (s$(), s1$, x, y, n, mx)
  469.       ln = LEN(s1$)
  470.        FOR i = y TO y + n
  471.        
  472.         s3$ = LEFT$(s$(i), x): s4$ = RIGHT$(s$(i), mx - (x - 1 + ln))
  473.         s$(i) = s3$ + s1$ + s4$
  474.        NEXT i
  475. END SUB
  476.  
  477. SUB sex (sex1, h1$, h2$, sx$)
  478.         ON sex1 GOTO msex1, msex2
  479.         GOTO msexe
  480. msex1:  sx$ = h1$: GOTO msexe
  481. msex2:  sx$ = h2$
  482. msexe:  END SUB
  483.  
  484. SUB sp (n)
  485. LOCATE 1, 1
  486. FOR i = 1 TO n
  487. PRINT "                                                                             "
  488. NEXT i: LOCATE 1, 1
  489. END SUB
  490.  
  491. SUB sy (m$, m1$, n)
  492.         a$ = LEFT$(m$, 2)
  493.         IF a$ = "rg" THEN GOTO mrug
  494.         GOTO mend
  495. mrug:   a$ = MID$(m$, 4, 1)
  496.         IF a$ = "s" THEN c = 1: c1 = 8
  497.         a$ = MID$(m$, 6, 1)
  498.         IF a$ = "n" THEN GOTO mrug1
  499.         GOTO mend
  500. mrug1:  CALL cph(n, d)
  501.        ' m2$ = sl$(1, INT(RND * c1 - .01) + 1)
  502.         ON d GOTO mrug2, mrug3
  503. mrug2:  'call spr(1,
  504. mrug3:
  505. mend:   END SUB
  506.  
  507. SUB tree (LOC$(), locx, locy, d$, n)
  508.         n1 = INT((RND * ((locx * locy) / 30)) * n)
  509.         nn = INT(RND * (n1 / 2) + (n1 / 1.25))
  510.         FOR i = 1 TO nn
  511. mtr1:   x = INT(((RND * (locx - 5)) + 3) / 2) * 2 + 1: y = INT((RND * (locy - 5)) + 3)
  512.         CALL scrn(LOC$(y), g$, x, 1): IF g$ <> "." THEN GOTO mtr1
  513.         CALL sets(LOC$(y), d$, x, locx)
  514. mtrn:   NEXT i
  515. END SUB
  516.  
  517. SUB wr (h$, d$, x, y)
  518.  x$ = STR$(x): IF LEN(x$) > 2 THEN x$ = RIGHT$(x$, 2)
  519.  y$ = STR$(y): IF LEN(y$) > 2 THEN y$ = RIGHT$(y$, 2)
  520. h$ = h$ + d$ + x$ + "," + y$ + ";"
  521. END SUB
  522.  
  523. SUB wrh (h$, find$, lx, door, fin)
  524.         h = LEN(h$)
  525.         FOR i = 1 TO h
  526.         a$ = MID$(h$, i, 1)
  527.         IF find$ <> "" THEN IF a$ = find$ THEN fin = INT(i / 7) + 1: ffin$ = find$: find$ = "" ELSE GOTO mnx
  528.         IF n = 0 THEN c$ = a$: n1$ = "": n2$ = "": n = 1: GOTO mnx
  529.         IF a$ = "," THEN n = 2: GOTO mnx
  530.         IF n = 1 THEN n1$ = n1$ + a$
  531.         IF a$ = ";" THEN n = 0: GOSUB mcall: GOTO mnx
  532.         IF n = 2 THEN n2$ = n2$ + a$
  533. mnx:    NEXT i: GOTO mwrhe
  534. mcall:  n1 = VAL(n1$): n2 = VAL(n2$)
  535.         IF c$ = ffin$ THEN lx = n1: door = n2: GOTO mwrhe
  536.         IF c$ = "r" THEN nr = n1: RETURN
  537.         IF c$ = "f" THEN nfl = n1: RETURN
  538.         IF c$ = "l" THEN lxx = n1: lyy = n2: RETURN
  539.         IF c$ = "d" THEN door = n1: RETURN
  540.        IF c$ = "s" THEN sym = n1: RETURN
  541.         IF c$ = "o" THEN nfl1 = nfl1 + 1: IF nfl1 = nfl THEN xf = n1: yf = n2: GOSUB mflor: RETURN
  542.         RETURN
  543. mflor:  hh1$ = "°±І#Ы=і": hh$ = MID$(hh1$, sym, 1)
  544.         yy = 4
  545.         xx = 52 - INT(xf / 2)
  546.         FOR j = 1 TO xf
  547.         IF sym < 7 THEN d$ = d$ + hh$
  548.         IF sym = 7 THEN IF j = 1 THEN d$ = d$ + "Ъ": d2$ = d2$ + "А":  ELSE IF j = xf THEN d$ = d$ + "ї": d2$ = d2$ + "Щ":  ELSE d$ = d$ + "Д": d2$ = d2$ + "Д"
  549.         IF j = 1 OR j = xf THEN d1$ = d1$ + hh$: d5$ = d5$ + "I":  ELSE d1$ = d1$ + ".": d5$ = d5$ + "."
  550.        
  551.         NEXT j: d$ = d$ + "....": d1$ = d1$ + "....": d2$ = d2$ + "....": d5$ = d5$ + "...."
  552.         LOCATE yy + 1, xx
  553.         PRINT d$
  554.         FOR j = 1 TO yf - 1
  555.         LOCATE yy + j + 1, xx
  556.         IF sym <> 6 THEN PRINT d1$ ELSE PRINT d5$
  557.         NEXT j
  558.         LOCATE yy + yf + 1, xx
  559.         IF sym <> 7 THEN PRINT d$:  ELSE PRINT d2$
  560.         PRINT : PRINT SPC(xx);
  561.         IF nfl > 1 THEN PRINT "ќв ¦:"; nfl - 1; "  " ELSE PRINT "Џ®¤ў «."
  562.         LOCATE yy + INT(yf / 2 + .5), xx + xf - 1
  563.         IF nfl = 2 AND door = 0 THEN sss$ = "\"
  564.         IF nfl = 2 AND door <> 0 THEN sss$ = "+"
  565.         IF nfl <> 2 THEN sss$ = ""
  566.         PRINT sss$
  567.         lx = xx + xf + 3
  568.         LOCATE yy + lyy, xx + lxx
  569.         IF nfl = 2 AND nr = 2 THEN PRINT "<": RETURN
  570.         IF nfl = nr THEN find$ = "<": RETURN
  571.         IF nfl = 1 THEN find$ = ">": RETURN
  572.         PRINT "<>"
  573.          RETURN
  574. mwrhe:   END SUB
  575.  
  576. SUB wrl (u, d, l, r, c, LOC$(), locx, locy)
  577.         DIM m(5), mm(5), dd(5)
  578.         m(1) = u: m(2) = d: m(3) = l: m(4) = r: m(5) = c
  579.         FOR i = 1 TO 5: d = 0
  580.         FOR j = 1 TO 5
  581.         IF m(i) <= m(j) THEN d = d + 1
  582.         NEXT j: mm(i) = d: dd(d) = i
  583.         NEXT i
  584.         'FOR i = 1 TO 5
  585.         vid = 1: ' m (dd(1))
  586.         ON vid GOTO mup', mdw, mlf, mrg, cen
  587. mup:
  588.          lk = INT(locx / (RND * 4 + 1)): lk2 = INT(locx / 1.5)
  589.          
  590.          z = 5
  591.          IF m(5) = m(1) THEN z = 2
  592.          maxy = INT(RND * 20 + (locy / z))
  593.          sty = maxy / lk
  594.          y = 1
  595.          FOR x = 1 TO locx
  596.        
  597.          CALL sety(LOC$(), "і", x, INT(y), m(1), locx)
  598.          IF x < lk THEN y = y + sty
  599.          IF x >= lk2 THEN y = y - sty
  600.          IF INT(y) < 1 THEN y = 1
  601.          NEXT x
  602. END SUB
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!