Программирование на Бейсике (исходники разных программ на нём)

[StoYazykov]

Все, что касается программирования на Бейсике (предпочтительно QBasic / QuickBASIC).
Исходники разных Бейсиковских программ

ВенераОС: viewtopic.php?f=21&t=1911&start=15&sid=992f1875e162b946a0c95eece6a0f199#p27156

[StoYazykov]

Оболочка для TASM. Кладется в одну папку с ним. Для справки напишите ;help

Код: Выделить всё

SCREEN 0
COLOR 15, 1
CLS
typ = 0
filename$ = "untitled.asm"
GOSUB refn
COLOR 10
PRINT "For help type ";
COLOR 12
PRINT "` ;help '"
DO
a$ = INKEY$
IF a$ = CHR$(9) THEN GOSUB writefile
COLOR 15
PRINT "TASM> ";
COLOR 7
LINE INPUT "", tasmcom$
IF LCASE$(tasmcom$) = ";help" THEN
PRINT " ;list  ==  view code"
PRINT " ;com   ==  compile file as *.com"
PRINT " ;exe   ==  compile file as *.exe"
PRINT " ;help  ==  help (current dialog)"
PRINT " ;exit  ==  exit"
PRINT " ;start ==  compile and start program"
PRINT " ;clean ==  clean file"
PRINT " ;open  ==  open file"
PRINT " ;new   ==  make new file"
END IF
IF LCASE$(tasmcom$) = ";list" THEN
OPEN filename$ FOR INPUT AS #2
DO WHILE NOT EOF(2)
LINE INPUT #2, listcode$
PRINT listcode$
LOOP
CLOSE #2
END IF

IF LCASE$(tasmcom$) = ";open" THEN INPUT "Filename for open> ", filename$: GOSUB refn
IF LCASE$(tasmcom$) = ";new" THEN INPUT "Filename for new> ", filename$: GOSUB refn
IF LCASE$(tasmcom$) = ";exit" THEN END
IF LCASE$(tasmcom$) = ";com" THEN typ = 0: PRINT "File type= *.com"
IF LCASE$(tasmcom$) = ";exe" THEN typ = 1: PRINT "File type= *.exe"
IF LCASE$(tasmcom$) = ";start" THEN
GOSUB writefile
SHELL "TASM ASE.asm"
IF typ = 0 THEN SHELL "tlink.exe ase.obj /t" ELSE SHELL "tlink.exe ase.obj"
END IF
GOSUB writefile
LOOP

writefile:
IF LCASE$(tasmcom$) = ";clean" THEN OPEN filename$ FOR OUTPUT AS #1: PRINT "(Cleaned ok)" ELSE OPEN filename$ FOR APPEND AS #1
PRINT #1, tasmcom$
CLOSE #1
RETURN

refn:
CLS
COLOR 0, 7
LOCATE 1, 30
PRINT filename$
COLOR , 1
LOCATE 3
RETURN

[StoYazykov]

Графический редактор.
==========
Управление:

Space | поставить точку
S | выбор цвета
M | закрасить замкнутую область
Esc | выход

==========

Сохраняется автоматически каждый шаг.

Код: Выделить всё

DECLARE SUB drawlines ()
DECLARE SUB Cur (cux!, cuy!, colr!)
DIM image(16, 15)
DIM icol(16, 15)
SCREEN 12
1
CLS
INPUT "1) Make new file or rewrite old  2) Open aldready exist file > ", mkf$
IF VAL(mkf$) <= 0 OR VAL(mkf$) > 2 THEN 1 ELSE mknewFyn = VAL(mkf$)
INPUT "File for draw"; filename$
IF filename$ = " " OR filename$ = "" THEN GOTO 1
IF mknewFyn = 1 THEN OPEN filename$ FOR OUTPUT AS #5
CLOSE #5
IF mknewFyn = 2 THEN GOTO Interface: : : : :
Interface:
CLS
PAINT (1, 1), &H0
LOCATE 20.52, 50
PRINT "Old-DOS Draw"
drawlines
ON ERROR GOTO 1
OPEN filename$ FOR INPUT AS #1
DO WHILE NOT EOF(1)
k$ = INKEY$
FOR io = 1 TO 15
  INPUT #1, icol(io, io), ix, iy, pai
  INPUT #1, icol(16, io), ix, iy, pai
  IF pai = 1 THEN PAINT (ix + 5, iy + 5), icol(io, io): GOTO 55
  LINE (ix, iy)-(ix + 20, iy + 20), icol(io, io), BF
