database/ddbase6.bas

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