database/ddbase6.bas

   1 ' Dos Database\r
   2 ' made by Svjatoslav Agejenko\r
   3 ' in 2002\r
   4 ' H-Page: svjatoslav.eu\r
   5 ' E-Mail: svjatoslavagejenko@gmail.com\r
   6  \r
   7 DECLARE SUB box (x1%, y1%, x2%, y2%)\r
   8 DECLARE SUB ssort (s%, m%)\r
   9 DECLARE SUB sort (s%, w%)\r
  10 REM $DYNAMIC\r
  11 DECLARE SUB cmp (a$, b$, r%)\r
  12 DECLARE SUB boss ()\r
  13 DECLARE SUB std (a$)\r
  14 DECLARE FUNCTION cnum$ (a%)\r
  15 DECLARE SUB fload (a$, b%, c%, d%)\r
  16 DECLARE SUB putfs (f%, l%, s%, c$)\r
  17 DECLARE SUB gets (l%, s%, a$)\r
  18 DECLARE SUB puts (l%, s%, a$)\r
  19 DECLARE SUB runf (a$)\r
  20 DECLARE SUB getfil (a%)\r
  21 DEFINT A-Y\r
  22 DECLARE SUB mkson (a$)\r
  23 DECLARE SUB title (a$)\r
  24 DECLARE SUB strip (a$, b$)\r
  25 DECLARE SUB cmd (a$)\r
  26 DECLARE SUB conkey (a$)\r
  27 DECLARE SUB conn (a$)\r
  28 DECLARE SUB ch ()\r
  29 DECLARE SUB chkey (a$)\r
  30 DECLARE SUB getkey (a$)\r
  31 DECLARE SUB conm (a$, c)\r
  32 DECLARE SUB start ()\r
  33 \r
  34 DIM SHARED con$(1 TO 50)\r
  35 DIM SHARED conc(1 TO 50)\r
  36 DIM SHARED concmd$\r
  37 DIM SHARED conx\r
  38 DIM SHARED sona$(1 TO 20)\r
  39 DIM SHARED mitus\r
  40 \r
  41 DIM SHARED buf$(1 TO 5000)\r
  42 DIM SHARED bufu(1 TO 5000)\r
  43 DIM SHARED bufl(1 TO 1000, 1 TO 30)\r
  44 DIM SHARED buflu(1 TO 1000)\r
  45 DIM SHARED lng\r
  46 DIM SHARED opf(1 TO 30)\r
  47 DIM SHARED hist$(1 TO 20)\r
  48 DIM SHARED histp, histk\r
  49 DIM SHARED buff(1 TO 30, 1 TO 1000)\r
  50 DIM SHARED stack(1 TO 2000, 1 TO 10)\r
  51 DIM SHARED stackl(1 TO 10)\r
  52 DIM SHARED stdl\r
  53 \r
  54 start\r
  55 \r
  56 1\r
  57 ch\r
  58 GOTO 1\r
  59 \r
  60 REM $STATIC\r
  61 SUB boss\r
  62 y1 = 0\r
  63 yp1 = 100\r
  64 y2 = 0\r
  65 yp2 = 100\r
  66 \r
  67 lx = 160\r
  68 ly = 100\r
  69 lxp = 1\r
  70 lyp = -1\r
  71 \r
  72 SCREEN 13\r
  73 \r
  74 GOSUB 18\r
  75 16\r
  76 a$ = INKEY$\r
  77 IF a$ = CHR$(0) + "H" THEN yp1 = yp1 - 25\r
  78 IF a$ = CHR$(0) + "P" THEN yp1 = yp1 + 25\r
  79 IF a$ = CHR$(27) THEN GOTO 17\r
  80 \r
  81 LINE (10, y1 - 35)-(20, y1 + 35), 0, B\r
  82 LINE (11, y1 - 34)-(19, y1 + 34), 15, B\r
  83 \r
  84 LINE (310, y2 - 35)-(300, y2 + 35), 0, B\r
  85 LINE (309, y2 - 34)-(301, y2 + 34), 15, B\r
  86 \r
  87 LINE (lx - 10, ly - 10)-(lx + 10, ly + 10), 0, B\r
  88 LINE (lx - 9, ly - 9)-(lx + 9, ly + 9), 15, B\r
  89 \r
  90 lx = lx + lxp\r
  91 ly = ly + lyp\r
  92 IF ly < 20 THEN lyp = 1\r
  93 IF ly > 180 THEN lyp = -1\r
  94 IF lx < 30 THEN\r
  95 lxp = 1\r
  96 IF ly < y1 - 35 OR ly > y1 + 35 THEN SOUND 1000, 1\r
  97 END IF\r
  98 IF lx > 290 THEN lxp = -1: GOSUB 18\r
  99 \r
 100 \r
 101 IF yp1 > 0 THEN y1 = y1 + 1: yp1 = yp1 - 1\r
 102 IF yp1 < 0 THEN y1 = y1 - 1: yp1 = yp1 + 1\r
 103 IF yp2 > 0 THEN y2 = y2 + 1: yp2 = yp2 - 1\r
 104 IF yp2 < 0 THEN y2 = y2 - 1: yp2 = yp2 + 1\r
 105 \r
 106 SOUND 0, .1\r
 107 GOTO 16\r
 108 18\r
 109 tlx = lx\r
 110 tly = ly\r
 111 tlyp = lyp\r
 112 tlxp = lxp\r
 113 \r
 114 \r
 115 19\r
 116 lx = lx + lxp\r
 117 ly = ly + lyp\r
 118 IF ly < 20 THEN lyp = 1\r
 119 IF ly > 180 THEN lyp = -1\r
 120 IF lx < 30 THEN lxp = 1\r
 121 IF lx > 290 THEN\r
 122 yp2 = ly - y2\r
 123 ELSE\r
 124 GOTO 19\r
 125 END IF\r
 126 \r
 127 SWAP lx, tlx\r
 128 SWAP ly, tly\r
 129 SWAP lyp, tlyp\r
 130 SWAP lxp, tlxp\r
 131 RETURN\r
 132 \r
 133 17\r
 134 SCREEN 0\r
 135 WIDTH 80, 50\r
 136 VIEW PRINT 1 TO 50\r
 137 END SUB\r
 138 \r
 139 SUB box (x1, y1, x2, y2)\r
 140 b$ = ""\r
 141 c$ = ""\r
 142 FOR a = x1 TO x2\r
 143 b$ = b$ + " "\r
 144 c$ = c$ + "-"\r
 145 NEXT a\r
 146 \r
 147 b$ = "|" + b$ + "|"\r
 148 c$ = "|" + c$ + "|"\r
 149 \r
 150 COLOR 14, 0\r
 151 LOCATE y1, x1\r
 152 PRINT c$\r
 153 LOCATE y2, x1\r
 154 PRINT c$\r
 155 FOR a = y1 + 1 TO y2 - 1\r
 156 LOCATE a, y1\r
 157 PRINT b$\r
 158 NEXT a\r
 159 \r
 160 \r
 161 END SUB\r
 162 \r
 163 SUB ch\r
 164 chkey a$\r
 165 IF a$ <> "" THEN conkey a$\r
 166 \r
 167 END SUB\r
 168 \r
 169 SUB chkey (a$)\r
 170 a$ = INKEY$\r
 171 IF a$ <> "" THEN\r
 172 IF a$ = CHR$(0) + "M" THEN a$ = "pa"\r
 173 IF a$ = CHR$(0) + "K" THEN a$ = "va"\r
 174 IF a$ = CHR$(0) + "H" THEN a$ = "ul"\r
 175 IF a$ = CHR$(0) + "P" THEN a$ = "al"\r
 176 \r
 177 \r
 178 END IF\r
 179 END SUB\r
 180 \r
 181 SUB cmd (a$)\r
 182 IF a$ = SPACE$(LEN(a$)) THEN GOTO 5\r
 183 conm a$, 14\r
 184 \r
 185 mkson a$\r
 186 IF mitus = 0 THEN GOTO 5\r
 187 \r
 188 SELECT CASE sona$(1)\r
 189 CASE "help"\r
 190 title "help"\r
 191 conm "help   - for help", 7\r
 192 conm "quit   - quit program", 7\r
 193 conm "b      - boss screen", 7\r
 194 conm "memstat- show info about memory blocks", 7\r
 195 conm "memput <addr> <data> - put data to specified memoy block", 7\r
 196 conm "memlist <addr> <amount> - show memory blocks, starting from <addr>", 7\r
 197 conm "runf <file.ext> - run script file", 7\r
 198 conm "lnstat - show info about memory lines", 7\r
 199 conm "lnput <line> <word> <data> <data> ... put data in <line> starting from <word>", 7\r
 200 conm "lnlist <addr> <amount> - show contenc of memory lines", 7\r
 201 conm "fstat - show info about memory files", 7\r
 202 conm "fput <file> <line> <word> <data> <data> ... put data in memory file", 7\r
 203 conm "fload <filename.ext> <file> <line> <word>- load data file into memory file", 7\r
 204 conm "cls    - clear screen", 7\r
 205 conm "stclear <stack> - clear stack", 7\r
 206 conm "chklin <page> <from line> <to line> - determine used line numbers to STDOUT", 7\r
 207 conm "stacksize <stack> - determine stack size to STDOUT", 7\r
 208 conm "filtand <stack> <word> <mask> <word> <mask> ... filters out lines to STDOUT", 7\r
 209 conm "filtor <stack> <word> <mask> <word> <mask> ... filters out lines to STDOUT", 7\r
 210 conm "disp <stack> <word> <word> ... display formatted selected cells to STDOUT", 7\r
 211 conm "sort <stack> <word> - sort elements by <word> value, lower first", 7\r
 212 conm "swap <stack> - swap stack elements (backwards)", 7\r
 213 conm "ssort <stack> <word> - sort stack in alphabetical order", 7\r
 214 conm "memget <pointer> - allocates memory block, and puts there -", 7\r
 215 conm "liststack <stack> <from line> <to line> - show stack values to STDOUT", 7\r
 216 conm "ask <question> <file> <line> <word> - asks question, and stores result", 7\r
 217 conm "flnget <file> <pointer> - get unused line in file", 7\r
 218 GOTO 5\r
 219 \r
 220 CASE "quit"\r
 221 SYSTEM\r
 222 \r
 223 CASE "memstat"\r
 224 title "memory blocks summary"\r
 225 c = 0\r
 226 lng = 0\r
 227 FOR b = 1 TO 5000\r
 228 IF bufu(b) > 0 THEN c = c + 1\r
 229 lng = lng + LEN(buf$(b))\r
 230 NEXT b\r
 231 d$ = "memory blocks used:" + STR$(c) + "  total 5000"\r
 232 conm d$, 7\r
 233 d$ = "data size:" + STR$(lng)\r
 234 conm d$, 7\r
 235 GOTO 5\r
 236 \r
 237 CASE "memput"\r
 238 b = VAL(sona$(2))\r
 239 strip sona$(3), c$\r
 240 IF c$ = "" THEN\r
 241 bufu(b) = 0\r
 242 buf$(b) = ""\r
 243 ELSE\r
 244 bufu(b) = 1\r
 245 buf$(b) = sona$(3)\r
 246 END IF\r
 247 GOTO 5\r
 248 \r
 249 CASE "memlist"\r
 250 b = VAL(sona$(2))\r
 251 c = VAL(sona$(3))\r
 252 IF b = 0 THEN b = 1\r
 253 IF c = 0 THEN c = 1\r
 254 \r
 255 FOR d = b TO 5000\r
 256 IF c = 0 THEN GOTO 5\r
 257 IF bufu(d) > 0 THEN\r
 258 e$ = cnum(d) + ":" + SPACE$(5 - LEN(cnum(d)))\r
 259 e$ = e$ + buf$(d)\r
 260 conm e$, 7\r
 261 c = c - 1\r
 262 END IF\r
 263 NEXT d\r
 264 GOTO 5\r
 265 \r
 266 CASE "runf"\r
 267 runf sona$(2)\r
 268 GOTO 5\r
 269 \r
 270 CASE "lnstat"\r
 271 title "memory lines summary"\r
 272 c = 0\r
 273 d = 0\r
 274 FOR b = 1 TO 1000\r
 275 IF buflu(b) > 0 THEN c = c + 1: d = d + buflu(b)\r
 276 NEXT b\r
 277 d$ = "memory lines used:" + STR$(c) + "  total 1000"\r
 278 conm d$, 7\r
 279 d$ = "total number of words in lines:" + STR$(d)\r
 280 conm d$, 7\r
 281 GOTO 5\r
 282 \r
 283 CASE "lnput"\r
 284 b = VAL(sona$(2))\r
 285 c = VAL(sona$(3))\r
 286 e = mitus\r
 287 IF e < 4 THEN e = 4\r
 288 FOR d = 4 TO e\r
 289 puts b, c + d - 4, sona$(d)\r
 290 NEXT d\r
 291 GOTO 5\r
 292 \r
 293 CASE "lnlist"\r
 294 b = VAL(sona$(2))\r
 295 c = VAL(sona$(3))\r
 296 \r
 297 FOR d = b TO 1000\r
 298 IF c = 0 THEN GOTO 5\r
 299 IF buflu(d) > 0 THEN\r
 300 e$ = cnum(d) + ":"\r
 301 e$ = e$ + SPACE$(5 - LEN(e$))\r
 302 e$ = e$ + cnum(buflu(d))\r
 303 e$ = e$ + SPACE$(8 - LEN(e$))\r
 304 \r
 305 FOR g = 1 TO 10\r
 306 gets d, g, f$\r
 307 e$ = e$ + " >" + f$\r
 308 NEXT g\r
 309 conm e$, 7\r
 310 c = c - 1\r
 311 END IF\r
 312 NEXT d\r
 313 GOTO 5\r
 314 \r
 315 CASE "fstat"\r
 316 title "Memory files summary"\r
 317 FOR b = 1 TO 30\r
 318   e = 0\r
 319   FOR c = 1 TO 1000\r
 320     IF buff(b, c) > -1 THEN\r
 321       IF e = 0 THEN\r
 322       d$ = "File number:" + STR$(b)\r
 323       conm d$, 7\r
 324       e = e + 1\r
 325       END IF\r
 326       d$ = "on line:" + STR$(c) + "  allocated memory line: " + STR$(buff(b, c))\r
 327       conm d$, 7\r
 328     END IF\r
 329   NEXT c\r
 330 NEXT b\r
 331 GOTO 5\r
 332 \r
 333 CASE "fput"\r
 334 b = VAL(sona$(2))\r
 335 c = VAL(sona$(3))\r
 336 d = VAL(sona$(4))\r
 337 f = mitus\r
 338 IF f < 5 THEN f = 5\r
 339 FOR e = 5 TO f\r
 340 putfs b, c, d + e - 5, sona$(e)\r
 341 NEXT e\r
 342 GOTO 5\r
 343 \r
 344 CASE "cls"\r
 345 FOR b = 1 TO 50\r
 346 conm " ", 7\r
 347 NEXT b\r
 348 GOTO 5\r
 349 \r
 350 CASE "fload"\r
 351 b = VAL(sona$(3))\r
 352 c = VAL(sona$(4))\r
 353 d = VAL(sona$(5))\r
 354 IF b = 0 THEN b = 1\r
 355 IF c = 0 THEN c = 1\r
 356 IF d = 0 THEN d = 1\r
 357 fload sona$(2), b, c, d\r
 358 GOTO 5\r
 359 \r
 360 CASE "stclear"\r
 361 b = VAL(sona$(2))\r
 362 IF b = 0 THEN b = 1\r
 363 stackl(b) = 0\r
 364 GOTO 5\r
 365 \r
 366 CASE "chklin"\r
 367 b = VAL(sona$(2))\r
 368 c = VAL(sona$(3))\r
 369 d = VAL(sona$(4))\r
 370 IF b = 0 THEN b = 1\r
 371 IF c = 0 THEN c = 1\r
 372 IF d = 0 THEN d = 1000\r
 373 \r
 374 FOR e = c TO d\r
 375 IF buff(b, e) > 0 THEN std cnum(buff(b, e))\r
 376 NEXT e\r
 377 GOTO 5\r
 378 \r
 379 CASE "stacksize"\r
 380 b = VAL(sona$(2))\r
 381 IF b = 0 THEN b = 1\r
 382 std cnum(stackl(b))\r
 383 GOTO 5\r
 384 \r
 385 CASE "b"\r
 386 boss\r
 387 conm "returning", 7\r
 388 GOTO 5\r
 389 \r
 390 CASE "filtor"\r
 391 b = VAL(sona$(2))\r
 392 FOR e = 1 TO stackl(b)\r
 393 FOR c = 3 TO mitus STEP 2\r
 394 gets stack(e, b), VAL(sona$(c)), f$\r
 395 cmp f$, sona$(c + 1), d\r
 396 IF d = 1 THEN\r
 397 std cnum(stack(e, b))\r
 398 GOTO 20\r
 399 END IF\r
 400 NEXT c\r
 401 20\r
 402 NEXT e\r
 403 GOTO 5\r
 404 \r
 405 CASE "disp"\r
 406 b = VAL(sona$(2))\r
 407 DIM tmp1(1 TO 100)\r
 408 DIM tmp2(1 TO 100)\r
 409 \r
 410 FOR d = 1 TO 100\r
 411 tmp2(d) = 0\r
 412 NEXT d\r
 413 d = 0\r
 414 \r
 415 FOR e = 3 TO mitus\r
 416 d = d + 1\r
 417 tmp1(d) = VAL(sona$(e))\r
 418 NEXT e\r
 419 \r
 420 FOR c = 1 TO stackl(b)\r
 421 FOR e = 1 TO d\r
 422 gets stack(c, b), tmp1(e), f$\r
 423 IF tmp2(e) < LEN(f$) THEN tmp2(e) = LEN(f$)\r
 424 NEXT e\r
 425 NEXT c\r
 426 \r
 427 FOR c = 1 TO stackl(b)\r
 428 g$ = ""\r
 429 FOR e = 1 TO d\r
 430 gets stack(c, b), tmp1(e), f$\r
 431 f$ = f$ + SPACE$(tmp2(e) - LEN(f$))\r
 432 g$ = g$ + f$ + " # "\r
 433 NEXT e\r
 434 conm g$, 10\r
 435 NEXT c\r
 436 \r
 437 ERASE tmp2\r
 438 ERASE tmp1\r
 439 GOTO 5\r
 440 \r
 441 CASE "filtand"\r
 442 b = VAL(sona$(2))\r
 443 FOR e = 1 TO stackl(b)\r
 444 FOR c = 3 TO mitus STEP 2\r
 445 gets stack(e, b), VAL(sona$(c)), f$\r
 446 cmp f$, sona$(c + 1), d\r
 447 IF d = 0 THEN GOTO 21\r
 448 NEXT c\r
 449 std cnum(stack(e, b))\r
 450 21\r
 451 NEXT e\r
 452 GOTO 5\r
 453 \r
 454 CASE "sort"\r
 455 b = VAL(sona$(2))\r
 456 c = VAL(sona$(3))\r
 457 sort b, c\r
 458 GOTO 5\r
 459 \r
 460 CASE "swap"\r
 461 b = VAL(sona$(2))\r
 462 c = stackl(b)\r
 463 FOR d = 1 TO c / 2\r
 464 SWAP stack(d, b), stack(c - d + 1, b)\r
 465 NEXT d\r
 466 GOTO 5\r
 467 \r
 468 CASE "ssort"\r
 469 b = VAL(sona$(2))\r
 470 c = VAL(sona$(3))\r
 471 IF b = 0 THEN b = 1\r
 472 IF c = 0 THEN c = 1\r
 473 ssort b, c\r
 474 GOTO 5\r
 475 \r
 476 CASE "memget"\r
 477 b = VAL(sona$(2))\r
 478 IF b = 0 THEN b = 1\r
 479 FOR c = 1 TO 5000\r
 480 IF bufu(c) = 0 THEN bufu(c) = 1: buf$(c) = "-": stack(b, 10) = c: GOTO 23\r
 481 NEXT c\r
 482 23\r
 483 IF stackl(10) < b THEN stackl(10) = b\r
 484 GOTO 5\r
 485 \r
 486 CASE "liststack"\r
 487 b = VAL(sona$(2))\r
 488 c = VAL(sona$(3))\r
 489 d = VAL(sona$(4))\r
 490 IF b = 0 THEN b = 1\r
 491 IF c = 0 THEN c = 1\r
 492 IF d = 0 THEN d = stackl(b)\r
 493 FOR e = c TO d\r
 494 std cnum(stack(e, b))\r
 495 NEXT e\r
 496 GOTO 5\r
 497 \r
 498 CASE "ask"\r
 499 b$ = sona$(2)\r
 500 IF b$ = "" THEN b$ = "input"\r
 501 c = VAL(sona$(3))\r
 502 d = VAL(sona$(4))\r
 503 e = VAL(sona$(5))\r
 504 box 5, 5, 75, 11\r
 505 LOCATE 7, 7\r
 506 PRINT b$\r
 507 LOCATE 9, 7\r
 508 INPUT "", f$\r
 509 putfs c, d, e, f$\r
 510 conm "'" + f$ + "' accepted", 7\r
 511 GOTO 5\r
 512 \r
 513 CASE "flnget"\r
 514 b = VAL(sona$(2))\r
 515 c = VAL(sona$(3))\r
 516 FOR d = 1 TO 1000\r
 517 IF buff(b, d) = -1 THEN\r
 518 stack(c, 10) = d\r
 519 IF stackl(10) < c THEN stackl(10) = c\r
 520 GOTO 24\r
 521 END IF\r
 522 NEXT d\r
 523 24\r
 524 GOTO 5\r
 525 \r
 526 END SELECT\r
 527 \r
 528 \r
 529 \r
 530 conm "Invalid command", 12\r
 531 5\r
 532 END SUB\r
 533 \r
 534 SUB cmp (a$, b$, r)\r
 535 IF a$ = b$ THEN r = 1 ELSE r = 0\r
 536 END SUB\r
 537 \r
 538 FUNCTION cnum$ (a)\r
 539 b$ = STR$(a)\r
 540 cnum$ = RIGHT$(b$, LEN(b$) - 1)\r
 541 END FUNCTION\r
 542 \r
 543 SUB conkey (a$)\r
 544 b$ = concmd$ + SPACE$(85)\r
 545 b$ = LEFT$(b$, 80)\r
 546 \r
 547 IF a$ = "va" THEN conx = conx - 1\r
 548 IF a$ = "pa" THEN conx = conx + 1\r
 549 IF a$ = "ul" THEN\r
 550 b$ = hist$(histk)\r
 551 histk = histk - 1\r
 552 IF histk < 1 THEN histk = 20\r
 553 END IF\r
 554 IF a$ = "al" THEN\r
 555 b$ = hist$(histk)\r
 556 histk = histk + 1\r
 557 IF histk > 20 THEN histk = 1\r
 558 END IF\r
 559 \r
 560 \r
 561 \r
 562 IF LEN(a$) = 1 THEN\r
 563 IF a$ = CHR$(13) THEN\r
 564 strip b$, c$\r
 565 histp = histp + 1\r
 566 IF histp > 20 THEN histp = 1\r
 567 histk = histp\r
 568 hist$(histp) = c$\r
 569 cmd c$\r
 570 b$ = ""\r
 571 conx = 1\r
 572 GOTO 4\r
 573 END IF\r
 574 \r
 575 IF a$ = CHR$(8) THEN\r
 576 IF conx > 1 THEN\r
 577 b$ = LEFT$(b$, conx - 2) + RIGHT$(b$, 81 - conx)\r
 578 conx = conx - 1\r
 579 END IF\r
 580 GOTO 4\r
 581 END IF\r
 582 \r
 583 b$ = LEFT$(b$, conx - 1) + a$ + RIGHT$(b$, 81 - conx)\r
 584 conx = conx + 1\r
 585 END IF\r
 586 4\r
 587 \r
 588 \r
 589 IF conx < 1 THEN conx = 1\r
 590 IF conx > 80 THEN conx = 80\r
 591 \r
 592 b$ = b$ + SPACE$(85)\r
 593 concmd$ = LEFT$(b$, 80)\r
 594 LOCATE 50, 1\r
 595 COLOR 15, 1\r
 596 PRINT concmd$;\r
 597 LOCATE 50, conx\r
 598 COLOR 0, 14\r
 599 PRINT RIGHT$(LEFT$(concmd$, conx), 1);\r
 600 \r
 601 \r
 602 END SUB\r
 603 \r
 604 SUB conm (d$, c)\r
 605 a$ = d$\r
 606 \r
 607 14\r
 608 IF LEN(a$) > 78 THEN\r
 609 b$ = LEFT$(a$, 78)\r
 610 conm b$, c\r
 611 a$ = "      >> " + RIGHT$(a$, LEN(a$) - 78)\r
 612 GOTO 14\r
 613 END IF\r
 614 \r
 615 \r
 616 b$ = a$ + SPACE$(80 - LEN(a$))\r
 617 con$(50) = b$\r
 618 conc(50) = c\r
 619 \r
 620 FOR a = 1 TO 49\r
 621 con$(a) = con$(a + 1)\r
 622 conc(a) = conc(a + 1)\r
 623 NEXT a\r
 624 \r
 625 FOR a = 1 TO 49\r
 626 LOCATE a, 1\r
 627 COLOR conc(a), 0\r
 628 PRINT con$(a)\r
 629 NEXT a\r
 630 \r
 631 END SUB\r
 632 \r
 633 SUB fload (a$, b, c, d)\r
 634 getfil h\r
 635 \r
 636 j = c\r
 637 l = 0\r
 638 \r
 639 OPEN a$ FOR INPUT AS #h\r
 640 12\r
 641 IF EOF(h) <> 0 THEN GOTO 13\r
 642 LINE INPUT #h, e$\r
 643 \r
 644 IF LEFT$(e$, 3) = "// " THEN\r
 645 conm e$, 10\r
 646 GOTO 12\r
 647 END IF\r
 648 IF e$ = SPACE$(LEN(e$)) THEN GOTO 12\r
 649 \r
 650 e$ = e$ + "|"\r
 651 l = l + 1\r
 652 h$ = ""\r
 653 i = d\r
 654 FOR f = 1 TO LEN(e$)\r
 655 g$ = RIGHT$(LEFT$(e$, f), 1)\r
 656 IF g$ = "|" THEN\r
 657   putfs b, j, i, h$\r
 658   h$ = ""\r
 659   g$ = ""\r
 660   i = i + 1\r
 661 END IF\r
 662 IF g$ = CHR$(9) THEN g$ = ""\r
 663 h$ = h$ + g$\r
 664 NEXT f\r
 665 \r
 666 j = j + 1\r
 667 GOTO 12\r
 668 13\r
 669 CLOSE #h\r
 670 \r
 671 \r
 672 opf(h) = 0\r
 673 \r
 674 k$ = "file: " + a$ + "  loaded." + STR$(l) + " lines in file"\r
 675 conm k$, 7\r
 676 END SUB\r
 677 \r
 678 SUB getfil (a)\r
 679 FOR b = 1 TO 30\r
 680 IF opf(b) = 0 THEN opf(b) = 1: a = b: GOTO 7\r
 681 NEXT b\r
 682 7\r
 683 END SUB\r
 684 \r
 685 SUB gets (l, s, a$)\r
 686 \r
 687 b = bufl(l, s)\r
 688 \r
 689 IF b = -1 THEN\r
 690 a$ = ""\r
 691 ELSE\r
 692 a$ = buf$(b)\r
 693 END IF\r
 694 END SUB\r
 695 \r
 696 SUB mkson (a$)\r
 697 \r
 698 mitus = 0\r
 699 \r
 700 d = 1\r
 701 FOR b = 1 TO LEN(a$)\r
 702 c$ = RIGHT$(LEFT$(a$, b), 1)\r
 703 IF c$ = " " THEN\r
 704 d = 1\r
 705 ELSE\r
 706 IF d = 1 THEN\r
 707 mitus = mitus + 1\r
 708 sona$(mitus) = ""\r
 709 d = 0\r
 710 END IF\r
 711 sona$(mitus) = sona$(mitus) + c$\r
 712 END IF\r
 713 NEXT b\r
 714 \r
 715 'conm "sonad_______", 10\r
 716 'FOR b = 1 TO mitus\r
 717 'conm sona$(b), 14\r
 718 'NEXT b\r
 719 \r
 720 FOR a = 1 TO mitus\r
 721 IF LEFT$(sona$(a), 2) = "|>" THEN\r
 722 IF sona$(a + 1) = "c" THEN stdl = 1\r
 723 IF sona$(a + 1) = "s" THEN stdl = 10 + VAL(sona$(a + 2))\r
 724 mitus = a - 1\r
 725 GOTO 15\r
 726 END IF\r
 727 IF LEFT$(sona$(a), 2) = "|@" THEN\r
 728 sona$(a) = cnum(stack(VAL(RIGHT$(sona$(a), LEN(sona$(a)) - 2)), 10))\r
 729 END IF\r
 730 NEXT a\r
 731 \r
 732 15\r
 733 FOR a = mitus + 1 TO 20\r
 734 sona$(a) = ""\r
 735 NEXT a\r
 736 END SUB\r
 737 \r
 738 SUB putfs (f, l, s, c$)\r
 739 \r
 740 'DIM SHARED buff(1 TO 30, 1 TO 1000)\r
 741 \r
 742 la = buff(f, l)\r
 743 \r
 744 IF la = -1 THEN\r
 745 FOR a = 1 TO 1000\r
 746 IF buflu(a) = 0 THEN la = a: GOTO 10\r
 747 NEXT a\r
 748 10\r
 749 END IF\r
 750 \r
 751 puts la, s, c$\r
 752 IF buflu(la) = 0 THEN buff(f, l) = -1 ELSE buff(f, l) = la\r
 753 END SUB\r
 754 \r
 755 SUB puts (l, s, a$)\r
 756 'PRINT l, s\r
 757 IF a$ = "|" THEN a$ = ""\r
 758 IF a$ = "||" THEN GOTO 11\r
 759 'conm a$, 13\r
 760 b = bufl(l, s)\r
 761 \r
 762 IF b = -1 THEN\r
 763 'DIM SHARED buf$(1 TO 10000)\r
 764 'DIM SHARED bufu(1 TO 10000)\r
 765 FOR c = 1 TO 10000\r
 766 IF bufu(c) = 0 THEN GOTO 6\r
 767 NEXT c\r
 768 6\r
 769 b = c\r
 770 bufu(b) = 1\r
 771 buflu(l) = buflu(l) + 1\r
 772 END IF\r
 773 \r
 774 strip a$, c$\r
 775 \r
 776 IF c$ = "" THEN\r
 777 bufu(b) = 0\r
 778 buf$(b) = ""\r
 779 bufl(l, s) = -1\r
 780 buflu(l) = buflu(l) - 1\r
 781 ELSE\r
 782 buf$(b) = c$\r
 783 bufl(l, s) = b\r
 784 END IF\r
 785 11\r
 786 END SUB\r
 787 \r
 788 SUB runf (a$)\r
 789 getfil h\r
 790 \r
 791 OPEN a$ FOR INPUT AS #h\r
 792 9\r
 793 IF EOF(h) <> 0 THEN GOTO 8\r
 794 LINE INPUT #h, b$\r
 795 cmd b$\r
 796 GOTO 9\r
 797 8\r
 798 CLOSE #h\r
 799 \r
 800 opf(h) = 0\r
 801 END SUB\r
 802 \r
 803 SUB sort (s, w)\r
 804 DIM tmp1(1 TO 10000)\r
 805 DIM tmp2(1 TO 10000)\r
 806 \r
 807 b = stackl(s)\r
 808 \r
 809 FOR a = 1 TO b\r
 810 gets stack(a, s), w, c$\r
 811 tmp1(a) = VAL(c$)\r
 812 tmp2(a) = a\r
 813 NEXT a\r
 814 \r
 815 d = 1\r
 816 FOR a = 1 TO b\r
 817 e = 32000\r
 818 \r
 819 FOR c = d TO b\r
 820 IF tmp1(c) < e THEN e = tmp1(c): f = c\r
 821 NEXT c\r
 822 \r
 823 SWAP tmp1(a), tmp1(f)\r
 824 SWAP tmp2(a), tmp2(f)\r
 825 d = d + 1\r
 826 NEXT a\r
 827 \r
 828 FOR a = 1 TO b\r
 829 stack(a, s) = tmp2(a)\r
 830 NEXT a\r
 831 \r
 832 END SUB\r
 833 \r
 834 SUB ssort (s, m)\r
 835 DIM tbti(1 TO 2000)\r
 836 DIM tbtp(1 TO 2000)\r
 837 DIM tbt$(1 TO 2000)\r
 838 \r
 839 FOR a = 1 TO stackl(s)\r
 840 gets stack(a, s), m, b$\r
 841 tbt$(a) = b$\r
 842 tbtp(a) = a\r
 843 NEXT a\r
 844 \r
 845 b = stackl(s)\r
 846 FOR a = 1 TO stackl(s)\r
 847 d$ = tbt$(1)\r
 848 e = 1\r
 849 f = ASC(LEFT$(d$, 1))\r
 850 FOR c = 2 TO b\r
 851 IF ASC(LEFT$(tbt$(c), 1)) = f THEN\r
 852 IF d$ <> tbt$(c) THEN\r
 853 g$ = d$ + CHR$(0)\r
 854 h$ = tbt$(c) + CHR$(0)\r
 855 i = LEN(g$)\r
 856 IF LEN(h$) > i THEN i = LEN(h$)\r
 857 FOR j = 1 TO i\r
 858 k = ASC(RIGHT$(LEFT$(g$, j), 1))\r
 859 l = ASC(RIGHT$(LEFT$(h$, j), 1))\r
 860 IF k < l THEN GOTO 22\r
 861 IF l < k THEN e = c: d$ = tbt$(c): f = ASC(LEFT$(d$, 1)): GOTO 22\r
 862 NEXT j\r
 863 END IF\r
 864 END IF\r
 865 IF ASC(LEFT$(tbt$(c), 1)) < f THEN f = ASC(LEFT$(tbt$(c), 1)): e = c: d$ = tbt$(c)\r
 866 22\r
 867 NEXT c\r
 868 \r
 869 tbti(a) = tbtp(e)\r
 870 tbt$(e) = tbt$(b)\r
 871 tbtp(e) = tbtp(b)\r
 872 b = b - 1\r
 873 NEXT a\r
 874 \r
 875 FOR a = 1 TO stackl(s)\r
 876 stack(a, s) = tbti(a)\r
 877 NEXT a\r
 878 \r
 879 conm "done", 7\r
 880 END SUB\r
 881 \r
 882 SUB start\r
 883 WIDTH 80, 50\r
 884 VIEW PRINT 1 TO 50\r
 885 CLS\r
 886 conx = 1\r
 887 histp = 1\r
 888 histk = 1\r
 889 stdl = 1\r
 890 \r
 891 conm "DDBASE, (Dos Data BASE) 0.0", 7\r
 892 conm "Copyright Svjatoslav Agejenko. All Rights Reserved.", 7\r
 893 conm "starting...", 7\r
 894 FOR a = 1 TO 5000\r
 895 bufu(a) = 0\r
 896 buf$(a) = ""\r
 897 NEXT a\r
 898 \r
 899 FOR a = 1 TO 30\r
 900 FOR b = 1 TO 1000\r
 901 bufl(b, a) = -1\r
 902 buff(a, b) = -1\r
 903 NEXT b\r
 904 opf(a) = 0\r
 905 NEXT a\r
 906 \r
 907 FOR a = 1 TO 1000\r
 908 buflu(a) = 0\r
 909 NEXT a\r
 910 \r
 911 FOR a = 1 TO 10\r
 912 stackl(a) = 0\r
 913 NEXT a\r
 914 \r
 915 \r
 916 a$ = "runf auto.scr"\r
 917 FOR b = 1 TO LEN(a$)\r
 918 c$ = RIGHT$(LEFT$(a$, b), 1)\r
 919 conkey c$\r
 920 NEXT b\r
 921 conkey CHR$(13)\r
 922 \r
 923 END SUB\r
 924 \r
 925 SUB std (a$)\r
 926 'conm a$, 2\r
 927 \r
 928 SELECT CASE stdl\r
 929 CASE 1\r
 930 conm a$, 10\r
 931 CASE 11 TO 20\r
 932 b = stdl - 10\r
 933 stackl(b) = stackl(b) + 1\r
 934 stack(stackl(b), b) = VAL(a$)\r
 935 \r
 936 c$ = a$ + " > " + cnum(stackl(b)) + " ! " + cnum(b)\r
 937 END SELECT\r
 938 \r
 939 \r
 940 \r
 941 \r
 942 END SUB\r
 943 \r
 944 SUB strip (a$, b$)\r
 945 b$ = a$\r
 946 2\r
 947 IF LEFT$(b$, 1) = " " THEN b$ = RIGHT$(b$, LEN(b$) - 1): GOTO 2\r
 948 3\r
 949 IF RIGHT$(b$, 1) = " " THEN b$ = LEFT$(b$, LEN(b$) - 1): GOTO 3\r
 950 END SUB\r
 951 \r
 952 SUB title (a$)\r
 953 conm " ", 10\r
 954 conm "================> " + a$ + " <===============", 7\r
 955 \r
 956 \r
 957 \r
 958 END SUB\r
 959 \r