NEXT io
55
LOOP
CLOSE #1
scol = 15
cx = 3
cy = 3
Cur cx, cy, 15
scol = 15
FOR i = 0 TO 15
IF i < 10 THEN LOCATE 2 + i, 52: COLOR i: PRINT " "; i; CHR$(219); CHR$(219); CHR$(219) ELSE LOCATE 2 + i, 52: COLOR i: PRINT i; CHR$(219); CHR$(219); CHR$(219)
NEXT i
5252 :
LINE (405, 20)-(480.2, 285.2), 15, B
LINE (406, 21)-(479.2, 286.2), 7, B
LINE (407, 22)-(478.2, 287.2), 8, B
LOCATE 1, 50
COLOR scol
PRINT "Current color:"; scol
COLOR 15
LOCATE 25, 5
PRINT "X="; ; cx; "    Y="; cy
LINE (10, 375)-(180, 405), 15, B
LINE (11, 376)-(179, 406), 7, B
LINE (12, 377)-(178, 407), 8, B
drawlines
Cur cx, cy, 13
DO
k$ = INKEY$
IF k$ = "M" OR k$ = "m" THEN
PAINT (cx + 10, cy + 10), scol
64 ranload = INT(RND * 30)
  IF ranload <= 0 THEN 64
  OPEN filename$ FOR APPEND AS #ranload
  FOR io = 1 TO 15
  image(io, io) = POINT(cx + 10, cy + 10)
  image(16, io) = POINT(cx + 10, cy + 10)
  WRITE #ranload, image(io, io), cx, cy, 1
  WRITE #ranload, image(16, io), cx, cy, 1
  PAINT (cx + 10, cy + 10), scol
  NEXT io
  CLOSE #ranload
  drawlines
END IF
IF k$ = " " THEN
65
  ranload = INT(RND * 30)
  IF ranload <= 0 THEN 65
  OPEN filename$ FOR APPEND AS #ranload
  FOR io = 1 TO 15
  image(io, io) = POINT(cx + 10, cy + 10)
  image(16, io) = POINT(cx + 10, cy + 10)
  WRITE #ranload, image(io, io), cx, cy, 0
  WRITE #ranload, image(16, io), cx, cy, 0
  LINE (cx, cy)-(cx + 20, cy + 20), scol, BF
  NEXT io
  CLOSE #ranload
image(mv, mg) = scol
END IF
343
IF k$ = "S" OR k$ = "s" THEN
FOR i = 0 TO 15
IF i < 10 THEN LOCATE 2 + i, 52: COLOR i: PRINT " "; i; CHR$(219); CHR$(219); CHR$(219) ELSE LOCATE 2 + i, 52: COLOR i: PRINT i; CHR$(219); CHR$(219); CHR$(219)
NEXT i
FOR m = 2 TO 5 STEP 0
526 k$ = INKEY$
  IF k$ = CHR$(27) THEN END
  LOCATE 20, 52
  locate 20,51
  input "Color> ",scol
  IF scol > 15 AND scol < 0 THEN 526
  IF scol <= 15 AND scol >= 0 THEN 525
NEXT m
525 LOCATE 20, 51: PRINT "                          "
END IF
IF k$ = CHR$(27) THEN END
IF k$ = CHR$(0) + CHR$(77) THEN GOTO Right
IF k$ = CHR$(0) + CHR$(75) THEN GOTO Left
IF k$ = CHR$(0) + CHR$(72) THEN GOTO Up
IF k$ = CHR$(0) + CHR$(80) THEN GOTO DowN
LOOP
Right:
push = POINT(cx + 10, cy + 10)
IF cx > 276 THEN GOTO 5252
Cur cx, cy, push
cx = cx + 20
Cur cx, cy, 12
GOTO 5252
Left:
push = POINT(cx + 10, cy + 10)
IF cx < 5 THEN GOTO 5252
Cur cx, cy, push
cx = cx - 20
Cur cx, cy, 12
GOTO 5252
Up:
push = POINT(cx + 10, cy + 10)
IF cy < 5 THEN GOTO 5252
Cur cx, cy, push
cy = cy - 20
Cur cx, cy, 12
GOTO 5252
DowN:
push = POINT(cx + 10, cy + 10)
IF cy > 283 THEN GOTO 5252
Cur cx, cy, push
cy = cy + 20
Cur cx, cy, 4
GOTO 5252

SUB Cur (cux, cuy, colr)
LINE (cux + 1, cuy + 1)-(cux + 19, cuy + 19), colr, B
END SUB

SUB drawlines
LINE (0, 0)-(310 - 5, 325), 15, B
LINE (1, 1)-(309 - 5, 319 + 5), 7, B
LINE (2, 2)-(308 - 5, 318 + 5), 8, B
END SUB

[yevrowl]

Оболочка для TASM. Кладется в одну папку с ним. Для справки напишите ;help

Спасибо, но с каким именно? http://old-dos.ru/index.php?page=search&string=tasm

[Sergey Dobryak]

https://qb45.org/index.php
https://qb64.com/samples.HTML
http://www.antonis.de/qbdown/qbspiele.htm

https://www.glorioustrainwrecks.com/mir ... qbasic.htm

http://www.petesqbsite.com/index.php

[yevrowl]

https://qb64.com/samples.HTML

404, файл не найден.

[uav]

https://qb64.com/samples.html

Регистр букв...

[yevrowl]

Ещё три:

http://www.qbasic.net/

http://www.quitebasic.com/

http://nordman.tripod.com/qbasic.html

[Sergey Dobryak]

"Return to Marchfeld" - 3D-Egoshooter у кого запускается?
http://www.antonis.de/qbdown/qbspiele.htm
Rtm.zip

[uav]

Н-да...
Не сразу догадался, что в начале игры нужно несколько раз нажать Escape (это чтобы она вообще запустилась).
Во-вторых, под чистым DOS'ом на реальном железе не пошла. Как и в DOSBox.
А вот в DOS-окне Windows 98 пошла нормально.

[Sergey Dobryak]

Н-да...
Не сразу догадался, что в начале игры нужно несколько раз нажать Escape (это чтобы она вообще запустилась).
Во-вторых, под чистым DOS'ом на реальном железе не пошла. Как и в DOSBox.
А вот в DOS-окне Windows 98 пошла нормально.

Я догадался быстро.
Значит не судьба посмотреть.
Думал, если запущу с ключом easy, то покатит. Оказывается без разницы.
Запускал на 486dx4-120 , Pentium1-133mhz

Зачем так делать? (({(

[uav]

Sergey Dobryak, вот эта версия работает лучше:
https://marioslab.io/projects/return-to ... ld/rtm.zip
Пошла и в DOSBox (циклы нужно тысяч на 100 вывести), и на реальном железе.

[Sergey Dobryak]

Sergey Dobryak, вот эта версия работает лучше:
https://marioslab.io/projects/return-to ... ld/rtm.zip
Пошла и в DOSBox (циклы нужно тысяч на 100 вывести), и на реальном железе.

Спасибо!
Идет. Правда только сд.
Я как-то хотел переделать под ega в2015году, но не получилось.

[Sergey Dobryak]

Ziel - добрый квест. На 386й только так идет, хорошо.

[Sergey Dobryak]

https://qb64.com/samples.HTML

404, файл не найден.

Видимо закрылся. На след день.