diff --git a/.gitignore b/.gitignore index 6ad6acd..694fd07 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,6 @@ .vscode *.sys *.lst -*.bak \ No newline at end of file +*.bak +cpm*.dsk +release/ \ No newline at end of file diff --git a/bin/cpm.bin b/bin/cpm.bin deleted file mode 100644 index f264a3b..0000000 Binary files a/bin/cpm.bin and /dev/null differ diff --git a/bootstrap/crt.inc b/bootstrap/crt.inc index 4be017a..4e99d10 100755 --- a/bootstrap/crt.inc +++ b/bootstrap/crt.inc @@ -35,6 +35,7 @@ mos_fclose: equ $0b mos_fgetc: equ $0c mos_fputc: equ $0d mos_feof: equ $0e +mos_setint: equ $14 mos_uopen: equ $15 mos_uclose: equ $16 mos_ugetc: equ $17 @@ -42,7 +43,6 @@ mos_uputc: equ $18 mos_fread: equ $1a mos_fwrite: equ $1b mos_flseek: equ $1c - ;; File modes fa_read: equ $01 fa_write: equ $02 diff --git a/bootstrap/drive_emu.inc b/bootstrap/drive_emu.inc index 920d22c..42c1b0c 100755 --- a/bootstrap/drive_emu.inc +++ b/bootstrap/drive_emu.inc @@ -110,17 +110,16 @@ fs_init: ld c, 0 MOSCALL mos_fclose + MOSCALL mos_sysvars + xor a + ld (ix+$28), a + ld ix, (sys_ix) + ld hl, drive ld c, fa_read+fa_write MOSCALL mos_fopen ld (f_handle), a or a - push af - MOSCALL mos_sysvars - xor a - ld (ix+$28), a - ld ix, (sys_ix) - pop af ret fs_seek: diff --git a/bootstrap/terminal.inc b/bootstrap/terminal.inc index 01f5354..083d259 100755 --- a/bootstrap/terminal.inc +++ b/bootstrap/terminal.inc @@ -24,7 +24,7 @@ _term_init: ld a, 7 out0 (REG_FTC), a ; Disable fifo - ld a, 0 + xor a out0 (REG_IER), a ; Disable ints @wait: @@ -36,7 +36,7 @@ _term_init: ret serial_cfg: - dl 115200 + dl 57600 db 8 db 1 db 0 @@ -45,6 +45,9 @@ serial_cfg: vdu_init: db 23, 0, 255 ; Switch to terminal emulation + db "CP/M to MOS gate v.1.1", 13, 10 + db "2023 (c) Aleksandr Sharikhin", 13, 10 + db 13,10 init_end: @@ -55,21 +58,25 @@ _ser_out: ld a, c out0 ($D0), a + xor a ret.lil _ser_in: - in0 a, ($D5) + in0 a, ($d5) and UART_LSR_RDY jr z, _ser_in + in0 a, ($d0) + ret.lil -_ser_status: - in0 a, ($D5) +_ser_status: + in0 a, ($d5) and UART_LSR_RDY ret.lil z ld a, $ff + or a ret.lil _term_out: @@ -121,3 +128,6 @@ _tty_status: ret.lil z ld a, $ff ret.lil + + + diff --git a/disks/build.sh b/disks/build.sh new file mode 100755 index 0000000..c169f3f --- /dev/null +++ b/disks/build.sh @@ -0,0 +1,12 @@ +#!/bin/bash -e + +rm -rf cpm*.dsk +for pth in images/* +do + drive="${pth: -1}" + image_name="cpm$drive.dsk" + cp template.dsk $image_name + echo "Working with drive image: $image_name" + cpmcp -fnihirash $image_name $pth/*.* 0: + echo "Image prepared" +done \ No newline at end of file diff --git a/disks/cpma.dsk b/disks/cpma.dsk deleted file mode 100644 index 2912e0d..0000000 Binary files a/disks/cpma.dsk and /dev/null differ diff --git a/disks/cpmb.dsk b/disks/cpmb.dsk deleted file mode 100644 index bc132f0..0000000 Binary files a/disks/cpmb.dsk and /dev/null differ diff --git a/disks/cpmc.dsk b/disks/cpmc.dsk deleted file mode 100644 index a5f3c0d..0000000 Binary files a/disks/cpmc.dsk and /dev/null differ diff --git a/disks/cpmd.dsk b/disks/cpmd.dsk deleted file mode 100644 index b21a8e4..0000000 --- a/disks/cpmd.dsk +++ /dev/null @@ -1 +0,0 @@ -ееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееее \ No newline at end of file diff --git a/disks/images/a/ASM.COM b/disks/images/a/ASM.COM new file mode 100644 index 0000000..a63e5ae Binary files /dev/null and b/disks/images/a/ASM.COM differ diff --git a/disks/images/a/DDT.COM b/disks/images/a/DDT.COM new file mode 100644 index 0000000..70e4ebf Binary files /dev/null and b/disks/images/a/DDT.COM differ diff --git a/disks/images/a/DUMP.COM b/disks/images/a/DUMP.COM new file mode 100644 index 0000000..03a77c3 Binary files /dev/null and b/disks/images/a/DUMP.COM differ diff --git a/disks/images/a/ED.COM b/disks/images/a/ED.COM new file mode 100644 index 0000000..a0f0f54 Binary files /dev/null and b/disks/images/a/ED.COM differ diff --git a/disks/images/a/LOAD.COM b/disks/images/a/LOAD.COM new file mode 100644 index 0000000..b9601e0 Binary files /dev/null and b/disks/images/a/LOAD.COM differ diff --git a/disks/images/a/PIP.COM b/disks/images/a/PIP.COM new file mode 100644 index 0000000..4b2ce4b Binary files /dev/null and b/disks/images/a/PIP.COM differ diff --git a/disks/images/a/STAT.COM b/disks/images/a/STAT.COM new file mode 100644 index 0000000..1de359f Binary files /dev/null and b/disks/images/a/STAT.COM differ diff --git a/disks/images/a/SUBMIT.COM b/disks/images/a/SUBMIT.COM new file mode 100644 index 0000000..2e78882 Binary files /dev/null and b/disks/images/a/SUBMIT.COM differ diff --git a/disks/images/a/XSUB.COM b/disks/images/a/XSUB.COM new file mode 100644 index 0000000..15e86ab Binary files /dev/null and b/disks/images/a/XSUB.COM differ diff --git a/disks/images/a/arc.com b/disks/images/a/arc.com new file mode 100644 index 0000000..302fd05 Binary files /dev/null and b/disks/images/a/arc.com differ diff --git a/disks/images/a/arcsq.com b/disks/images/a/arcsq.com new file mode 100644 index 0000000..a9601f6 Binary files /dev/null and b/disks/images/a/arcsq.com differ diff --git a/disks/images/a/ark.com b/disks/images/a/ark.com new file mode 100644 index 0000000..cfc2373 Binary files /dev/null and b/disks/images/a/ark.com differ diff --git a/disks/images/a/ccploc.com b/disks/images/a/ccploc.com new file mode 100644 index 0000000..8970407 Binary files /dev/null and b/disks/images/a/ccploc.com differ diff --git a/disks/images/a/cpmstat.com b/disks/images/a/cpmstat.com new file mode 100644 index 0000000..903b11c Binary files /dev/null and b/disks/images/a/cpmstat.com differ diff --git a/disks/images/a/cpmunarj.com b/disks/images/a/cpmunarj.com new file mode 100644 index 0000000..ba56e56 Binary files /dev/null and b/disks/images/a/cpmunarj.com differ diff --git a/disks/images/a/crck.com b/disks/images/a/crck.com new file mode 100644 index 0000000..94ed532 Binary files /dev/null and b/disks/images/a/crck.com differ diff --git a/disks/images/a/crunch.com b/disks/images/a/crunch.com new file mode 100644 index 0000000..d3a121a Binary files /dev/null and b/disks/images/a/crunch.com differ diff --git a/disks/images/a/fm.com b/disks/images/a/fm.com new file mode 100644 index 0000000..4420bbc Binary files /dev/null and b/disks/images/a/fm.com differ diff --git a/disks/images/a/kermit.com b/disks/images/a/kermit.com new file mode 100644 index 0000000..b24df27 Binary files /dev/null and b/disks/images/a/kermit.com differ diff --git a/disks/images/a/kermit.ini b/disks/images/a/kermit.ini new file mode 100644 index 0000000..df02632 --- /dev/null +++ b/disks/images/a/kermit.ini @@ -0,0 +1,2 @@ +SET PORT TTY +SET TERMINAL OFF \ No newline at end of file diff --git a/disks/images/a/lbrext.com b/disks/images/a/lbrext.com new file mode 100644 index 0000000..d92f111 Binary files /dev/null and b/disks/images/a/lbrext.com differ diff --git a/disks/images/a/ldir.com b/disks/images/a/ldir.com new file mode 100644 index 0000000..763f2a8 Binary files /dev/null and b/disks/images/a/ldir.com differ diff --git a/disks/images/a/lu.com b/disks/images/a/lu.com new file mode 100644 index 0000000..80be217 Binary files /dev/null and b/disks/images/a/lu.com differ diff --git a/disks/images/a/m80.com b/disks/images/a/m80.com new file mode 100644 index 0000000..d546065 Binary files /dev/null and b/disks/images/a/m80.com differ diff --git a/disks/images/a/mload.com b/disks/images/a/mload.com new file mode 100644 index 0000000..786f678 Binary files /dev/null and b/disks/images/a/mload.com differ diff --git a/disks/images/a/nulu152.com b/disks/images/a/nulu152.com new file mode 100644 index 0000000..5b136b2 Binary files /dev/null and b/disks/images/a/nulu152.com differ diff --git a/disks/images/a/pmarc.com b/disks/images/a/pmarc.com new file mode 100644 index 0000000..2a266fd Binary files /dev/null and b/disks/images/a/pmarc.com differ diff --git a/disks/images/a/pmext.com b/disks/images/a/pmext.com new file mode 100644 index 0000000..abe8d17 Binary files /dev/null and b/disks/images/a/pmext.com differ diff --git a/disks/images/a/pmset.com b/disks/images/a/pmset.com new file mode 100644 index 0000000..16bfeae Binary files /dev/null and b/disks/images/a/pmset.com differ diff --git a/disks/images/a/relhex.com b/disks/images/a/relhex.com new file mode 100644 index 0000000..680fa30 Binary files /dev/null and b/disks/images/a/relhex.com differ diff --git a/disks/images/a/te.com b/disks/images/a/te.com new file mode 100644 index 0000000..2137c8c Binary files /dev/null and b/disks/images/a/te.com differ diff --git a/disks/images/a/unarc.com b/disks/images/a/unarc.com new file mode 100644 index 0000000..8b44fa9 Binary files /dev/null and b/disks/images/a/unarc.com differ diff --git a/disks/images/a/uncr.com b/disks/images/a/uncr.com new file mode 100644 index 0000000..a446322 Binary files /dev/null and b/disks/images/a/uncr.com differ diff --git a/disks/images/a/uncrlzw2.com b/disks/images/a/uncrlzw2.com new file mode 100644 index 0000000..b4c5c9d Binary files /dev/null and b/disks/images/a/uncrlzw2.com differ diff --git a/disks/images/a/uncrunch.com b/disks/images/a/uncrunch.com new file mode 100644 index 0000000..0dfe894 Binary files /dev/null and b/disks/images/a/uncrunch.com differ diff --git a/disks/images/a/unzip.com b/disks/images/a/unzip.com new file mode 100644 index 0000000..b231bf4 Binary files /dev/null and b/disks/images/a/unzip.com differ diff --git a/disks/images/a/usq.com b/disks/images/a/usq.com new file mode 100644 index 0000000..eee4167 Binary files /dev/null and b/disks/images/a/usq.com differ diff --git a/disks/images/b/BACCRRT.ASC b/disks/images/b/BACCRRT.ASC new file mode 100644 index 0000000..1316a9c --- /dev/null +++ b/disks/images/b/BACCRRT.ASC @@ -0,0 +1,156 @@ +100 REM (SOURCE UNKNOWN) EDITED SLIGHTLY BY D. KURLAND 11/6/75 +110 PRINT "WELCOME TO CASINO UNIVAC 1108" +120 PRINT "THE GAME IS BACCARAT" +130 H=0 +140 GOSUB 1400 +150 DIM A(10),C(10) +160 PRINT "ARE YOU READY"; +170 INPUT X$ +180 IF X$="NO" OR X$="N" THEN 1390 +190 PRINT "WAGER"; +200 D=0 +210 E=0 +220 INPUT G +230 IF G>100000! THEN 1370 +240 IF G>0 THEN 270 +250 PRINT "HA!HA!, VERY FUNNY!!" +260 GOTO 190 +270 B=1 +280 GOTO 740 +290 A(B)=INT(RND(1)*52)+1 +300 C(B)=A(B)-13*INT(A(B)/13) +310 IF C(B)=0 THEN 600 +320 ON C(B)GOTO330,350,370,390,410,430,450,470,490,510,540,570 +330 PRINT "ACE "; +340 GOTO 620 +350 PRINT "DEUCE "; +360 GOTO 620 +370 PRINT "THREE "; +380 GOTO 620 +390 PRINT "FOUR "; +400 GOTO 620 +410 PRINT "FIVE "; +420 GOTO 620 +430 PRINT "SIX "; +440 GOTO 620 +450 PRINT "SEVEN "; +460 GOTO 620 +470 PRINT "EIGHT "; +480 GOTO 620 +490 PRINT "NINE "; +500 GOTO 620 +510 PRINT "TEN "; +520 C(B)=0 +530 GOTO 620 +540 PRINT "JACK "; +550 C(B)=0 +560 GOTO 620 +570 PRINT "QUEEN "; +580 C(B)=0 +590 GOTO 620 +600 PRINT "KING "; +610 C(B)=0 +620 IF INT(A(B)/13)<>A(B)/13 THEN 640 +630 ON A(B)/13 GOTO 660,680,700,720 +640 IF INT(A(B)/13)=0 THEN 660 +650 ON INT(A(B)/13)GOTO 680,700,720 +660 PRINT "OF CLUBS" +670 RETURN +680 PRINT "OF DIAMONDS" +690 RETURN +700 PRINT "OF SPADES" +710 RETURN +720 PRINT "OF HEARTS" +730 RETURN +740 PRINT "YOUR FIRST CARD IS A "; +750 GOSUB 290 +760 GOSUB 1310 +770 PRINT "YOUR NEXT CARD IS A "; +780 GOSUB 290 +790 GOSUB 1310 +800 PRINT "DO YOU WANT A CARD"; +810 INPUT J$ +820 IF J$="YES" OR J$="Y" THEN 870 +830 C(3)=0 +840 D=D+C(B) +850 B=B+1 +860 GOTO 900 +870 PRINT "THE CARD IS A "; +880 GOSUB290 +890 GOSUB 1310 +900 PRINT "MY FIRST CARD IS A "; +910 GOSUB 290 +920 GOSUB 1340 +930 PRINT "MY NEXT CARD IS A "; +940 GOSUB 290 +950 GOSUB 1340 +960 IF E<10 THEN 990 +970 E=E-10 +980 GOTO 960 +990 IF E<6 THEN 1030 +1000 PRINT "I DO NOT WANT A CARD" +1010 C(6)=0 +1020 GOTO 1060 +1030 PRINT "I TAKE CARD" +1040 PRINT "THE CARD IS A "; +1050 GOSUB 290 +1060 E=E+C(6) +1070 IF D<10 THEN 1100 +1080 D=D-10 +1090 GOTO 1070 +1100 PRINT "YOUR TOTAL IS";D +1110 IF E<10 THEN 1140 +1120 E=E-10 +1130 GOTO 1110 +1140 PRINT "MY TOTAL IS ";E +1150 IF D=E THEN 1590 +1160 IF D>E THEN 1200 +1170 PRINT "I WIN $"G +1180 G=-G +1190 GOTO 1210 +1200 PRINT "YOU WIN $";G +1210 H=H+G +1220 IF H>0 THEN 1290 +1230 IF H=0 THEN 1610 +1240 PRINT "YOU OWE ME $";-H +1250 PRINT "DO YOU WANT TO TRY AGAIN"; +1260 INPUT K$ +1270 IF K$="NO" OR K$="N" THEN 1390 +1280 GOTO 190 +1290 PRINT "I.O.U. $";H +1300 GOTO 1250 +1310 D=D+C(B) +1320 B=B+1 +1330 RETURN +1340 E=E+C(B) +1350 B=B+1 +1360 RETURN +1370 PRINT "HOUSE LIMIT IS $100000" +1380 GOTO190 +1390 STOP +1400 PRINT "DO YOU WANT THE RULES OF THE GAME"; +1410 INPUT I$ +1420 IF I$="NO" OR I$="N" THEN RETURN +1430 PRINT "* OFFICIAL RULES FOR THE GAME OF BACCARAT *" +1440 PRINT "THE COMPUTER IS SHUFFLING SIX DECKS OF CARDS" +1450 PRINT "TOGETHER. THE RULES ARE AS FOLLOWS: THE OBJECT" +1460 PRINT "IS TO BE AS CLOSE TO POSSIBLE TO NINE IN TWO" +1470 PRINT "OR THREE CARDS, FACE CARDS AND TENS COUNT ZERO" +1480 PRINT "ACES COUNT AS ONE EACH,ALL OTHER CARDS COUNT" +1490 PRINT "THEIR INDEX VALUE. WHEN THE TOTAL IS OVER TEN" +1500 PRINT "THE TENS UNIT IS DROPPED. EXAMPLE: A SEVEN AND" +1510 PRINT "A SIX TOTALING THIRTEEN COUNT AS THREE. THE" +1520 PRINT "PLAYER WITH THE HIGHER TOTAL WINS. IN CASE OF" +1530 PRINT "A TIE THE COMPUTER WINS. " +1540 PRINT "DO YOU UNDERSTAND THE RULES"; +1550 INPUT O$ +1560 IF O$="YES" OR O$="Y" THEN RETURN +1570 PRINT "TOUGH LUCK" +1580 RETURN +1590 PRINT "IT IS A TIE. THE COMPUTER WINS!" +1600 GOTO 1170 +1610 PRINT "YOU ARE EVEN-UP !!" +1620 GOTO1250 +1630 END +N +1590 PRINT "I \ No newline at end of file diff --git a/disks/images/b/BASEBALL.ASC b/disks/images/b/BASEBALL.ASC new file mode 100644 index 0000000..627aa29 --- /dev/null +++ b/disks/images/b/BASEBALL.ASC @@ -0,0 +1,555 @@ +100 REM BASEBALL SIMULATION PROGRAM +110 REM WRITTEN BY JOEL LIND & KEN BIRKMAN - NYU - JULY 1973 +120 REM STOLEN AND ENHANCED DECEMBER 1973 BY R. D. KURLAND - NYU +130 DIM B(7),P$(9),W$(7),J$(8),K$(4) +140 FOR I=1 TO 7: B(I)=0:NEXT +150 B=0:T9=0:R9=0:S=0:O=0:B1=0:B2=0:T=0 +160 Z1=1:Z2=1 +170 PRINT "WELCOME TO EBBETT'S FIELD" +180 PRINT "WHAT DO YOU WANT TO CALL YOUR TEAM"; +190 INPUT A$ +200 FOR I=1 TO 7:READ W$(I):NEXT +210 FOR I=1 TO 9:READ P$(I):NEXT +220 FOR I=1 TO 4:READ K$(I):NEXT +230 FOR I=1 TO 8:READ J$(I):NEXT +240 PRINT "FINE. THE ";A$;" NEED A MANAGER. WHAT'S YOUR NAME"; +250 INPUT B$ +260 PRINT "WHAT DO YOU WANT TO CALL MY TEAM, ";B$; +270 INPUT C$ +280 PRINT +290 PRINT "OPENING DAY, THE ";A$;" VERSUS THE ";C$ +300 PRINT +310 PRINT "LET'S FLIP A COIN. THE WINNER IS THE HOME TEAM." +320 PRINT "HEADS OR TAILS"; +330 INPUT D$ +340 IF D$<>"HEADS" AND D$<>"TAILS" THEN 320 +350 FOR I=1 TO TYM +360 Y=RND(1) +370 NEXT I +380 H=1 +390 Y=RND(1) +400 Y$="HEADS" +410 IF Y>.5 THEN Y$="TAILS" +420 IF D$=Y$ THEN 490 +430 H=0 +440 PRINT "YOU LOST THE TOSS. THE ";A$;" ARE UP FIRST." +450 PRINT +460 PRINT +470 A=0 +480 GOTO 610 +490 PRINT "YOU WIN THE TOSS. ";A$;" TAKE THE FIELD, AND "; +500 PRINT C$;" ARE AT BAT." +510 A=1 +520 R9=0 +530 T=T+1 +540 IF T<3 THEN GOSUB 5140 +550 IF T<18 THEN 710 +560 IF T>18 THEN 590 +570 GOSUB 3500 +580 GOTO 710 +590 GOSUB 3290 +600 GOTO 710 +610 REM START AN INNING - WE ARE OUT ON THE FIELD +620 T=T+1 +630 R9=0 +640 IF T<18 THEN 690 +650 IF T>18 THEN 680 +660 GOSUB 3500 +670 GOTO 690 +680 GOSUB 3290 +690 IF T>2 THEN 710 +700 GOSUB 5070 +710 S=0:B=0 +720 PRINT +730 IF O=0 THEN PRINT "NO OUTS" +740 IF O=1 THEN PRINT "THERE IS 1 OUT" +750 IF O>1 THEN PRINT "THERE ARE";O;"OUTS" +760 P=B(1)+B(2)+B(3) +770 IF P<>3 THEN 800 +780 PRINT "BASES LOADED" +790 GOTO 900 +800 IF P=0 THEN 900 +810 Y$="RUNNER ON " +820 IF P>1 THEN Y$="RUNNERS ON " +830 PRINT Y$; +840 IF B(1)=0 THEN 870 +850 PRINT "FIRST"; +860 IF P>1 THEN PRINT " AND "; +870 IF B(2)=1 THEN PRINT "SECOND"; +880 IF P>1 AND B(1)=0 THEN PRINT " AND "; +890 IF B(3)=1 THEN PRINT "THIRD" ELSE PRINT " " +900 IF A=0 THEN 920 +910 GOTO 3030 +920 PRINT "BATTER UP" +930 IF B<>3 OR S<>2 THEN 960 +940 PRINT "FULL COUNT" +950 GOTO 970 +960 IF B>0 OR S>0 THEN PRINT "THE COUNT IS";B;"AND";S +970 PRINT +980 IF A=1 THEN 3030 +990 PRINT "WHAT WILL YOUR BATTER DO, ";B$; +1000 INPUT C +1010 IF C>0 AND C<5 THEN 1050 +1020 PRINT "HUH? "; +1030 GOSUB 5070 +1040 GOTO 990 +1050 Y2=RND(1) +1060 IF Y2<.56 OR Y2>.5625 THEN 1120 +1070 PRINT "WILD PITCH!" +1080 N=1 +1090 GOSUB 3540 +1100 B(1)=0 +1110 GOTO 1210 +1120 IF Y2>.772 AND Y2<.775 THEN 4880 +1130 ON C GOTO 1140,1450,2600,4450,5500 +1140 C=1 +1150 GOSUB 5240 +1160 IF A=0 THEN Z1=Z1+1 +1170 Y=RND(1) +1180 IF B<>3 OR S<>0 THEN 1200 +1190 IF Y<.7 THEN 1310 ELSE 1210 +1200 IF Y<.5 THEN 1310 +1210 B=B+1 +1220 Y=INT(RND(1)*8+1) +1230 IF Y=9 THEN 1220 +1240 PRINT J$(Y);" - BALL";B +1250 IF B<>4 THEN 930 +1260 PRINT "WALK" +1270 GOSUB 4950 +1280 Y=RND(1) +1290 GOTO 710 +1300 PRINT "HIGH POP - FOUL DOWN THE ";Y$;" FIELD LINE" +1310 S=S+1 +1320 IF C=2 OR C=5 THEN 1370 +1330 Y=INT(RND(1)*4+1) +1340 IF Y=5 THEN 1330 +1350 PRINT K$(Y);", CALLED STRIKE";S +1360 GOTO 1380 +1370 PRINT "SWINGING STRIKE";S +1380 IF C=5 AND S<>3 THEN 4450 +1390 IF S<>3 THEN 930 +1400 PRINT "STRUCK OUT" +1410 O=O+1 +1420 IF O=3 THEN 2850 +1430 IF C=5 THEN 4450 +1440 GOTO 710 +1450 C=2 +1460 Y=INT(RND(1)*10+1) +1470 IF Y=10 THEN 1450 +1480 IF A=0 THEN Z2=Z2+1 +1490 IF C<>5 THEN GOSUB 5240 +1500 IF S<>2 AND Z2/Z1>7 AND A=0 THEN 1520 +1510 IF S<>2 OR Z2/Z1<25 THEN 1590 +1520 Y=INT(RND(1)*20+1) +1530 IF Y>7 THEN 1550 +1540 ON Y GOTO 1610,1310,1310,1310,1310,1680,1610 +1550 IF Y>13 THEN 1570 +1560 ON Y-7 GOTO 1680,1310,1740,1850,1740,1850 +1570 IF Y>18 THEN 1600 +1580 ON Y-13 GOTO 1980,1980,2040,2570,1640,2570 +1590 IF Y<3 THEN 1310 +1600 ON Y-2 GOTO 1610,1680,1740,1850,1980,2040,2570 +1610 PRINT "FOULED INTO THE STANDS-OUT OF PLAY" +1620 IF S<>2 THEN S=S+1 +1630 GOTO 930 +1640 Y=RND(1) +1650 Y$="RIGHT" +1660 IF Y<.5 THEN Y$="LEFT" +1670 GOTO 1620 +1680 Y=INT(RND(1)*20+1) +1690 IF Y>18 THEN 1720 +1700 PRINT "FOULED BACK INTO THE STANDS" +1710 GOTO 1620 +1720 PRINT "POPPED IT UP - CAUGHT BY CATCHER" +1730 GOTO 1410 +1740 PRINT "INFIELD GROUNDER" +1750 E2=RND(1) +1760 IF E2<.37 OR E2>.41 THEN 1820 +1770 PRINT "1 BASE ERROR!!" +1780 N=1 +1790 C=4 +1800 GOSUB 3540 +1810 GOTO 710 +1820 GOSUB 4100 +1830 IF O=3 THEN 2850 +1840 GOTO 710 +1850 PRINT "GROUNDER - COULD BE TROUBLE" +1860 Y=RND(1) +1870 IF Y>.75 THEN 1950 +1880 Y$="UP THE MIDDLE" +1890 IF Y<.5 THEN Y$="THROUGH THE HOLE INTO RIGHT FIELD" +1900 IF Y<.25 THEN Y$="THROUGH THE HOLE INTO LEFT FIELD" +1910 PRINT "A SINGLE ";Y$;"!" +1920 N=1 +1930 GOSUB 3540 +1940 GOTO 710 +1950 PRINT "INFIELDER UP WITH IT!" +1960 GOSUB 4800 +1970 IF O=3 THEN 2850 ELSE 710 +1980 Y=RND(1) +1990 Y$="LEFT" +2000 IF Y<.6 THEN Y$="CENTER" +2010 IF Y<.3 THEN Y$="RIGHT" +2020 PRINT "FLY-OUT TO ";Y$;" FIELD" +2030 GOTO 1410 +2040 Z=RND(1) +2050 Y$="CENTER" +2060 IF Z<.6 THEN Y$="RIGHT" +2070 IF Z<.3 THEN Y$="LEFT" +2080 PRINT "LONG FLY TO DEEP ";Y$;" FIELD - LOOKS GOOD!" +2090 Z=RND(1) +2100 IF Z<.9 THEN 2130 +2110 PRINT Y$;"FIELDER CAUGHT IT AT THE WALL!" +2120 GOTO 2180 +2130 IF Z<.8 THEN 2160 +2140 PRINT "A DIVING CATCH!" +2150 GOTO 2180 +2160 IF Z<.7 THEN 2290 +2170 PRINT Y$;"FIELDER CAUGHT IT ON THE WARNING TRACK!" +2180 O=O+1 +2190 IF O=3 THEN 2850 +2200 FOR I=3 TO 1 STEP -1 +2210 IF B(I)=1 THEN 2240 +2220 NEXT I +2230 GOTO 710 +2240 B(I+1)=B(I) +2250 B(I)=0 +2260 PRINT "LEAD RUNNER TAGS UP - AND ADVANCES 1 BASE!" +2270 GOSUB 3830 +2280 GOTO 710 +2290 IF Z<.5 THEN 2360 +2300 PRINT "BATTER HOLDS WITH A SINGLE." +2310 N=2 +2320 GOSUB 3540 +2330 B(2)=0 +2340 B(1)=1 +2350 GOTO 710 +2360 IF Z<.15 THEN 2480 +2370 PRINT "DOUBLE!" +2380 Y=RND(1) +2390 IF Y>.5 THEN 2430 +2400 N=2 +2410 GOSUB 3540 +2420 GOTO 710 +2430 N=3 +2440 GOSUB 3540 +2450 B(3)=0 +2460 B(2)=1 +2470 GOTO 710 +2480 IF Z<.1 THEN 2530 +2490 PRINT "TRIPLE!" +2500 N=3 +2510 GOSUB 3540 +2520 GOTO 710 +2530 PRINT "IT'S OVER THE WALL -- A H*O*M*E R*U*N!!!" +2540 N=4 +2550 GOSUB 3540 +2560 GOTO 710 +2570 Y=INT(RND(1)*7+1) +2580 PRINT "LINED OUT TO ";P$(Y) +2590 GOTO 1410 +2600 GOSUB 5240 +2610 PRINT "BATTER BUNTS..." +2620 Y=RND(1) +2630 IF Y<.6 THEN 2750 +2640 IF B(3)=0 THEN 2660 +2650 IF Y<.8 THEN 2830 +2660 PRINT "THROWN OUT AT FIRST." +2670 O=O+1 +2680 IF O=3 THEN 2850 +2690 IF B(1)+B(2)+B(3)=0 THEN 710 +2700 PRINT "SACRIFICE - "; +2710 N=1 +2720 GOSUB 3540 +2730 B(1)=0 +2740 GOTO 710 +2750 IF Y<.2 THEN 2830 +2760 IF Y<.4 THEN 2790 +2770 PRINT "BATTER MISSES PITCH" +2780 GOTO 1310 +2790 PRINT "BEATS IT OUT! SINGLE!" +2800 N=1 +2810 GOSUB 3540 +2820 GOTO 710 +2830 GOSUB 4100 +2840 IF O<>3 THEN 710 +2850 PRINT "3 OUTS. THE SIDE IS RETIRED"; +2860 I=B(1)+B(2)+B(3) +2870 IF I=0 THEN PRINT "." +2880 IF I=1 THEN PRINT ", LEAVING 1 MAN ON BASE" +2890 IF I>1 THEN PRINT ", LEAVING";I;"MEN ON BASE" +2900 PRINT +2910 PRINT +2920 PRINT "*************" +2930 D=T/2-INT(T/2) +2940 PRINT "AFTER"; +2950 IF T>1 THEN PRINT INT(T/2); +2960 IF D>.3 THEN PRINT " 1/2 "; +2970 Y$="INNINGS" +2980 IF T<3 THEN Y$="INNING" +2990 PRINT Y$;" OF PLAY, THE SCORE IS" +3000 GOSUB 3960 +3010 O=0:B(1)=0:B(2)=0:B(3)=0 +3020 IF A=0 THEN 510 ELSE 470 +3030 REM MY TEAM IS AT BAT +3040 Y=RND(1) +3050 IF B(1)+B(2)+B(3)=0 THEN 3140 +3060 REM IF O=2 AND S=2 AND B=3 THEN 4850 +3070 IF B(3)=1 THEN 3110 +3080 IF B(2)=0 THEN 3100 +3090 IF .45Y THEN 4450 +3100 IF .45Y THEN 4450 +3110 IF O=2 THEN 3140 +3120 IF O<2 AND Y<.333 AND B(3)=1 THEN 2600 +3130 IF .45Y THEN 2600 +3140 IF S=0 THEN 3240 +3150 IF B<>3 THEN 3180 +3160 IF Y<.6 THEN 1450 +3170 GOTO 1140 +3180 IF Y>.3 THEN 1450 +3190 IF S<>2 THEN 1140 +3200 IF B=0 AND Y<.1 THEN 1140 +3210 IF B=0 THEN 1450 +3220 IF Y<.2 THEN 1140 +3230 GOTO 1450 +3240 IF B=3 THEN 3270 +3250 IF Y<.6 THEN 1140 +3260 GOTO 1450 +3270 IF Y<.9 THEN 1140 +3280 GOTO 1450 +3290 IF T<>19 THEN 3330 +3300 IF R1<>R2 THEN 3340 +3310 PRINT +3320 PRINT "*** GOING INTO EXTRA INNINGS ***" +3330 IF R1=R2 THEN RETURN +3340 IF (T-1)/2<>INT(T-1)/2 THEN RETURN +3350 PRINT "THE BALLGAME IS OVER." +3360 PRINT "*************" +3370 PRINT "FINAL SCORE:" +3380 T9=1 +3390 GOSUB 3960 +3400 IF R1>R2 THEN 3470 +3410 PRINT "NICE TRY, ";B$ +3420 PRINT "YOU SHOULD KNOW BETTER THAN TO TRY TO" +3430 PRINT "OUT-MANAGE A COMPUTER. MAYBE BASEBALL" +3440 PRINT "JUST ISN'T YOUR SPORT...WHY DON'T YOU TRY GOLF?" +3450 REM CHAIN GOLF +3460 STOP +3470 PRINT "CONGRATULATIONS, ";B$ +3480 PRINT "YOU'VE BEATEN ME, BUT I WILL HAVE MY REVENGE." +3490 STOP +3500 REM 9TH INNING +3510 IF A=0 THEN 3530 +3520 IF R2>R1 THEN 3350 ELSE RETURN +3530 IF R1>R2 THEN 3350 ELSE RETURN +3540 REM ADVANCE N BASES (SET N BEFORE GOSUB) +3550 N2=B(1)+B(2)+B(3) +3560 IF C=5 THEN N=N+1 +3570 N3=N +3580 IF N2=0 THEN 3650 +3590 REM FIND LAST RUNNER: MAKE SURE HE ISN"T TRYING TO ADVANCE +3600 REM PAST HOME PLATE. +3610 FOR I=1 TO 3 +3620 IF B(I)=1 THEN 3640 +3630 NEXT I +3640 IF 4-I1 THEN B(N-P)=0 +3720 IF (N-P)<=1 THEN B(1)=0 +3730 NEXT P +3740 FOR P=1 TO 7 +3750 IF P=N THEN 3780 +3760 NEXT P +3770 GOTO 3830 +3780 IF C=4 OR N2=0 THEN 3830 +3790 Y$="RUNNERS ADVANCE" +3800 IF N2=1 THEN Y$="RUNNER ADVANCES" +3810 PRINT Y$;N3; +3820 IF N3=1 THEN PRINT "BASE" ELSE PRINT "BASES" +3830 IF B(4)+B(5)+B(6)+B(7)=0 THEN RETURN +3840 REM AT LEAST 1 RUN HAS SCORED. +3850 N2=B(4)+B(5)+B(6)+B(7) +3860 IF A=0 THEN 3890 +3870 R2=R2+N2 +3880 GOTO 3900 +3890 R1=R1+N2 +3900 B(4)=0:B(5)=0:B(6)=0:B(7)=0 +3910 IF N2=1 THEN PRINT "** 1 RUN SCORED" +3920 IF N2>1 THEN PRINT "**";N2;"RUNS SCORED" +3930 PRINT +3940 PRINT +3950 PRINT "********NEW SCORE:" +3960 IF H=1 THEN 4000 +3970 IF LEN(A$)>LEN(C$) THEN PRINT A$;TAB(LEN(A$)+3);R1 +3980 IF LEN(A$)<=LEN(C$) THEN PRINT A$;TAB(LEN(C$)+3);R1 +3990 IF H=1 THEN 4030 +4000 IF LEN(A$)>LEN(C$) THEN PRINT C$;TAB(LEN(A$)+3);R2 +4010 IF LEN(A$)<=LEN(C$) THEN PRINT C$;TAB(LEN(C$)+3);R2 +4020 IF H=1 THEN 3970 +4030 PRINT "*************" +4040 PRINT +4050 PRINT +4060 IF T9=1 THEN 4090 +4070 IF A=1 AND T>17 AND INT(T/2)=T/2 AND R2>R1 THEN 3350 +4080 IF A=0 AND T>17 AND INT(T/2)=T/2 AND R1>R2 THEN 3350 +4090 RETURN +4100 REM LEAD RUNNER OUT (FIELDER"S CHOICE THEN ONE BASE ADVANCE) +4110 N=1 +4120 I=4 +4130 IF B(4)=0 AND B(3)=1 AND B(2)=1 AND B(1)=1 THEN 4220 +4140 I=3 +4150 IF B(3)=0 AND B(2)=1 AND B(1)=1 THEN 4220 +4160 I=2 +4170 IF B(2)=0 AND B(1)=1 THEN 4220 +4180 REM NO ONE FORCED +4190 O=O+1 +4200 PRINT "BATTER THROWN OUT" +4210 RETURN +4220 B(I-1)=0 +4230 F=RND(1) +4240 IF O=2 OR F>.3 THEN 4290 +4250 O=O+2 +4260 PRINT "DOUBLE PLAY!" +4270 IF O=3 THEN RETURN +4280 GOTO 4910 +4290 O=O+1 +4300 PRINT "RUNNER ON BASE";I-1;"IS OUT ON FIELDER'S CHOICE" +4310 IF O=3 THEN RETURN +4320 GOSUB 3540 +4330 RETURN +4340 REM FORCED RUNNERS ADVANCE 1 BASE, OTHERS HOLD +4350 FOR I=1 TO 3 +4360 IF B(I)=0 THEN 4400 +4370 NEXT I +4380 N=1 +4390 GOTO 3540 +4400 REM NO ONE ON BASE I +4410 FOR I2=I TO 1 STEP -1 +4420 B(I2)=1 +4430 NEXT I2 +4440 RETURN +4450 REM LEAD RUNNER STEALS +4460 FOR I=3 TO 1 STEP -1 +4470 IF B(I)=1 THEN 4510 +4480 NEXT I +4490 PRINT "NO ONE ON BASE, DUMMY!" +4500 GOTO 990 +4510 REM I IS LEAD RUNNER"S BASE +4520 IF C<>5 THEN GOSUB 5240 +4530 IF RND(1)/I<.3 THEN 4680 +4540 IF B(1)+B(2)+B(3)>1 THEN 4570 +4550 PRINT "RUNNER STEALS A BASE" +4560 GOTO 4580 +4570 PRINT "RUNNERS STEAL A BASE" +4580 N=1 +4590 C2=C +4600 C=4 +4610 GOSUB 3540 +4620 C=C2 +4630 B(1)=0 +4640 IF C=5 AND S<>3 THEN 930 +4650 IF C=5 THEN 710 +4660 Y=RND(1) +4670 IF Y>.5 THEN 1210 ELSE 1310 +4680 PRINT "RUNNER THROWN OUT STEALING" +4690 O=O+1 +4700 B(I)=0 +4710 IF O=3 THEN 2850 +4720 N=1 +4730 GOSUB 3540 +4740 B(1)=0 +4750 IF C=5 AND S<>3 THEN 930 +4760 IF C=5 THEN 710 +4770 Y=RND(1) +4780 IF B=3 THEN 1310 +4790 IF Y>.5 THEN 1210 ELSE 1310 +4800 REM RUNNERS ADVANCE ONE BASE, BATTER THROWN OUT +4810 N=1 +4820 IF O=2 THEN 4850 +4830 GOSUB 3540 +4840 B(1)=0 +4850 O=O+1 +4860 PRINT "BATTER THROWN OUT" +4870 RETURN +4880 PRINT "HIT BATSMAN (OUCH!)" +4890 GOSUB 4950 +4900 GOTO 710 +4910 N=1 +4920 GOSUB 3540 +4930 B(1)=0 +4940 RETURN +4950 REM BATTER WALKED +4960 FOR I=1 TO 3 +4970 IF B(I)=0 THEN 5010 +4980 NEXT I +4990 N=1 +5000 GOTO 3540 +5010 IF I=1 THEN 5050 +5020 FOR I0=I TO 2 STEP -1 +5030 B(I0)=B(I0-1) +5040 NEXT I0 +5050 B(1)=1 +5060 RETURN +5070 PRINT "WHEN YOUR'RE UP:" +5080 PRINT "1-BATTER TAKES PITCH" +5090 PRINT "2-BATTER SWINGS AWAY" +5100 PRINT "3-BATTER BUNTS" +5110 PRINT "4-LEAD RUNNER STEALS" +5120 REM PRINT "5-HIT AND RUN" +5130 RETURN +5140 REM PITCHING ROUTINE +5150 PRINT "YOUR PITCHER MAY THROW:" +5160 PRINT "1-FAST BALL" +5170 PRINT "2-CURVE" +5180 PRINT "3-SLIDER" +5190 PRINT "4-SINKER" +5200 PRINT "5-CHANGE-UP" +5210 PRINT "6-KNUCKLEBALL" +5220 PRINT "7-SCREWBALL" +5230 RETURN +5240 IF A=0 THEN 5370 +5250 IF R9=1 THEN 5300 +5260 PRINT "WHAT WILL YOUR PITCHER THROW"; +5270 INPUT W +5280 IF W<0 THEN R9=1 +5290 IF R9=0 THEN 5320 ELSE PRINT "RANDOM PITCHES FOR REST OF INNING" +5300 W=INT(RND(1)*8+1) +5310 IF W=8 THEN 5300 +5320 IF W>0 AND W<8 THEN 5470 +5330 PRINT "UH-UH, ";B$;". "; +5340 GOSUB 5150 +5350 PRINT +5360 GOTO 5260 +5370 REM I MUST SELECT A PITCH +5380 W1=RND(1) +5390 W=1 +5400 IF W1<.75 THEN W=2 +5410 IF W1<.55 THEN W=3 +5420 IF W1<.45 THEN W=4 +5430 IF W1<.35 THEN W=5 +5440 IF W1<.15 THEN W=6 +5450 IF W1<.08 THEN W=7 +5460 GOTO 5470 +5470 PRINT W$(W); +5480 PRINT "..."; +5490 RETURN +5500 REM HIT-AND-RUN +5510 IF B(1)+B(2)+B(3)=0 THEN 4490 +5520 GOSUB 5240 +5530 PRINT "HIT AND RUN!" +5540 C=5 +5550 GOTO 1460 +5560 DATA FAST BALL,CURVE BALL,SLIDER,SINKER,CHANGE-UP,KNUCKLEBALL +5570 DATA SCREWBALL +5580 DATA RIGHT,LEFT,CENTER,FIRST,SECOND,THIRD,SHORTSTOP,PITCHER,CATCHER +5590 DATA RIGHT OVER THE PLATE,CAUGHT THE OUTSIDE CORNER +5600 DATA OVER THE INSIDE CORNER,OVER AT THE KNEES +5610 DATA HIGH,LOW,INSIDE,OUTSIDE,HIGH AND TIGHT,LOW AND OUTSIDE +5620 DATA LOW AND INSIDE,HIGH AND OUTSIDE +5630 END + \ No newline at end of file diff --git a/disks/images/b/BIGTREK.ASC b/disks/images/b/BIGTREK.ASC new file mode 100644 index 0000000..338dec7 --- /dev/null +++ b/disks/images/b/BIGTREK.ASC @@ -0,0 +1,1444 @@ +1 'REWRITE BY ZOSO +2 RANDOMIZE:WIDTH90:LQ=1000 +7 DIM G1$(16),V$(5,5),C$(20),G(8,8),D$(12),Q$(10,10),D4(12),D9(106) +10 DIM S2(8,8):Q$="?" +15 DATA S.R. SENSORS,L.R. SENSORS,PHASERS,PHOTON TUBES,LIFE SUPPORT +20 DATA WARP ENGINES,IMPULSE ENGINES,SHIELDS,SUBSPACE RADIO +21 DATA SHUTTLE CRAFT,COMPUTER,TRANSFER PANEL,ABANDON,CHART,COMPUTER +22 DATA DAMAGES,DESTRUCT,DOCK,IDLE,IMPULSE,LRSCAN,NAVIGATE,PHASERS,QUIT +23 DATA SHIELDS,SOS,SRSCAN,STATUS,TORPEDO,TRANSFER,VISUAL,WARP,SHORT +24 DATA MEDIUM,LONG,BEGINNER,NOVICE,SENIOR,EXPERT,COURSE,WCOST,ICOST +25 DATA PEFFECT,SCORE,OUT,ANTARES,SIRIUS,RIGEL,MERAK,PROCYON,CAPELLA +26 DATA VEGA,DENEB,CANOPUS,ALDEBARAN,ALTAIR,REGULUS,BELLATRIX,ARCTURUS +27 DATA POLLUX,SPICA,10.5,12,1.5,9,0,3,7.5,6,4.5 +28 DEF FNA(X)=INT(8*RND(X))+1:DEF FNB(X)=INT(10*RND(X))+1 +29 DEF FND(X)=X/60 +30 DEFFNR(X)=INT(X*10+.5)/10:DEFFNS(X)=INT(X*100+.5)/100 +40 FORI=1TO12:READD$(I):NEXT:FORI=1TO20:READC$(I):NEXT +43 FORI=1TO3:READT$(I):NEXT:FORI=1TO4:READS$(I):NEXT:FORI=1TO6 +44 READC2$(I):NEXT:FORI=1TO16:READG1$(I):NEXT:FORI=1TO9:READC5(I):NEXT +46 GOSUB24001:S7$(1)="":S7$(2)=" ":S7$(3)=" ":S7$(4)="" +70 IFA2<>0THEN901 +75 J4=0:T1=0:INPUT"COMMAND";A$:IFLEN(A$)>1THEN110 +80 ?"2 LETTERS, PLEASE.":GOTO75 +110 FORI=1TO20 +120 IFA$=LEFT$(C$(I),LEN(A$))THEN150 +130 NEXT +135 ?"ILLEGAL !! - USE THIS LIST" +140 ?:FORI=1TO20STEP4 +141 ?C$(I);TAB(12);C$(I+1);TAB(22);C$(I+2);TAB(32);C$(I+3) +142 NEXT:?:GOTO70 +150 ONIGOTO201,226,251,276,291,301,326,351,376,401 +160 ONI-10GOTO426,901,476,501,526,545,551,576,601,627 +201 GOSUB 35001:GOTO70 +226 GOSUB 3001:GOTO70 +251 GOSUB5001:GOTO70 +276 GOSUB8001:GOTO70 +291 GOSUB36001:GOTO70 +301 GOSUB7000:GOTO70 +326 GOSUB33001:IFJ3=0THEN70 +331 IFA2<>0THEN901 +332 IFG(Q1,Q2)=1000THEN750 +340 GOSUB1000:GOTO70 +351 GOSUB13001:IFJ3=0THEN70 +353 GOTO710 +376 GOSUB14001:GOTO70 +401 GOSUB34001 +402 IFJ3=0THEN70 +410 GOTO710 +426 GOSUB20001:IFJ3=0THEN70 +428 GOSUB1000:GOTO70 +476 GOSUB26001:IFJ3=0THEN70 +478 IFA2<>0THEN901 +479 GOSUB1000:S9=0:GOTO70 +501 GOSUB11001:GOTO70 +526 GOSUB29002:GOSUB14001:GOTO70 +545 ?:GOSUB37001:GOTO70 +551 GOSUB21001:IFJ3=0THEN70ELSE710 +576 GOSUB31001:IFJ3=0THEN70 +585 IFA2<>0THEN901 +590 IFG(Q1,Q2)<>LQTHEN70 +595 GOTO750 +601 GOSUB32001:IFJ3=0THEN70 +603 IFA2<>0THEN901 +610 IFG(Q1,Q2)<>LQTHEN70 +615 GOTO750 +627 GOSUB25010:GOTO70 +710 IFA2<>0THEN901 +720 IFT1<>0THENGOSUB9000 +730 IFA2<>0THEN901 +740 IFG(Q1,Q2)0THEN901 +760 IFA2<>0THEN901 +770 GOTO740 +790 GOSUB1000:GOTO70 +901 ?:?:INPUT"ANOTHER GAME ";A$ +910 IFLEFT$(A$,1)="Y"THEN46 +911 ?CHR$(26):END +1000 IF(C3<>0)AND(J4=0)THENGOSUB16001 +1020 IFK3=0THENRETURN +1030 IFA2<>0THENRETURN +1040 P2=1/I8 +1050 J5=0 +1060 ? +1070 IFC5$="DOCKED"THEN1780 +1080 H2=0:H3=0:C6=1 +1090 IFS9=1THENC6=.5+.5*RND(1) +1100 A3=0 +1110 FORL=1TOK3 +1120 IFK6(L)<0THEN1540 +1130 A3=1 +1140 D6=.8+.05*RND(1) +1150 H4=K6(L)*D6^K8(L) +1160 IF(S4=0)AND(S9=0)THEN1230 +1170 P3=.1:IFP2*S3>P3THENP3=P2*S3 +1180 H5=P3*C6*H4+1 +1190 IFH5>S3THENH5=S3 +1195 S3=S3-H5:H4=H4-H5 +1210 IF(P3>.1)AND(H4<5E-03*E1)THEN1540 +1230 J5=1 +1240 ?FNR(H4);"UNIT HIT ON THE ";S5$;" FROM "; +1250 J6=K4(L):J7=K5(L) +1260 IFQ$(J6,J7)="K"THEN?"KLINGON AT"; +1270 IFQ$(J6,J7)="C"THEN?"COMMANDER AT"; +1280 ?J6;"-";J7 +1290 IFH4>H2THENH2=H4 +1300 H3=H3+H4 +1310 IFH4<(275-25*S8)*(1+.5*RND(1))THEN1530 +1320 N4=1+INT(H4/(500+100*RND(1))) +1330 ?"*** CRITICAL HIT--"; +1340 K9=1 +1350 FORW4=1TON4 +1360 J9=INT(12*RND(1))+1 +1370 C5(W4)=J9 +1380 E3=(H4*D5)/(N4*(75+25*RND(1))) +1390 IFJ9=6THENE3=E3/3 +1395 D4(J9)=D4(J9)+E3 +1400 IFW4=1THEN1470 +1420 FORV=1TOW4 +1430 IFJ9=C5(V-1)THEN1480 +1440 NEXTV +1450 K9=K9+1 +1460 IFK9=3THEN? +1465 ? " AND "; +1470 ?D$(J9); +1480 NEXTW4 +1490 ? " DAMAGED." +1500 IFD4(8)=0THEN1530 +1510 IFS4<>0THEN?"*** SHIELDS KNOCKED DOWN." +1520 S4=0 +1530 E1=E1-H4 +1540 NEXTL +1550 IFA3=0THENRETURN +1560 IFE1<=0THEN1750 +1570 P4=100*P2*S3+.5 +1580 IFJ5<>0THEN1610 +1590 ?"ENEMY ATTACK--SHIELDS REDUCED TO "; +1600 GOTO1650 +1610 ?"ENERGY LEFT:";FNS(E1);" SHIELDS "; +1620 IFS4<>0THEN?"UP,"; +1630 IF(S4=0)AND(D4(8)=0)THEN?"DOWN, "; +1640 IFD4(8)>0THEN?"DAMAGED, "; +1650 ?INT(P4);"%" +1660 IF(H2<200)AND(H3<500)THEN1800 +1670 J8=INT(H3*RND(1)*.015) +1680 IFJ8<2THEN1800 +1690 ? +1700 ?"---> 'SICKBAY TO BRIDGE. WE SUFFERED ";J8;"CASUALTIES IN THAT ATTACK" +1730 C4=C4+J8 +1740 GOTO1800 +1750 F9=5 +1760 GOSUB10000:RETURN +1780 ?"*** KLINGONS ATTACK-- STARBASE SHIELDS PROTECT THE ";S5$ +1800 FORW4=1TOK3 +1810 K8(W4)=K7(W4) +1820 NEXTW4 +1830 GOSUB28000:RETURN +2001 ?:IFJ4=0THEN2050 +2020 ?"*** RED ALERT! RED ALERT!" +2030 ?"*** THE ";S5$;" HAS STOPPED IN QUADRANT CONTAINING SUPERNOVA" +2050 ? "*** AUTO-OVERRIDE ATTEMPTS TO HURL ";S5$;" TO OTHER QUADRANT" +2080 S2(Q1,Q2)=1 +2090 GOSUB18000 +2100 IFD4(6)=0THEN2290 +2110 ? +2120 ?"WARP ENGINES DAMAGED." +2140 ?:?"TRYING TO ENGAGE IMPULSE ENGINES..." +2150 IFD4(7)=0THEN2190 +2160 ?"IMPULSE ENGINES DAMAGED." +2165 F9=8 +2170 GOSUB10000 +2180 RETURN +2190 P2=.75*E1 +2200 D6=4E-03*(P2-50) +2210 D7=1.4142+1.2*RND(1) +2220 D1=D6 +2230 IFD6>D7THEND1=D7 +2240 T1=D1/.4 +2250 D2=12*RND(1) +2260 J4=0 +2270 GOSUB13200 +2280 GOTO2400 +2290 W1=6+2*RND(1) +2300 W2=W1*W1 +2310 P2=.75*E1 +2320 D6=P2/(W1*W1*W1*(S4+1)) +2330 D7=1.4142+2*RND(1) +2340 D1=D6 +2350 IFD6>D7THEND1=D7 +2360 T1=10*D1/W2 +2370 D2=12*RND(1) +2380 J4=0 +2390 GOSUB34500 +2400 IFJ4<>0THEN2440 +2410 F9=8 +2420 GOSUB10000 +2430 RETURN +2440 IFR1<>0THENRETURN +2450 F9=1 +2460 GOSUB10000 +2470 RETURN +3001 ?:?" 1 2 3 4 5 6 7 8" +3010 ?" --- --- --- --- --- --- --- ---" +3020 FORI=1TO8 +3030 ?I;" "; +3040 FORJ=1TO8 +3060 ONSGN(S2(I,J))+2GOTO3070,3090,3110 +3070 ?" .1."; +3080 GOTO 3160 +3090 ?" ..."; +3100 GOTO3160 +3110 IFS2(I,J)>LQTHEN3150 +3120 IFG(I,J)5THENI2=5 +4300 R3=I2 +4310 I5=7*L2 +4320 R5=I5 +4340 R7=(S8-2*RND(1)+1)*S8*.1+.1 +4350 IFR7<.2THENR7=R7+.1 +4360 I1=INT(2*R7*I5) +4370 R1=I1 +4380 I4=INT(S8+.0625*I1*RND(1)) +4390 R2=I4 +4400 I3=(I1+4*I4)*I5 +4410 R4=I3 +4420 RETURN +5001 IFD4(11)=0THEN5030 +5010 ?" COMPUTER DISABLED" +5020 RETURN +5030 ?"----COMPUTER ACTIVE----" +5040 INPUT"PROGRAM NAME";B$ +5050 FORI=1TO6 +5060 IFB$=LEFT$(C2$(I),LEN(B$))THEN5120 +5070 NEXT +5080 ?"VALID PROGRAMS ARE:" +5090 ?" COURSE WCOST SCORE" +5100 ?" PEFFECT ICOST OUT" +5110 GOTO5040 +5120 ON IGOTO5210,5302,5410,5510,5610,5700 +5210 INPUT "ENTER QUADRANT AND SECTOR - ";A3,A4 +5220 IF(A3<>INT(A3))OR(A4<>INT(A4))THEN5990 +5221 IFA3<0THEN5040 +5222 IFA3=0THENA3=10*Q1+Q2 +5223 A3=A3+.5 +5225 K=INT(A3/10) +5226 IF(K<1)OR(K>8)THEN5990 +5227 C6(1)=K:K=INT(A3-C6(1)*10) +5228 IF(K<1)OR(K>8)THEN5990 +5229 C6(2)=K:A4=A4+.5 +5230 K=INT(A4/100) +5231 IF(K<1)OR(K>10)THEN5990 +5232 C6(1)=C6(1)+(K-1)/10:K=INT(A4-K*100) +5233 IF(K<1)OR(K>10)THEN5990 +5234 C6(2)=C6(2)+(K-1)/10 +5235 X=Q1+((S6-1)/10)-C6(1):Y=Q2+((S7-1)/10)-C6(2) +5236 D1=0:D2=0:IF(X=0)AND(Y=0)THEN5250 +5237 D1=SQR(X*X+Y*Y) +5238 IFX<0THENZ7=SGN(Y)*(3.1416-ATN(ABS(Y/X))) +5239 IFX=0THENZ7=SGN(Y)*1.5708 +5240 IFX>0THENZ7=ATN(Y/X) +5245 D2=12-Z7*1.9098593:IFD2>12THEND2=D2-12 +5250 ?"COURSE IS";FNS(D2);" FOR A DISTANCE OF"; +5260 ?FNS(D1);"QUADRANTS.":GOTO5040 +5302 INPUT"ENTER DISTANCE AND WARP FACTOR";D1,A4 +5304 IF(D1<0)THEN5040 +5310 C7=D1*A4*A4*A4 +5315 T1=(10*D1)/((A4*A4)+1E-05) +5320 ?"IT WOULD TAKE";FNS(T1);"STARDATES AND USE" +5325 ?FNR(C7);"UNITS OF ENERGY (";FNR(C7+C7);"IF SHIELDS ARE UP)" +5330 GOTO5040 +5410 INPUT"ENTER DISTANCE...";D1 +5420 IFD1<0THEN5040 +5430 C7=250*D1+50:T1=D1/.4 +5440 ?"IT WOULD TAKE";FNR(T1);"STARDATES AND USE" +5450 ?C7;"UNITS OF ENERGY" +5460 GOTO5040 +5510 INPUT"ENTER PHASER RANGE IN QUADRANTS";A3 +5520 IFA3<0THEN5040 +5530 A3=A3*10:C7=(.9^A3)*100 +5540 ?"PHASERS ARE ";LEFT$(STR$(C7),5);"% EFFECTIVE AT THAT RANGE" +5550 GOTO5040 +5610 GOSUB23000 +5620 GOTO5040 +5700 RETURN +5990 ?"FORMAT IS MN,XXYY...WHERE MN IS THE QUADRANT" +5991 ?"AND XXYY IS THE SECTOR...E.G. 64,0307 REFERS" +5992 ?"TO QUADRANT 6-4, SECTOR 3-7." +5995 GOTO 5040 +6000 IFT2$<>"C"THEN6100 +6010 C3=0:?"*** COMMANDER AT"; +6030 FORF=1TOR2:IF(C1(F)=Q1)AND(C2(F)=Q2)THEN6050 +6040 NEXTF +6050 C1(F)=C1(R2):C2(F)=C2(R2):C1(R2)=0:C2(R2)=0 +6060 R2=R2-1:F1(2)=1E+30 +6070 IFR2<>0THENF1(2)=D0-(I4/R2)*LOG(RND(1)) +6080 K2=K2+1 +6090 GOTO6120 +6100 ?"*** KLINGON AT"; +6110 K1=K1+1 +6120 ?A5;"-";A6;"DESTROYED." +6130 Q$(A5,A6)=".":R1=R1-1 +6140 IFR1=0THENRETURN +6150 R5=R4/(R1+4*R2) +6160 G(Q1,Q2)=G(Q1,Q2)-100 +6170 FORF=1TOK3 +6180 IF(K4(F)=A5)AND(K5(F)=A6)THEN6200 +6190 NEXTF +6200 K3=K3-1 +6210 IFF>K3THEN6250 +6220 FORG=FTOK3 +6230 K4(G)=K4(G+1):K5(G)=K5(G+1):K6(G)=K6(G+1) +6235 K7(G)=K7(G+1):K8(G)=K7(G) +6240 NEXTG +6250 K4(K3+1)=0:K5(K3+1)=0:K7(K3+1)=0:K8(K3+1)=0:K6(K3+1)=0 +6260 RETURN +7000 IFC5$="DOCKED"THEN7100 +7010 IFB6=0THEN7020 +7015 IF(ABS(S6-B6)<=1)AND(ABS(S7-B7)<=1)THEN7040 +7020 ?S5$;" NOT ADJACENT TO A BASE." +7030 RETURN +7040 C5$="DOCKED" +7050 ?"---> DOCKING COMPLETED" +7060 E1=I7:S3=I8:T4=I9:L1=J1 +7070 RETURN +7100 ?"CAPTAIN, WE'RE ALREADY DOCKED!" +7110 RETURN +8001 J=0:?:FORI=1TO12 +8010 IFD4(I)<=0THEN8070 +8020 IFJ<>0THEN8060 +8030 ?" DEVICE";SPC(12);"-REPAIR TIMES-" +8040 ?SPC(21);"IN FLIGHT DOCKED":J=1 +8060 ?" ";D$(I);TAB(23);FNS(D4(I));TAB(33);FNS(D3*D4(I)) +8070 NEXTI +8080 IFJ=0THEN?" - ALL DEVICES FUNCTIONAL -" +8090 RETURN +9000 M=0:D7=D0+T1:FORL=1TO5 +9020 IFF1(L)>D7THEN9040 +9030 M=L:D7=F1(L) +9040 NEXTL +9050 X6=D7-D0:D0=D7 +9060 R4=R4-(R1+4*R2)*X6 +9070 R5=R4/(R1+4*R2) +9080 IFR5>0THEN9120 +9090 F9=2 +9100 GOSUB10000 +9110 RETURN +9120 IF(D4(5)=0)OR(C5$="DOCKED")THEN9180 +9130 IF(L1>=X6)OR(D4(5)<=L1)THEN9160 +9140 F9=3:GOSUB10000 +9150 RETURN +9160 L1=L1-X6 +9170 IFD4(5)<=X6THENL1=J1 +9180 R=X6 +9190 IFC5$="DOCKED"THENR=X6/D3 +9200 FORL=1TO12 +9210 IFD4(L)<=0THEN9230 +9220 D4(L)=D4(L)-R +9225 IFD4(L)<0THEND4(L)=0 +9226 IFD4(L)<>0THEN9230 +9227 ?:?"DAMAGE CONTROL- ";D$(L);" NOW OPERATIONAL." +9230 NEXTL +9240 IFM=0THENRETURN +9250 T1=T1-X6 +9260 ONMGOTO9280,9291,9340,9355,9475 +9280 X2=0:Y2=0:GOSUB27000 +9285 F1(1)=D0-.5*I5*LOG(RND(1)) +9286 IFG(Q1,Q2)=LQTHENRETURN +9287 GOTO9000 +9291 IFR2=0THEN9330 +9292 IFC5$="DOCKED"THEN9325 +9293 I=INT(RND(1)*R2)+1 +9294 Y6=(C1(I)-Q1)^2+(C2(I)-Q2)^2 +9295 IFY6=0THEN9325 +9296 Y6=SQR(Y6):T1=.17778*Y6 +9297 ?:?"*** ";S5$;" CAUGHT IN LONG-RANGE TRACTOR BEAM--" +9298 Q1=C1(I):Q2=C2(I) +9299 S6=FNB(1):S7=FNB(1) +9300 ?"PULLED TO QUADRANT";Q1;"-";Q2;", SECTOR";S6;"-";S7 +9301 IFR6<>0THEN?"(IDLE PERIOD CANCELLED)" +9302 R6=0 +9303 IFS4<>0THEN9320 +9304 IF(D4(8)=0)AND(S3>0)THEN9310 +9305 ?"(SHIELDS NOT CURRENTLY USABLE.)" +9307 GOTO9320 +9310 GOSUB26500 +9315 S9=0 +9320 GOSUB18000 +9325 F1(2)=D0+T1-1.5*(I5/R2)*LOG(RND(1)) +9326 GOTO9000 +9330 F1(2)=1E+30:GOTO9000 +9340 D9(1)=D0:D9(2)=R1:D9(3)=R2:D9(4)=R3:D9(5)=R4:D9(6)=R5 +9342 D9(7)=S1:D9(8)=B1:D9(9)=K1:D9(10)=K2 +9343 FORI=1TO8:FORJ=1TO8:D9(I-1+8*(J-1)+11)=G(I,J):NEXTJ:NEXTI +9344 FORI=75TO84:D9(I)=C1(I-74):NEXT +9345 FORI=85TO94:D9(I)=C2(I-84):NEXT +9346 FORI=95TO99:D9(I)=B2(I-94):NEXT +9347 FORI=100TO104:D9(I)=B3(I-99):NEXT +9348 D9(105)=B4:D9(106)=B5 +9349 S0=1:F1(3)=D0-.3*I5*LOG(RND(1)):GOTO9000 +9355 IF(R2=0)OR(R3=0)THEN9400 +9360 FORI=1TOR3:FORJ=1TOR2:IF(B2(I)=C1(J))AND(B3(I)=C2(J))THEN9410 +9370 NEXTJ:NEXTI +9380 F1(4)=D0+.5+3*RND(1) +9390 F1(5)=1E+30:GOTO9000 +9400 F1(4)=1E+30:F1(5)=1E+30:GOTO9000 +9410 B4=B2(I):B5=B3(I) +9420 IF(B4=Q1)AND(B5=Q2)THEN9380 +9430 F1(5)=D0+.5+3*RND(1) +9440 F1(4)=F1(5)-.3*I5*LOG(RND(1)) +9450 IFD4(9)>0THEN9000 +9460 ?:?" CAPTAIN, THE STARBASE IN";B4;"-";B5;"IS UNDER ATTACK-" +9462 ?" AND CAN ONLY RESIST UNTIL STARDATE";FNR(F1(5));"!!!" +9465 IFR6=0THEN9000 +9466 INPUT" SHALL WE CANCEL IDLE PERIOD";B$ +9468 IFLEFT$(B$,1)="Y"THENR6=0 +9469 GOTO9000 +9475 F1(5)=1E+30:IF(R2=0)OR(R3=0)THEN9000 +9485 K=INT(G(B4,B5)/100):IFG(B4,B5)-K*100<10THEN9000 +9490 FORI=1TOR2:IF(C1(I)=B4)AND(C2(I)=B5)THEN9520 +9510 NEXT:GOTO9000 +9520 IFS2(B4,B5)=-1THENS2(B4,B5)=0 +9530 IFS2(B4,B5)>999THENS2(B4,B5)=S2(B4,B5)-10 +9540 IF(B4<>Q1)OR(B5<>Q2)THEN9630 +9550 FORI=1TOK3:K=K4(I):L=K5(I) +9560 IFQ$(K,L)="C"THEN9570 +9565 NEXT +9570 IFK6(I)<25+50*RND(1)THEN9000 +9580 Q$(B6,B7)=".":B6=0:B7=0 +9590 GOSUB17000 +9600 ?:?"CAPTAIN, I BELIEVE THE STARBASE HAS BEEN DESTROYED" +9620 GOTO9680 +9630 IF(R3=1)OR(D4(9)>0)THEN9680 +9640 ? +9650 ?"--> STARFLEET COMMAND REPORTS THAT STARBASE IN QUADRANT";B4;"-";B5 +9660 ?"HAS BEEN DESTROYED BY ENEMY COMMANDER !!" +9680 G(B4,B5)=G(B4,B5)-10 +9690 IFR3<=1THEN9730 +9700 FORI=1TOR3:IF(B2(I)=B4)AND(B3(I)=B5)THEN9720 +9710 NEXT +9720 B2(I)=B2(R3):B3(I)=B3(R3) +9730 R3=R3-1 +9740 GOTO9000 +10000 ?:?:?:INPUT"CONFLICT RESOLVED - PREPARED FOR RATING ";B$ +10001 ?CHR$(26):A2=1:?:?"IT IS STARDATE";FNR(D0):? +10010 ONF9GOTO10025,10135,10165,10190,10200,10205,10225,10240 +10015 ONF9-8GOTO10250,10271,10285 +10025 ?"YOU HAVE DESTROYED THE KLINGON INVASION FLEET":? +10030 ?" ***THE FEDERATION IS SAVED***":G1=1 +10035 IF(A1=0)OR(B1<>0)THEN10110 +10040 IFLEFT$(S5$,1)<>"E"THEN10110 +10045 IF3*S1+35*N1+C4>=100THEN10110 +10050 IFD0-J2<=6THEN10075 +10060 R8=.1*S8*(S8+1)+.1 +10065 IF(K1+K2)/(D0-J2)I1THEN10150 +10140 ?" SUMMARILY EXECUTED" +10145 A1=0:GOSUB23000:RETURN +10150 ?" IMPRISONED FOR LIFE" +10165 ?"YOUR LIFE SUPPORT RESERVES HAVE RUN OUT, AND" +10170 ?"YOU WILL SOON DIE!!!" +10172 ? +10175 ?"YOUR STARSHIP IS A DERELICT IN SPACE." +10180 GOTO10300 +10190 ?"YOUR ENERGY SUPPLY IS EXHAUSTED.":GOTO10172 +10200 ?"THE ";S5$;" HAS BEEN DESTROYED IN BATTLE." +10201 GOTO10300 +10205 RETURN +10225 ?"YOUR STARSHIP HAS BEEN DESTROYED BY A NOVA." +10230 ?"NICE WORK, IDIOT !!!":GOTO10300 +10240 ?"THE ";S5$;" HAS BEEN INCINERATED BY A SUPERNOVA." +10241 GOTO10300 +10250 ?"YOU HAVE BEEN CAPTURED BY THE ENEMY. IF YOU STILL HAD A STARBASE," +10255 ?"YOU WOULD HAVE BEEN REPATRIATED. SINCE YOU HAVE NO BASES, YOU WILL" +10260 ?"BE MERCILESSLY TORTURED !!" +10266 GOTO10300 +10271 ?:?"THE ";S5$;" IS NOW AN EXPANDING CLOUD" +10272 ?"OF SUB-ATOMIC PARTICLES...":GOTO10300 +10285 ?"STARBASE WAS UNABLE TO RE-MATERIALIZE YOUR STARSHIP." +10300 ? +10310 IFLEFT$(S5$,1)="F"THENS5$="" +10315 IFLEFT$(S5$,1)="E"THENS5$="FAERIE QUEENE" +10316 A1=0 +10320 IFR1=0THEN10355 +10325 G3=R4/I3:B8=(R1+2*R2)/(I1+2*I4) +10326 A3=G3/B8 +10327 IF A3<1+.5+RND(1)THEN10345 +10330 ?"AS A RESULT OF YOUR ACTIONS, A TREATY WITH THE KLINGON" +10331 ?"EMPIRE HAS BEEN SIGNED. THE TERMS OF THE TREATY ARE" +10332 IFA3<3*RND(1)THEN10340 +10335 ?"FAVORABLE TO THE FEDERATION.":? +10336 ?"CONGRATULATIONS.":GOTO10350 +10340 ?"HIGHLY UNFAVORABLE TO THE FEDERATION.":GOTO10350 +10345 ?"THE FEDERATION WILL BE DESTROYED!" +10350 GOSUB23000:RETURN +10355 ?"SINCE YOU TOOK THE LAST KLINGON WITH YOU, YOU ARE" +10360 ?"A MARTYR AND A HERO.":G1=1:A1=0 +10390 GOSUB23000:RETURN +11001 IFC5$<>"DOCKED"THEN11020 +11010 ?"--> CAPTAIN, WE'RE ALREADY DOCKED!" +11015 RETURN +11020 IFD4(9)=0THEN11030 +11025 ?"SUBSPACE RADIO DAMAGED...CANNOT TRANSMIT.":RETURN +11030 IFR3<>0THEN11050 +11040 ?"CAPTAIN, NO RESPONSE FROM STARBASE !":RETURN +11050 N1=N1+1:IFB6=0THEN11070 +11060 GOTO11130 +11070 D1=1E+30 +11080 FORL=1TOR3:X=10*SQR((B2(L)-Q1)^2+(B3(L)-Q2)^2) +11090 IFX>D1THEN11110 +11100 D1=X:K=L +11110 NEXTL +11120 Q1=B2(K):Q2=B3(K):GOSUB18000 +11130 Q$(S6,S7)="." +11135 ? +11140 ?"STARBASE IN QUADRANT";Q1;"-";Q2;"RESPONDS --"; +11145 ?" ";S5$;" DEMATERIALIZES." +11146 P2=(1-.98^D1)^.333333 +11150 FORL=1TO3 +11155 IFL=1THEN?"1ST "; +11160 IFL=2THEN?"2ND "; +11170 IFL=3THEN?"3RD "; +11180 ?"ATTEMPT TO RE-MATERIALIZE THE ";S5$;". . . . ."; +11190 IFRND(1)>P2THEN11220 +11200 ?"FAILS.":NEXTL +11210 F9=11:GOSUB10000:RETURN +11220 FORL=1TO5:I=B6+INT(3*RND(1))-1 +11230 IF(I<1)OR(I>10)THEN11260 +11235 J=B7+INT(3*RND(1))-1 +11240 IF(J<1)OR(J>10)THEN11260 +11250 IFQ$(I,J)="."THEN11270 +11260 NEXTL:?"FAILS.":GOTO11210 +11270 ?"SUCCEEDS.":S6=I:S7=J:Q$(I,J)=LEFT$(S5$,1) +11280 GOSUB7000:?"CAPTAIN, WE MADE IT!":RETURN +12001 P4=2:L5=K3:N=1 +12010 FORK=1TOL5 +12020 IFH3(K)=0THEN12240 +12030 D6=.9+.01*RND(1):H2=H3(K)*D6^K7(N) +12040 P3=K6(N) +12050 P=ABS(P3):IFP4*H24.99THEN12100 +12090 ?"MINOR HIT ON ":GOTO12110 +12100 ?FNR(H2);"UNIT HIT ON "; +12110 M$=Q$(X8,Y8) +12120 IF M$="K"THEN?"KLINGON AT"; +12125 IFM$="C"THEN?"COMMANDER AT"; +12130 ?X8;"-";Y8 +12140 IFK6(N)<>0THEN12180 +12150 A5=X8:A6=Y8:T2$=Q$(X8,Y8):GOSUB6000 +12160 IFR1<>0THEN12250 +12170 F9=1:GOSUB10000:GOTO12250 +12180 IFK6(N)<0THEN12240 +12190 IFRND(1)<.9THEN12240 +12200 IFK6(N)>(.4+.4*RND(1))*P3THEN12240 +12205 ? +12210 ?"*** CAPTAIN, THE VESSEL AT SECTOR"; +12215 ?X8;"-";Y8 +12220 ?" HAS JUST LOST ITS FIREPOWER !!!" +12225 ? +12230 K6(N)=-K6(N) +12240 N=N+1 +12250 NEXTK +12260 RETURN +13001 J3=0 +13010 IFD4(7)<>0THEN13250 +13020 IFE1<=75THEN13070 +13030 INPUT"ENTER COURSE....";D2 +13040 IFD2<.01ORD2>12THENGOSUB40000ELSE13048 +13041 RETURN +13048 INPUT"DISTANCE ";D1:IFD1>0THEN13050 +13049 RETURN +13050 P3=50+250*D1 +13060 IFP375THEN13120 +13110 ?"QUADRANT. THEY ARE USELESS NOW.'":RETURN +13120 ?"QUADRANT. WE CAN GO A MAXIMUM OF "; +13130 ?FNR(4E-03*(E1-50)-.05);"QUADRANTS.'":RETURN +13140 T1=D1/.4 +13150 IFT1"Y"THENRETURN +13200 GOSUB15001:J3=1 +13210 IFA2<>0THENRETURN +13220 E1=E1-P3 +13230 IFE1>0THENRETURN +13240 F9=4:GOSUB10000:RETURN +13250 ?"IMPULSE ENGINES DAMAGED.":RETURN +14001 N$=" #" +14005 ? +14010 IFD4(2)<>0THEN14180 +14020 ?"L.R. SCAN FOR QUADRANT";Q1;"-";Q2:? +14030 I=Q1-1:J=Q1+1:K=Q2-1:L=Q2+1 +14040 FORM=ITOJ:FORN=KTOL +14050 IF(M<=0)OR(M>8)THEN14110 +14060 IF(N<=0)OR(N>8)THEN14110 +14070 IFD4(11)=0THENS2(M,N)=1 +14080 IFG(M,N)>=LQTHEN ?" ***";" "; +14090 IFG(M,N)B8THENB8=ABS(D6) +15040 D4=D4/B8:D6=D6/B8:T5=0:T6=0 +15050 IFD0+T110)THEN15150 +15106 IF(Y1<1)OR(Y1>10)THEN15150 +15108 IFQ$(X1,Y1)="O"THEN15111 +15109 IFQ$(X1,Y1)<>"."THEN15125 +15110 NEXTL +15111 D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +15112 S6=X1:S7=Y1 +15115 F4=S6:F5=S7 +15116 IFQ$(X1,Y1)<>"O"THEN15320 +15120 T2=FNA(1):T3=FNA(1) +15122 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):? +15123 ?"*** SPACE PORTAL ENTERED ***":GOTO15307 +15125 T6=1:K=50*D1/T1+.001:D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +15127 IF(Q$(X1,Y1)="K")OR(Q$(X1,Y1)="C")THEN15145 +15129 ?:?S5$;" BLOCKED BY "; +15130 IFQ$(X1,Y1)="*"THEN?"STAR AT"; +15131 IFQ$(X1,Y1)="B"THEN?"STARBASE AT"; +15132 ?" SECTOR";X1;"-";Y1;"...." +15133 ?"EMERGENCY STOP REQUIRED";FNR(K);"UNITS OF ENERGY." +15135 E1=E1-K +15137 S6=INT(X7-D4+.5):F4=S6:S7=INT(Y7-D6+.5):F5=S7 +15140 IFE1>0THEN15320 +15141 F9=4:GOSUB10000:RETURN +15145 S6=X1:S7=Y1:GOSUB22001:F4=S6:F5=S7:GOTO15320 +15150 IFK3=0THEN15165 +15155 FORL=1TOK3 +15156 F3=SQR((X1-K4(L))^2+(Y1-K5(L))^2) +15158 K8(L)=.5*(F3+K7(L)):NEXTL +15160 IFG(Q1,Q2)<>LQTHENGOSUB1000 +15162 IFA2<>0THENRETURN +15165 X7=10*(Q1-1)+S6:Y7=10*(Q2-1)+S7 +15170 X1=INT(X7+10*D1*B8*D4+.5) +15175 Y1=INT(Y7+10*D1*B8*D6+.5):L6=0 +15180 L5=0 +15185 IFX1>0THEN15195 +15190 X1=-X1+1:L5=1 +15195 IFY1>0THEN15210 +15200 Y1=-Y1+1:L5=1 +15210 IFX1<=80THEN15220 +15215 X1=161-X1:L5=1 +15220 IFY1<=80THEN15230 +15225 Y1=161-Y1:L5=1 +15230 IFL5=0THEN15240 +15235 L6=1:GOTO15180 +15240 IFL6=0THEN15270 +15260 ?:?"*** MESSAGE FROM STARFLEET COMMAND.....STARDATE";FNR(DO) +15261 ?"PERMISSION TO EXIT GALAXY - DENIED -" +15265 ?"'ENGINES SHUT DOWN AT "; +15266 Z1=INT((X1+9)/10):Z2=INT((Y1+9)/10) +15267 ?"QUADRANT";Z1;"-";Z2;", "; +15268 ?"SECTOR";X1-10*(Z1-1);"-";Y1-10*(Z2-1);"'" +15270 IFT5<>0THENRETURN +15295 Q1=INT((X1+9)/10):Q2=INT((Y1+9)/10) +15296 S6=X1-10*(Q1-1):S7=Y1-10*(Q2-1) +15307 GOSUB18400:?:GOTO15315 +15310 ?CHR$(26):?"ENTERING THE ";G2$;" QUADRANT (";Q1;"-";Q2;")" +15315 Q$(S6,S7)=LEFT$(S5$,1):GOSUB18000:GOSUB29002:GOSUB14001:RETURN +15320 Q$(S6,S7)=LEFT$(S5$,1) +15321 IFL6=1THENRETURN +15325 IFK3=0THEN15390 +15330 FORL=1TOK3 +15340 F3=SQR((F4-K4(L))^2+(F5-K5(L))^2) +15350 K8(L)=.5*(K7(L)+F3) +15360 K7(L)=F3 +15370 NEXTL +15380 GOSUB28000 +15390 GOSUB17000:RETURN +16001 A=1:B=1 +16010 FORK=1TOK3 +16020 C=K4(K):D=K5(K) +16030 IFQ$(C,D)="C"THEN16050 +16040 NEXTK +16050 N=0:F=K6(K)+100*K3 +16060 IFF>LQTHENN=INT(RND(1)*K7(K)+1) +16065 IF((C5$="DOCKED")AND((B4<>Q1)OR(B5<>Q2)))THENN=-S8 +16070 IFN=0THENN=INT(((F+200*RND(1))/150)-5) +16071 IFN=0THENRETURN +16072 IF(N>0)AND(K7(K)<1.5)THENRETURN +16075 IFABS(N)>S8THENN=SGN(N)*ABS(S8) +16080 T=ABS(N):P=S6-C:Q=S7-D +16085 IF2*ABS(P)0THENP=SGN(P*N) +16100 IFQ<>0THENQ=SGN(Q*N) +16105 R=C:S=D:Q$(C,D)="." +16110 FORL2=1TOT:L=R+P:M=S+Q +16115 IF(L>0)AND(L<=10)THEN16120 +16117 ONSGN(N)+2GOTO16240,16165,16165 +16120 IF(M>0)AND(M<=10)THEN16130 +16125 ONSGN(N)+2GOTO16240,16135,16135 +16130 IFQ$(L,M)="."THEN16195 +16135 IF(Q=B)OR(P=0)THEN16165 +16140 M=S+B +16145 IF(M>0)AND(M<=10)THEN16155 +16150 ONSGN(N)+2GOTO16240,16160,16160 +16155 IFQ$(L,M)="."THEN16195 +16160 B=-B +16165 IF(P=A)OR(Q=0)THEN16200 +16170 L=R+A +16175 IF(L>0)AND(L<=10)THEN16185 +16180 ONSGN(N)+2GOTO16240,16190,16190 +16185 IFQ$(L,M)="."THEN16195 +16190 A=-A:GOTO16200 +16195 R=L:S=M +16200 NEXTL2 +16205 Q$(R,S)="C" +16210 IF(R=C)AND(S=D)THENRETURN +16215 K4(K)=R:K5(K)=S:K7(K)=SQR((S6-R)^2+(S7-S)^2) +16220 K8(K)=K7(K):IFN>0THEN?"*** COMMANDER ADVANCES TO"; +16225 IFN<0THEN?"*** COMMANDER RETREATS TO"; +16230 ?" SECTOR";R;"-";S:GOSUB28000:RETURN +16240 I=Q1+INT((L+9)/10)-1:J=Q2+INT((M+9)/10)-1 +16245 IF(I<1)OR(I>8)THEN16350 +16250 IF(J<1)OR(J>8)THEN16350 +16260 FORL3=1TOR2 +16265 IF(C1(L3)=I)AND(C2(L3)=J)THEN16350 +16270 NEXTL3:?"*** COMMANDER ESCAPES TO "; +16275 ?"QUADRANT";I;"-";J;" (AND REGAINS STRENGTH)" +16280 K4(K)=K4(K3):K5(K)=K5(K3):K7(K)=K7(K3):K8(K)=K8(K3) +16285 K6(K)=K6(K3):K3=K3-1:C3=0 +16290 IFC5$<>"DOCKED"THENGOSUB17000 +16300 GOSUB28000 +16310 G(Q1,Q2)=G(Q1,Q2)-100:G(I,J)=G(I,J)+100 +16320 FORL3=1TOR2 +16330 IF(C1(L3)=Q1)AND(C2(L3)=Q2)THEN16340 +16335 NEXTL3 +16340 C1(L3)=I:C2(L3)=J:RETURN +16350 A=-A:B=-B:GOTO16200 +17000 C5$="GREEN":IFE199THENC5$="RED" +17030 RETURN +18000 J4=1:B6=0:B7=0:K3=0:C3=0:U=G(Q1,Q2):IFU>999THEN18290 +18030 K3=INT(.01*U):FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +18040 Q$(S6,S7)=LEFT$(S5$,1):U=G(Q1,Q2):IFU<100THEN18150 +18050 U=U-100*K3:FORA=1TOK3 +18060 S=FNB(1):K4(A)=S:T=FNB(1):K5(A)=T +18070 IFQ$(S,T)<>"."THEN18060 +18080 Q$(S,T)="K":K7(A)=SQR((S6-S)^2+(S7-T)^2):K8(A)=K7(A) +18090 K6(A)=RND(1)*150+325:NEXTA +18100 IFR2=0THEN18140 +18110 FORA=1TOR2 +18115 IF(C1(A)=Q1)AND(C2(A)=Q2)THEN18130 +18120 NEXTA:GOTO18140 +18130 Q$(S,T)="C":K6(K3)=LQ+400*RND(1):C3=1 +18140 GOSUB28000 +18150 IFU<10THEN18190 +18160 U=U-10 +18170 B6=FNB(1):B7=FNB(1):IFQ$(B6,B7)<>"."THEN18170 +18180 Q$(B6,B7)="B" +18190 GOSUB17000:IFU<1THENRETURN +18200 FORA=1TOU +18210 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN18210 +18220 Q$(S,T)="*":NEXTA +18230 IF(T2<>Q1)OR(T3<>Q2)THENRETURN +18240 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN18240 +18250 Q$(S,T)="O":? +18260 ?"*** SHORT-RANGE SENSORS DETECT A SPACE-WARP IN THIS QUADRANT" +18280 RETURN +18290 FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +18300 Q$(S6,S7)=LEFT$(S5$,1):RETURN +18400 G4$="III":L=2:IFQ2>=5THEN18420 +18410 L=1 +18420 G2$=G1$(2*(Q1-1)+L):L=Q2 +18425 IFL<=4THEN18440 +18430 L=Q2-4 +18440 G3$="IV":IFL=4THEN18460 +18450 G3$=LEFT$(G4$,L) +18460 G2$=G2$+" "+G3$:RETURN +19002 IFRND(1)>.1THEN19015 +19010 GOSUB27000:RETURN +19015 Q$(A5,A6)=".":?"*** STAR AT SECTOR";A5;"-";A6;"NOVAS." +19020 G(Q1,Q2)=G(Q1,Q2)-1:S1=S1+1 +19025 B9=1:T6=1:T7=1:K=0:X1=0:Y1=0 +19030 H4(B9,1)=A5:H4(B9,2)=A6 +19035 FORM=B9TOT6:FORQ=1TO3:FORJ=1TO3 +19040 IFJ*Q=4THEN19260 +19045 J5=H4(M,1)+Q-2:J6=H4(M,2)+J-2 +19050 IF(J5<1)OR(J5>10)THEN19260 +19055 IF(J6<1)OR(J6>10)THEN19260 +19060 IFQ$(J5,J6)="."THEN19260 +19065 IFQ$(J5,J6)="O"THEN19260 +19070 IFQ$(J5,J6)<>"*"THEN19105 +19075 IFRND(1)>=.1THEN19085 +19080 X2=J5:Y2=J6:GOSUB27000:RETURN +19085 T7=T7+1:H4(T7,1)=J5:H4(T7,2)=J6:G(Q1,Q2)=G(Q1,Q2)-1 +19090 S1=S1+1:?"*** STAR AT SECTOR";J5;"-";J6;"NOVAS." +19100 GOTO19255 +19105 IFQ$(J5,J6)<>"B"THEN19140 +19110 G(Q1,Q2)=G(Q1,Q2)-10:FORV=1TOR3 +19115 IF(B2(V)<>Q1)OR(B3(V)<>Q2)THEN19125 +19120 B2(V)=B2(R3):B3(V)=B3(R3) +19125 NEXTV:R3=R3-1:B6=0:B7=0:B1=B1+1:GOSUB17000 +19130 ?"*** STARBASE AT SECTOR";J5;"-";J6;"DESTROYED." +19135 GOTO19255 +19140 IF(S6<>J5)OR(S7<>J6)THEN19190 +19145 ?"*** STARSHIP BUFFETED BY NOVA.":IFS4<>0THEN19155 +19150 E1=E1-LQ:GOTO19170 +19155 IFS3>=LQTHEN19180 +19160 D6=LQ-S3:E1=E1-D6:GOSUB17000:S3=0:S4=0 +19165 ?"*** STARSHIP SHIELDS KNOCKED OUT.":D4(8)=5E-03*D5*RND(1))*D6 +19170 IFE1>0THEN19185 +19175 F9=7:GOSUB10000:RETURN +19180 S3=S3-LQ +19185 X1=X1+S6-H4(M,1):Y1=Y1+S7-H4(M,2):K=K+1:GOTO19260 +19190 IFQ$(J5,J6)<>"C"THEN19250 +19195 FORV=1TOK3 +19200 IF(K4(V)=J5)AND(K5(V)=J6)THEN19210 +19205 NEXTV +19210 K6(V)=K6(V)-800:IFK6(V)<=0THEN19250 +19215 N5=J5+J5-H4(M,1):N6=J6+J6-H4(M,2) +19220 ?"*** COMMANDER AT SECTOR";J5;"-";J6;"DAMAGED"; +19225 IF(N5<1)OR(N5>10)OR(N6<1)OR(N6>10)THEN19245 +19230 ?" AND BUFFETED TO SECTOR";N5;"-";N6 +19235 Q$(N5,N6)="C":K4(V)=N5:K5(V)=N6 +19240 K7(V)=SQR((S6-N5)^2+(S7-N6)^2):K8(V)=K7(V) +19241 Q$(J5,J6)="." +19245 ?:GOTO19260 +19250 A5=J5:A6=J6:T2$=Q$(J5,J6):GOSUB6000:GOTO19260 +19255 ?:Q$(J5,J6)="." +19260 NEXTJ:NEXTQ:NEXTM +19265 IFT6=T7THEN19280 +19270 B9=T6+1:T6=T7:GOTO19035 +19280 IFK=0THENRETURN +19290 D1=K*.1 +19300 IFX1<>0THENX1=SGN(X1) +19310 IFY1<>0THENY1=SGN(Y1) +19320 I=3*(X1+1)+Y1+2 +19330 D2=C5(I) +19340 IFD2=0THEND1=0 +19350 IFD1=0THENRETURN +19360 ?:?"FORCE OF NOVA DISPLACES STARSHIP." +19370 GOSUB15001:RETURN +20001 P=2:J3=1 +20020 IFC5$<>"DOCKED"THEN20030 +20025 ?"PHASERS CAN'T BE FIRED THRU BASE SHIELDS.":GOTO20080 +20030 IFD4(3)=0THEN20050 +20040 ?"PHASER BANKS DAMAGED.":GOTO20080 +20050 IFS4=0THEN20060 +20055 ?"SHIELDS MUST BE DOWN TO FIRE PHASERS.":GOTO20080 +20060 IFK3>0THEN20090 +20065 ? +20070 ?"THE SHORT-RANGE SENSORS DETECT NO ENEMY IN THIS QUADRANT." +20080 J3=0:RETURN +20090 ?"PHASERS LOCKED ON TARGET. ENERGY AVAILABLE="; +20095 ?.01*INT(100*E1) +20100 INPUT"UNITS TO FIRE";P1:IFP1=ETHEN20270 +20250 H3(I)=H5(I):E=E-R7 +20260 NEXTI:GOTO20280 +20270 H3(I)=H3(I)+E:E=0 +20280 GOSUB12001 +20290 IF(E<>0)AND(A2=0)THEN20310 +20300 J3=1:RETURN +20310 ?FNR(E);"EXPENDED ON EMPTY SPACE.":J3=1:RETURN +21001 J3=1:IFD4(4)=0THEN21015 +21010 ?"PHOTON TUBES DAMAGED.":GOTO21035 +21015 IFT4<>0THEN21025 +21020 ?"NO TORPEDOS LEFT.":GOTO21035 +21025 INPUT"TORPEDO COURSE";C6 +21030 IFC6<.01ORC6>12THENGOSUB40000ELSE21040 +21035 J3=0:RETURN +21040 INPUT"BURST OF 3";B$:N=1 +21045 IFLEFT$(B$,1)="N"THEN21070 +21050 IFLEFT$(B$,1)<>"Y"THEN21040 +21051 IFT4>2THEN21060 +21055 ?"NO BURST. ONLY";T4;"TORPEDOS LEFT.":GOTO21035 +21060 INPUT"SPREAD ANGLE (3 - 30 DEG)";G2 +21061 IFG2<0THEN21035 +21062 IF(G2<3)OR(G2>30)THEN21060 +21063 G2=FND(G2) +21065 N=3 +21070 FORZ6=1TON +21075 IFC5$<>"DOCKED"THENT4=T4-1 +21080 Z7=Z6:R=RND(1) +21085 R=(R+RND(1))*.5-.5 +21090 IF(R>=-.4)AND(R<=.4)THEN21125 +21095 R=(RND(1)+1.2)*R:IFN=3THEN21105 +21100 ?"*** METEORITE DEFLECTION":R=INT(RND(1)*50)+1 +21101 ?"TORPEDO EFFECTIVENESS REDUCED"; R;"%":?:GOTO21110 +21105 ?"*** TORPEDO NUMBER";Z6;"MISFIRE - ";R;"% DOWN" +21110 IF RND(1)>.2THEN21125 +21115 ?"*** PHOTON TUBES DAMAGED BY MISFIRE." +21120 D4(4)=D5*(1+2*RND(1)):GOTO21440 +21125 IF(S4<>0)OR(C5$="DOCKED")THENR=R+1E-03*S3*R +21130 A3=C6+.25*R:IFN=1THEN21140 +21135 A8=(15-A3+(2-Z6)*G2)*.523599:? +21137 ?"TRACK FOR TORPEDO NUMBER";Z7;"--":GOTO21145 +21140 ?:?"TORPEDO TRACK --":A8=(15-A3)*.523599 +21145 X4=-SIN(A8):Y4=COS(A8):B8=ABS(X4) +21146 IFABS(Y4)>ABS(X4)THENB8=ABS(Y4) +21150 X4=X4/B8:Y4=Y4/B8:X5=S6:Y5=S7 +21155 FORL9=1TO15:X5=X5+X4:A5=INT(X5+.5) +21160 IF(A5<1)OR(A5>10)THEN21430 +21165 Y5=Y5+Y4:A6=INT(Y5+.5) +21170 IF(A6<1)OR(A6>10)THEN21430 +21175 IF(L9=5)OR(L9=9)THEN? +21180 ?FNR(X5);"-";FNR(Y5);", "; +21185 IFQ$(A5,A6)<>"."THEN21195 +21190 GOTO21425 +21195 ?:IFQ$(A5,A6)="K"THEN21220 +21200 IFQ$(A5,A6)<>"C"THEN21325 +21205 IFRND(1)>.1THEN21220 +21210 ?"*** COMMANDER AT SECTOR";A5;"-";A6;"USES ANTI-PHOTON DEVICE !" +21215 ?"-- TORPEDO NEUTRALIZED.":GOTO21435 +21220 FORV=1TOK3 +21225 IF(A5=K4(V))AND(A6=K5(V))THEN21235 +21230 NEXTV +21235 K=K6(V):W3=200+800*RND(1) +21240 IFABS(K)0THEN21255 +21250 T2$=Q$(A5,A6):GOSUB6000:GOTO21435 +21255 IFQ$(A5,A6)="K"THEN?"*** KLINGON AT"; +21260 IFQ$(A5,A6)="C"THEN?"*** COMMANDER AT"; +21265 ?A5;"-";A6; +21270 A7=A8+2.5*(RND(1)-.5) +21275 W3=ABS(-SIN(A7)):IFABS(COS(A7))>W3THENW3=ABS(COS(A7)) +21280 X7=-SIN(A7)/W3:Y7=COS(A7)/W3 +21285 P=INT(A5+X7+.5):Q=INT(A6+Y7+.5) +21290 IF(P<1)OR(P>10)OR(Q<1)OR(Q>10)THEN21320 +21295 IFQ$(P,Q)<>"."THEN21320 +21300 Q$(P,Q)=Q$(A5,A6):Q$(A5,A6)=".":?"DAMAGED--" +21305 ?" DISPLACED BY BLAST TO SECTOR";P;"-";Q +21310 K4(V)=P:K5(V)=Q:K7(V)=SQR((S6-P)^2+(S7-Q)^2) +21311 K8(V)=K7(V) +21315 GOSUB28000:GOTO21435 +21320 ?"DAMAGED, BUT NOT DESTROYED.":GOTO21435 +21325 IFQ$(A5,A6)<>"B"THEN21365 +21330 ?"*** STARBASE DESTROYED...!!!" +21335 IFS2(Q1,Q2)<0THENS2(Q1,Q2)=0 +21340 FORW=1TOR3 +21345 IF(B2(W)<>Q1)OR(B3(W)<>Q2)THEN21355 +21350 B2(W)=B2(R3):B3(W)=B3(R3) +21355 NEXTW:Q$(A5,A6)=".":R3=R3-1:B6=0:B7=0 +21360 G(Q1,Q2)=G(Q1,Q2)-10:B1=B1+1:GOSUB17000:GOTO21435 +21365 IFQ$(A5,A6)<>"*"THEN21405 +21370 IFRND(1)>.15THEN21385 +21375 ?"*** STAR AT SECTOR";A5;"-";A6;"UNAFFECTED BY PHOTON BLAST" +21380 GOTO21435 +21385 X2=A5:Y2=A6:GOSUB19002:A5=X2:A6=Y2 +21390 IFG(Q1,Q2)=LQTHENRETURN +21395 IFA2<>0THENRETURN +21400 GOTO21435 +21405 ?:?" >>> ORGANIAN TRUCE-MONITOR DESTROYED <<<":Q$(A5,A6)=".":? +21420 T2=0:T3=0:GOTO21435 +21425 NEXTL9 +21430 ?:?"TORPEDO MISSED!" +21435 NEXTZ6 +21440 IFR1<>0THENRETURN +21445 F9=1:GOSUB10000:RETURN +22001 ?:?"*** RED ALERT!! RED ALERT!! ***":? +22010 ?"*** COLLISION IMMINENT!!":? +22020 ?"*** ";S5$;" RAMS ";:W7=1:IFQ$(S6,S7)="C"THENW7=2 +22030 IFW7=1THEN?"KLINGON AT "; +22040 IFW7=2THEN?"COMMANDER AT "; +22050 ?"SECTOR";S6;"-";S7:A5=S6:A6=S7:T2$=Q$(S6,S7) +22060 GOSUB6000:?"*** ";S5$;" HEAVILY DAMAGED." +22070 K=INT(5+RND(1)*20):?"***SICKBAY REPORTS";K;"CASUALTIES!" +22080 C4=C4+K:FORL=1TO12:I=RND(1) +22090 J=(3.5*W7*(RND(1)+I)+1)*D5 +22100 IFL=6THENJ=J/3 +22110 D4(L)=D4(L)+T1+J:NEXTL:D4(6)=D4(6)-3 +22120 IFD4(6)<0THEND4(6)=0 +22130 S4=0:IFR1<>0THENRETURN +22140 F9=1:GOSUB10000:RETURN +23000 P=D0-J2:IF(P<>0)AND(R1=0)THEN23020 +23010 IFP<5THENP=5 +23020 N=(K2+K1)/P:K=INT(500*N+.5):L=0 +23030 IFG1<>0THENL=100*S8 +23035 I=0 +23040 IFLEFT$(S5$,1)="E"THENM=0 +23045 IFLEFT$(S5$,1)="F"THENM=1 +23050 IFLEFT$(S5$,1)=""THENM=2 +23060 IFA1=0THENI=200 +23070 J=10*K1+50*K2+K+L-I-100*B1-100*M-35*N1-3*S1-C4 +23080 ?:IFJ<>0THEN23100 +23090 ?"AS YET, YOU HAVE NO SCORE.":RETURN +23100 ?"YOUR SCORE --":?:IFK1=0THEN23120 +23110 ?K1;TAB(5);"ORDINARY KLINGON(S) DESTROYED";TAB(36);10*K1*MR +23120 IFK2=0THEN23140 +23130 ?K2;TAB(5);"KLINGON COMMANDER(S) DESTROYED";TAB(36);50*K2*MR +23140 IFK=0THEN23160 +23150 ?FNR(N);TAB(5);"KLINGONS PER STARDATE, AVERAGE"; +23155 ?TAB(36);K*MR +23160 IFS1=0THEN23180 +23170 ?S1;TAB(5);"STAR(S) DESTROYED";TAB(36);-3*S1*MR +23180 IFB1=0THEN23200 +23190 ?B1;TAB(5);"STARBASES DESTROYED";TAB(36);-100*B1*MR +23200 IFN1=0THEN23220 +23210 ?N1;TAB(5);"SOS CALL(S) TO A STARBASE";TAB(36);-35*N1*MR +23220 IFC4=0THEN23240 +23230 ?C4;TAB(5);"CASUALTIES INCURRED";TAB(36);-C4*MR +23240 IFM=0THEN23260 +23250 ?M;TAB(5);"SHIP(S) LOST OR DESTROYED";TAB(36)-100*M*MR +23260 IFA1<>0THEN23280 +23270 ?TAB(5)"PENALTY FOR GETTING KILLED";TAB(36);-200*MR +23280 IFG1=0THEN23300 +23290 ?TAB(5);"BONUS FOR WINNING ";S$(S8);" GAME";TAB(36);L*MR +23300 ?TAB(5);"-------------------------------------" +23310 ?TAB(28);"TOTAL";TAB(36);J*MR;"**":RETURN +24001 A2=0:G1=0:GOSUB4001:S5$="ENTERPRISE" +24010 I7=5000:E1=I7:I8=2500:S3=I8:S4=0:S9=S4:J1=4:L1=J1 +24020 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):I9=10:T4=I9 +24030 W1=5:W2=25:FORI=1TO12:D4(I)=0:NEXT +24040 J2=100*INT(31*RND(1)+20):D0=J2:K1=0:K2=0:N1=0:N2=0:R6=0:C4=0 +24050 A1=1:D3=.25:FORI=1TO8:FORJ=1TO8:S2(I,J)=0:NEXTJ:NEXTI +24060 F1(1)=D0-.5*I5*LOG(RND(1)):F1(5)=1E+30 +24070 F1(2)=D0-1.5*(I5/R2)*LOG(RND(1)):I6=0 +24080 F1(3)=D0-.3*I5*LOG(RND(1)):F1(4)=D0-.3*I5*LOG(RND(1)) +24090 FORI=1TO8:FORJ=1TO8:K=INT(RND(1)*9+1):I6=I6+K +24100 G(I,J)=K:NEXTJ:NEXTI:S1=0 +24110 FOR I=1TOI2 +24120 X=INT(RND(1)*6+2):Y=INT(RND(1)*6+2) +24130 IFG(X,Y)>=10THEN24120 +24140 IFI<2THEN24180 +24150 K=I-1:FORJ=1TOK:D1=SQR((B2(J)-X)^2+(B3(J)-Y)^2) +24160 IFD1<2THEN24120 +24170 NEXTJ +24180 B2(I)=X:B3(I)=Y:S2(X,Y)=-1:G(X,Y)=G(X,Y)+10:NEXTI +24190 B1=0:K=I1-I4:L=INT(.25*S8*(9-L2)+1) +24200 M=INT((1-RND(1)^2)*L):IFM>KTHENM=K +24210 N=100*M +24220 X=FNA(1):Y=FNA(1):IFG(X,Y)+N>999THEN24220 +24230 G(X,Y)=G(X,Y)+N:K=K-M:IFK<>0THEN24200 +24240 FORI=1TOI4 +24250 X=FNA(1):Y=FNA(1):IF(G(X,Y)<99)AND(RND(1)<.75)THEN24250 +24260 IFG(X,Y)>899THEN24250 +24270 IFI=1THEN24300 +24280 M=I-1:FORJ=1TOM:IF(C1(J)=X)AND(C2(J)=Y)THEN24250 +24290 NEXTJ +24300 G(X,Y)=G(X,Y)+100:C1(I)=X:C2(I)=Y:NEXTI +24305 I=INT(D0):?:S0=0 +24310 T2=FNA(1):T3=FNA(1):IFG(T2,T3)<100THEN24310 +24320 IFS8<>1THEN24440 +24330 ?"IT IS STARDATE";I;"...THE ORGANIAN PEACE TREATY BETWEEN" +24340 ?"THE UNITED FEDERATION OF PLANETS AND THE KLINGON EMPIRE" +24350 ?"HAS COLLAPSED AND THE FEDERATION IS BEING ATTACKED BY A" +24360 ?"DEADLY KLINGON INVASION FLEET. AS CAPTAIN OF THE STARSHIP" +24370 ?"U.S.S. ENTERPRISE, IT IS YOUR MISSION TO SEEK OUT AND" +24380 ?"DESTROY THIS INVASION FORCE OF";I1;"BATTLE CRUISERS." +24390 ?:?"YOU HAVE AN INITIAL ALLOTMENT OF";INT(I5); +24400 ?"STARDATES":?"TO COMPLETE YOUR MISSION." +24410 ?"AS THE MISSION PROCEEDS, YOU MAY BE GIVEN MORE TIME." +24420 ?:?"YOU WILL HAVE";I2;"SUPPORTING STARBASE(S).":? +24430 GOTO24515 +24440 ?"STARDATE..............";I +24450 ?"NUMBER OF KLINGONS....";I1 +24460 ?"NUMBER OF STARDATES...";INT(I5) +24470 ?"NUMBER OF STARBASES...";I2 +24480 ?"STARBASE LOCATIONS...."; +24490 FORI=1TOI2:?B2(I);"-";B3(I); +24500 IFI<>I2THEN?", "; +24510 NEXTI:?:? +24515 GOSUB18400 +24520 ?"THE ";S5$;" IS CURRENTLY IN THE ";G2$;" QUADRANT." +24530 GOSUB18000 +24531 ?:INPUT"READY TO CONTINUE";NL$:?CHR$(26):GOSUB29002:GOSUB14001:RETURN +25010 INPUT"WARP FACTOR";K +25020 ? +25025 IFK<1THEN25140 +25026 IFK>10THEN25150 +25030 J=W1:W1=K:W2=W1*W1 +25040 IF(W1<=J)OR(W1<=6)THEN25070 +25050 IFW1<=8THEN25080 +25060 IFW1>8THEN25100 +25070 ?"'WARP FACTOR";W1;"CAPTAIN'":RETURN +25080 ?"*** OUR MAXIMUM SAFE SPEED IS WARP 6":RETURN"; +25100 IFW1=10THEN25130 +25110 ?"*** CAPTAIN, OUR ENGINES MAY NOT TAKE IT !":RETURN +25130 ?"-'AYE, CAPTAIN, WE'LL GIVE IT A TRY.'":RETURN +25140 ?"-'WE CAN'T GO BELOW WARP 1, CAPTAIN.'":RETURN +25150 ?"-'OUR TOP SPEED IS WARP 10, CAPTAIN.'" +25160 RETURN +26001 J3=0:IFD4(8)<>0THEN26600 +26010 IFS4<>0THEN26530 +26500 INPUT"SHIELDS ARE DOWN. DO YOU WANT THEM UP";B$ +26510 IFLEFT$(B$,1)="Y"THEN26560 +26520 RETURN +26530 INPUT"SHIELDS ARE UP. DO YOU WANT THEM DOWN";B$ +26540 IFLEFT$(B$,1)="Y"THEN26590 +26550 RETURN +26560 S4=1:S9=1:IFC5$<>"DOCKED"THENE1=E1-50 +26570 ?"SHIELDS RAISED.":IFE1<=0THEN26610 +26580 J3=1:RETURN +26590 S4=0:S9=1:?"SHIELDS LOWERED.":J3=1:RETURN +26600 ?"SHIELDS DAMAGED AND DOWN. ":RETURN +26610 ?:?"SHIELDS CONSUME ALL ENERGY." +26620 F9=4:GOSUB10000:RETURN +27000 IFX2<>0THEN27100 +27010 N=INT(RND(1)*I6+1):FORX=1TO8:FORY=1TO8 +27020 N=N-(G(X,Y)-INT(G(X,Y)/10)*10):IFN<=0THEN27040 +27030 NEXTY:NEXTX:RETURN +27040 IF(X<>Q1)OR(Y<>Q2)THEN27150 +27050 IFJ4<>0THEN27150 +27060 N=INT(RND(1)*(G(X,Y)-INT(G(X,Y)/10)*10))+1 +27070 FORX3=1TO10:FORY3=1TO10:IFQ$(X3,Y3)<>"*"THEN27090 +27080 N=N-1:IFN=0THEN27100 +27090 NEXTY3:NEXTX3 +27100 ?:?"*** RED ALERT!! RED ALERT!! *** +27105 X3=X2:Y3=Y2 +27110 ?"*** INCIPIENT SUPERNOVA DETECTED AT SECTOR";X3;"-";Y3 +27120 X=Q1:Y=Q2:K=(X2-S6)^2+(Y2-S7)^2 +27130 IFK>1.5THEN27180 +27140 ?"*** EMERGENCY AUTO-OVERRIDE JAMMED ***":A2=1:GOTO27180 +27150 IFD4(9)<>0THEN27180 +27160 ?:?"MESSAGE FROM STARFLEET COMMAND...STARDATE";INT(D0) +27170 ?"'SUPERNOVA IN QUADRANT";X;"-";Y; +27175 ?"....CAUTION ADVISED'" +27180 N=G(X,Y):R=INT(N/100):Q=0 +27190 IF(X<>Q1)OR(Y<>Q2)THEN27210 +27200 K3=0:C3=0 +27210 IFR=0THEN27270 +27220 R1=R1-R:IFR2=0THEN27270 +27230 FORL=1TOR2:IF(C1(L)<>X)OR(C2(L)<>Y)THEN27260 +27240 C1(L)=C1(R2):C2(L)=C2(R2):C1(R2)=0:C2(R2)=0 +27250 R2=R2-1:R=R-1:Q=1:IFR2=0THENF1(2)=1E+30 +27260 NEXTL +27270 IFR3=0THEN27310 +27280 FORL=1TOR3:IF(B2(L)<>X)OR(B3(L)<>Y)THEN27300 +27290 B2(L)=B2(R3):B3(L)=B3(R3):B2(R3)=0:B3(R3)=0:R3=R3-1 +27300 NEXTL +27310 IFX2=0THEN27350 +27320 N=G(X,Y)-INT(G(X,Y)/100)*100 +27330 S1=S1+(N-INT(N/10)*10):B1=B1+INT(N/10) +27340 K1=K1+R:K2=K2+Q +27350 IF(S2(X,Y)<>0)AND(D4(9)<>0)THENS2(X,Y)=LQ+G(X,Y) +27360 IF(D4(9)=0)OR((Q1=X)AND(Q2=Y))THENS2(X,Y)=1 +27370 G(X,Y)=1000 +27380 IF(R1<>0)OR((X=Q1)AND(Y=Q2))THEN27430 +27390 ?CHR$(26):?"*** SUPERNOVA IN QUADRANT";X;"-";Y;"HAS DESTROYED THE" +27400 ?"REMAINDER OF THE ENEMY FLEET !!" +27420 F9=1:GOSUB10010:RETURN +27430 IFA2=0THENRETURN +27440 F9=8:GOSUB10010:RETURN +28000 IFK3<=1THENRETURN +28010 Z4=0:FORO=1TOK3-1:IFK7(O)<=K7(O+1)THEN28080 +28020 K=K7(O):K7(O)=K7(O+1):K7(O+1)=K +28030 K=K8(O):K8(O)=K8(O+1):K8(O+1)=K +28040 K=K4(O):K4(O)=K4(O+1):K4(O+1)=K +28050 K=K5(O):K5(O)=K5(O+1):K5(O+1)=K +28060 K=K6(O):K6(O)=K6(O+1):K6(O+1)=K +28070 Z4=1 +28080 NEXTO +28090 IFZ4<>0THEN28010 +28100 RETURN +29002 IFD(1)<>0THEN29230 +29010 ?:?" 1 2 3 4 5 6 7 8 9 10" +29020 FORI=1TO10:IFI<10THEN?" "; +29030 ?I;:FORJ=1TO10:?Q$(I,J);" ";:NEXTJ +29040 ONIGOTO29050,29060,29080,29090,29140 +29045 ONI-5GOTO29150,29160,29170,29200,29210 +29050 ?" STARDATE ";FNR(D0):GOTO29220 +29060 IFC5$<>"DOCKED"THENGOSUB17000 +29070 ?" CONDITION ";C5$:GOTO29220 +29080 ?" POSITION ";Q1;"-";Q2;", ";S6;"-";S7:GOTO29220 +29090 ?" LIFE SUPPORT ";:IFD4(5)<>0THEN29110 +29100 ?"ACTIVE":GOTO29220 +29110 IFC5$<>"DOCKED"THEN29130 +29120 ?"DAMAGED, SUPPORTED BY STARBASE":GOTO29220 +29130 ?"DAMAGED, RESERVES=";FNS(L1):GOTO29220 +29140 ?" WARP FACTOR ";FNR(W1):GOTO29220 +29150 ?" ENERGY";SPC(8);.01*INT(100*E1):GOTO29220 +29160 ?" TORPEDOS ";T4:GOTO29220 +29170 ?" SHIELDS ";:B$="DOWN,":IFS4<>0THENB$="UP," +29180 IFD4(8)>0THENB$="DAMAGED," +29190 ?B$;INT(100*S3/I8+.5);"%":GOTO29220 +29200 ?" KLINGONS LEFT ";R1:GOTO29220 +29210 ?" TIME LEFT ";FNS(R5) +29220 NEXTI:RETURN +29230 ?"SHORT RANGE SENSORS DAMAGED.":RETURN +30001 ?:?"*** TIME WARP ENTERED ***":?"YOU ARE TRAVELING "; +30010 IFS0<>0THEN30050 +30020 T1=-.5*I5*LOG(RND(1)) +30030 ?"FORWARD IN TIME";FNR(T1);"STARDATES." +30040 F1(2)=F1(2)+T1:GOTO30200 +30050 M=D0:D0=D9(1) +30060 ?"BACKWARD IN TIME";FNR(M-D0);"STARDATES.":S0=0 +30070 R1=D9(2):R2=D9(3):R3=D9(4):R4=D9(5):R5=D9(6) +30080 S1=D9(7):B1=D9(8):K1=D9(9):K2=D9(10) +30090 FORI=1TO8:FORJ=1TO8:G(I,J)=D9(I-1+8*(J-1)+11):NEXTJ:NEXTI +30100 FORI=75TO84:C1(I-74)=D9(I):NEXT +30110 FORI=85TO94:C2(I-84)=D9(I):NEXT +30120 FORI=95TO99:B2(I-94)=D9(I):NEXT +30130 FORI=100TO104:B3(I-99)=D9(I):NEXT:B4=D9(105):B5=D9(106) +30140 F1(1)=D0-.5*I5*LOG(RND(1)) +30150 IFR2<>0THENF1(2)=D0-(I5/R2)*LOG(RND(1)) +30160 F1(3)=D0-.5*I5*LOG(RND(1)) +30170 FORI=1TO8:FORJ=1TO8:IF10THEN31120 +31020 INPUT"NUMBER OF UNITS TO SHIELDS";Z3 +31030 IFZ3<0THENRETURN +31040 IFE1+S3-Z3>0THEN31060 +31050 ?"SCOTT HERE- 'WE ONLY HAVE";FNR(E1+S3);"UNITS LEFT.'" +31051 RETURN +31060 E1=E1+S3-Z3:S3=Z3:?"--ENERGY TRANSFER COMPLETE--" +31070 ?"(SHIP ENERGY=";FNR(E1);" SHIELD ENERGY=";FNR(S3);")" +31075 J3=1 +31080 T1=.1:P5=(K3+4*C3)/48:IFP5<.1THENP5=.1 +31090 IFP5>RND(1)THENGOSUB1000 +31100 IFA2<>0THENRETURN +31110 GOSUB9000:RETURN +31120 ?"TRANSFER PANEL DAMAGED.":RETURN +32001 INPUT"WHICH DIRECTION";Z +32002 IFZ<.01ORZ>12THENGOSUB40000ELSE32020 +32005 J3=0:RETURN +32020 T1=.05:P=(K3+4*C3)/48:IFP<.05THENP=.05 +32030 IFP>RND(1)THENGOSUB1000 +32040 IFA2<>0THENRETURN +32050 GOSUB9000:J3=1:IFA2<>0THENRETURN +32080 D5=INT((Z/12)*8+1.5):IFD5>8THEND5=1 +32085 FORI=1TO5:FORJ=1TO5:V$(I,J)=" ":NEXTJ:NEXTI:N=0 +32087 V$(3,3)=LEFT$(S5$,1) +32090 OND5GOTO32100,32130,32150,32170,32190,32220,32260,32300 +32100 I=S6-2:J=S7-2:V$(1,1)=Q$:IF(J>0)AND(I>0)THENV$(1,1)=Q$(I,J) +32110 I=S6-1:J=S7-1:V$(2,2)=Q$:IF(I>0)AND(J>0)THENV$(2,2)=Q$(I,J) +32120 N=N+1:IFN=3THEN32350 +32125 I=S6-2:V$(1,2)=Q$:IF(I>0)AND(J>0)THENV$(1,2)=Q$(I,J) +32130 I=S6-2:V$(1,3)=Q$:IFI>0THENV$(1,3)=Q$(I,S7) +32135 I=S6-1:V$(2,3)=Q$:IFI>0THENV$(2,3)=Q$(I,S7) +32140 N=N+1:IFN=3THEN32350 +32145 I=S6-2:J=S7+1:V$(1,4)=Q$:IF(I>0)AND(J<11)THENV$(1,4)=Q$(I,J) +32150 I=S6-2:J=S7+2:V$(1,5)=Q$:IF(I>0)AND(J<11)THENV$(1,5)=Q$(I,J) +32155 I=S6-1:J=S7+1:V$(2,4)=Q$:IF(I>0)AND(J<11)THENV$(2,4)=Q$(I,J) +32160 N=N+1:IFN=3THEN32350 +32165 J=S7+2:V$(2,5)=Q$:IF(I>0)AND(J<11)THENV$(2,5)=Q$(I,J) +32170 J=S7+2:V$(3,5)=Q$:IFJ<11THENV$(3,5)=Q$(S6,J) +32175 J=S7+1:V$(3,4)=Q$:IFJ<11THENV$(3,4)=Q$(S6,J) +32180 N=N+1:IFN=3THEN32350 +32185 I=S6+1:J=S7+2:V$(4,5)=Q$:IF(I<11)AND(J<11)THENV$(4,5)=Q$(I,J) +32190 I=S6+2:J=S7+2:V$(5,5)=Q$:IF(I<11)AND(J<11)THENV$(5,5)=Q$(I,J) +32195 I=S6+1:J=S7+1:V$(4,4)=Q$:IF(I<11)AND(J<11)THENV$(4,4)=Q$(I,J) +32200 N=N+1:IFN=3THEN32350 +32210 I=S6+2:V$(5,4)=Q$:IF(I<11)AND(J<11)THENV$(5,4)=Q$(I,J) +32220 I=S6+2:V$(5,3)=Q$:IFI<11THENV$(5,3)=Q$(I,S7) +32230 I=S6+1:V$(4,3)=Q$:IFI<11THENV$(4,3)=Q$(I,S7) +32240 N=N+1:IFN=3THEN32350 +32250 I=S6+2:J=S7-1:V$(5,2)=Q$:IF(I<11)AND(J>0)THENV$(5,2)=Q$(I,J) +32260 I=S6+2:J=S7-2:V$(5,1)=Q$:IF(I<11)AND(J>0)THENV$(5,1)=Q$(I,J) +32270 I=S6+1:J=S7-1:V$(4,2)=Q$:IF(I<11)AND(J>0)THENV$(4,2)=Q$(I,J) +32280 N=N+1:IFN=3THEN32350 +32290 J=S7-2:V$(4,1)=Q$:IF(I<11)AND(J>0)THENV$(4,1)=Q$(I,J) +32300 J=S7-2:V$(3,1)=Q$:IFJ>0THENV$(3,1)=Q$(S6,J) +32310 J=S7-1:V$(3,2)=Q$:IFJ>0THENV$(3,2)=Q$(S6,J) +32320 N=N+1:IFN=3THEN32350 +32330 I=S6-1:J=S7-2:V$(2,1)=Q$:IF(I>0)AND(J>0)THENV$(2,1)=Q$(I,J) +32340 GOTO32100 +32350 FORI=1TO5 +32360 IF(V$(I,1)=" ")AND(V$(I,3)=" ")AND(V$(I,5)=" ")THEN32390 +32370 ?" "; +32380 FORJ=1TO5:?V$(I,J);" ";:NEXTJ:? +32390 NEXTI:RETURN +33001 J3=0:INPUT"HOW MANY STARDATES";Z5:IF(Z5"Y"THENRETURN +33030 R6=1 +33040 IFZ5<=0THENR6=0 +33050 IFR6=0THENRETURN +33060 T1=Z5:Z6=Z5 +33070 IFK3=0THEN33100 +33080 T1=1+RND(1):IFZ50THENRETURN +33120 GOSUB9000:J3=1:IFA2<>0THENRETURN +33130 Z5=Z5-Z6:GOTO33040 +34001 J3=0:IFD4(6)<>0THEN34750 +34010 INPUT"ENTER COURSE...";D2:IFD2<.01ORD2>12THENGOSUB40000ELSE34013 +34012 RETURN +34013 INPUT"DISTANCE...";D1:IFD1<=0THENRETURN +34030 P=(D1+.05)*W1*W1*W1*(S4+1):IFPE1)THEN34080 +34060 ?" WE HAVEN'T THE ENERGY TO GO THAT FAR WITH"; +34070 ?" THE SHIELDS UP.":RETURN +34080 W=INT((E1/(D1+.05))^.333333):IFW<=0THEN34130 +34090 ?" WE HAVEN'T THE ENERGY. BUT WE COULD DO IT AT WARP";W +34100 IFS4<>0THEN34120 +34110 RETURN +34120 ?" IF YOU'LL LOWER THE SHIELDS.":RETURN +34130 ?" WE CAN'T DO IT, CAPTAIN. WE HAVEN'T GOT THE ENERGY." +34140 RETURN +34150 T1=10*D1/W2:IFT1<.8*R5THEN34500 +34160 ?:?"MR. SPOCK - 'CAPTAIN, I COMPUTE THAT SUCH A TRIP" +34170 ?" WILL REQUIRE APPROXIMATELY";FNR(100*T1/R5); +34180 ?"PERCENT":?" OF OUR REMAINING TIME. ARE YOU SURE "; +34190 INPUT "THIS IS WISE";B$:IFLEFT$(B$,1)="Y"THEN34500 +34200 J3=0:RETURN +34500 Q4=0:W=0:IFW1<=6THEN34660 +34510 P=D1*(6-W1)^2/66.6667:IFP>RND(1)THENQ4=1 +34520 IFQ4<>0THEND1=RND(1)*D1 +34530 W=0:IFW1<10THEN34550 +34540 IF.25*D1>RND(1)THENW=1 +34550 IF(Q4=0)AND(W=0)THEN34660 +34560 A=(15-D2)*.5236:X1=-SIN(A):X2=COS(A) +34570 B8=ABS(X1):IFABS(X2)>ABS(X1)THENB8=ABS(X2) +34580 X1=X1/B8:Y1=Y1/B8:N=INT(10*D1*B8+.5):X=S6:Y=S7 +34590 IFN=0THEN34660 +34600 FORL=1TON +34610 X=X+X1:Q=INT(X+.5):IF(Q<1)OR(Q>10)THEN34660 +34620 Y=Y+Y1:R=INT(Y+.5):IF(R<1)OR(R>10)THEN34660 +34630 IFQ$(Q,R)="."THEN34650 +34640 Q4=0:W=0 +34650 NEXTL +34660 GOSUB15001:IFA2<>0THENRETURN +34670 E1=E1-D1*W1*W1*W1*(S4+1):IFE1>0THEN34690 +34680 F9=4:GOSUB10000:RETURN +34690 T1=10*D1/W2:IFW<>0THENGOSUB30001 +34700 IFQ4=0THEN34740 +34710 ?:?"ENGINEERING TO BRIDGE--":?" SCOTT HERE- "; +34715 ?"'WE'VE JUST BLOWN THE WARP ENGINES." +34720 ?" WE'LL HAVE TO SHUT 'ER DOWN HERE, CAPTAIN.'" +34725 D4(6)=D5*(3*RND(1)+1) +34740 J3=1:RETURN +34750 ?"WARP ENGINES DAMAGED.":RETURN +35001 ONSGN(D4(10))+2GOTO35010,35030,35020 +35010 ?"YE FAERIE QUEENE HAS NO SHUTTLE CRAFT.":RETURN +35020 ?"SHUTTLE CRAFT DAMAGED.":RETURN +35030 ?:?"***ABANDON SHIP! ABANDON SHIP!" +35040 ?"***ALL HANDS ABANDON SHIP!":? +35050 ?"YOU AND THE BRIDGE CREW ESCAPE IN THE GALILEO." +35060 ?"THE REMAINDER OF THE CREW BEAMS DOWN" +35070 ?"TO THE NEAREST HABITABLE PLANET.":IFR3<>0THEN35090 +35080 F9=9:GOSUB10000:RETURN +35090 ?:?"YOU ARE CAPTURED BY KLINGONS AND RELEASED TO" +35100 ?"THE FEDERATION IN A PRISONER-OF-WAR EXCHANGE." +35110 ?"STARFLEET PUTS YOU IN COMMAND OF ANOTHER SHIP," +35120 ?"THE FAERIE QUEENE WHICH IS ANTIQUATED, BUT" +35130 ?"STILL USABLE.":N=INT(RND(1)*R3+1):Q1=B2(N):Q2=B3(N) +35140 S6=5:S7=5:GOSUB18000:Q$(S6,S7)="." +35145 FORL=1TO3:S6=INT(3*RND(1)-1+B6) +35150 IF(S6<1)OR(S7>10)THEN35180 +35160 S7=INT(3*RND(1)-1+B7):IF(S7<1)OR(S7>10)THEN35180 +35170 IFQ$(S6,S7)="."THEN35190 +35180 NEXTL:GOTO35140 +35190 S5$="FAERIE QUEENE":Q$(S6,S7)=LEFT$(S5$,1):C5$="DOCKED" +35200 FORL=1TO12:D4(L)=0:NEXT:D4(10)=-1:E1=3000:I7=E1 +35210 S3=1500:I8=S3:T4=6:I9=T4:L1=3:J1=L1:S4=0:W1=5:W2=25 +35220 RETURN +36001 IFD4(11)=0THEN36030 +36010 ?"COMPUTER DAMAGED - CANNOT EXECUTE DESTRUCT SEQUENCE" +36020 RETURN +36030 ?:?" ---WORKING---" +36040 ?"IDENTIFICATION-POSITIVE" +36050 ?"SELF-DESTRUCT-SEQUENCE-ACTIVATED":J=3 +36060 FORI=10TO6STEP-1:?SPC(J);I:GOSUB36210:J=J+3:NEXT +36070 ?"ENTER-YOUR-MISSION-PASSWORD-TO-CONTINUE" +36080 ?"SELF-DESTRUCT-SEQUENCE-OTHERWISE-DESTRUCT" +36090 ?"SEQUENCE-WILL-BE-ABORTED" +36100 INPUTB$:IFB$<>X$THEN36190 +36110 ?"PASSWORD-ACCEPTED":J=10 +36120 FORI=5TO1STEP-1:?SPC(J);I:GOSUB36210:J=J+3:NEXT +36130 ?:?"*****ENTROPY OF ";S5$;" MAXIMIZED*****" +36140 ?:IFK3=0THEN36180 +36150 W=20*E1:FORL=1TOK3:IFK6(L)*K7(L)>WTHEN36170 +36160 A5=K4(L):A6=K5(L):T2$=Q$(A5,A6):GOSUB6000 +36170 NEXTL +36180 F9=10:GOSUB10000:RETURN +36190 ?"PASSWORD-REJECTED" +36200 ?"CONTINUITY-EFFECTED":?:RETURN +36210 K=12345:FORM=1TO90:K=K+1:NEXTM:RETURN +37001 FORI=1TO10:GOTO29040:RETURN +40000 ?"---> COURSE(S) .01-12 ONLY !!!":RETURN + \ No newline at end of file diff --git a/disks/images/b/BIOCAL.ASC b/disks/images/b/BIOCAL.ASC new file mode 100644 index 0000000..a1e4081 --- /dev/null +++ b/disks/images/b/BIOCAL.ASC @@ -0,0 +1,170 @@ +100 REM***************************************************************** +110 REM +120 REM BIORHYTHM WALL CALENDAR +130 REM +140 REM WRITTEN BY +150 REM +160 REM RON WILLIAMS +170 REM 1845 COCHRAN RD. +180 REM MORGAN HILL, CA 95037 +190 REM (408) 779-8655 +200 REM +210 REM BASED ON A CONCEPT BY +220 REM DR. ROBERT SMITH AT +230 REM CONTROL DATA CORP. +240 REM +250 REM +260 REM THE ONLY INPUT THE PROGRAM REQUIRES IS YOUR NAME AND YOUR +270 REM DATE OF BIRTH (GIVEN AS MM,DD,YYYY OR MM,DD,YY). +280 REM THIS PROGRAM PRINTS OUT A 12-MONTH CALENDER FOR 1978. IF SOME +290 REM PARTICULAR DAY HAS A 'P', AN 'S' OR AN 'I' INSTEAD OF A +300 REM NUMBER, IT MEANS THAT DAY IS A P(HYSICAL), S(ENSITIVITY) OR +310 REM I(NTELLECTUAL) CRITICAL DAY FOR YOU. A '+' OR '-' FOLLOWING +320 REM ONE OF THE THREE LETTERS ABOVE MEANS THE SINE CURVE IS +330 REM BEGINNING ITS UPWARD(+) OR DOWNWARD(-) SWING. +340 REM +350 REM IF TWO LETTERS APPEAR ON THE CALENDAR, IT MEANS YOU HAVE A +360 REM DOUBLE-CRITICAL DAY! (E.G. 'PS' MEANS YOUR PHYSICAL AND +370 REM SENSITIVITY CYCLES ARE BOTH CRITICAL ON THAT DAY). +380 REM +390 REM IF A DOUBLE ASTERISK (**) APPEARS ON THE CALENDAR, IT MEANS +400 REM ALL THREE CYCLES ARE CRITICAL ON THAT DAY! YOU'D BEST JUST +410 REM STAY HOME N BED!! ONE GOOD(?) THING YOU MIGHT SAY +420 REM ABOUT A TRIPLE-CRITICAL DAY IS THAT YOU ONLY HAVE 9 OF THEM +430 REM IN THE 58-YEAR BIORHYTHM LIFE CYCLE (YOUR THREE CYCLES +440 REM START OVER AGAIN ABOUT EVERY 58 YEARS). +450 REM +460 REM THIS PROGRAM WAS ORIGINALLY WRITTEN IN PL/M FOR THE INTELLEC +470 REM MICROCOMPUTER DEVELOPMENT SYSTEM. +480 REM BEING INNATELY LAZY, I MERELY TRANSLATED THE CODE (INSTEAD OF +490 REM REDESIGNING IT) WHEN I REWROTE IT IN MICROSOFT DISK BASIC. +500 REM THIS LAME EXCUSE IS MY WAY OF TELLING THE USER THAT THE +510 REM PROGRAM RUNS SLO-O-O-W AS COMPARED TO THE PL/M VERSION. +520 REM +530 REM +540 REM****************************************************************** +550 REM +560 CLEAR 1000 +570 DEFINT A-E:DEFINT G-Z +580 DIM CA(583),CB$(71) +590 WIDTH80 +600 GOSUB 1600 +610 LINEINPUT"PLEASE ENTER YOUR NAME ===> ";N$ +620 INPUT"NOW ENTER YOUR BIRTHDATE (E.G. 5,22,1934) ===> ";MM,DD,YY +630 IF YY<1000 THEN YY=YY+1900 +640 PRINT:LINEINPUT"POSITION PAPER AT TOP OF FORM, THEN HIT -RETURN-";A$ +650 PRINT:PRINT"WAIT....YOUR BIORHYTHM CALENDAR WILL BE PRINTING SHORTLY....." +660 CY=1978 +670 X=MM:Y=DD:Z=YY:IFX<3THENGOSUB1770ELSEGOSUB1780 +680 F1=F +690 X=1:Y=1:Z=1978:GOSUB1770 +700 TD=F-F1+1 +710 IF CY MOD 4=0 THEN MV(13)=29 +720 FOR K=0TO583:CA(K)=0:NEXT +730 MV(1)=MV(13):CP=SD(CY-1971) +740 FORJ=1TO12 +750 L=MV(J-1) +760 RP=6*(J-1)+1 +770 FOR K=1TOL +780 CA(CP+7*(RP-1))=K +790 CP=CP+1 +800 IF CP>7 THEN CP=1:RP=RP+1 +810 NEXT K +820 NEXTJ +830 CL=23:RP=0 +840 FOR L=1 TO 3 +850 MC=TD MOD CL +860 FOR J=1 TO 72 +870 FOR K=1 TO 7 +880 SL=K+7*(J-1) +890 IF CA(SL)=0 THEN 960 +900 IF MC-CL\2-1 = 0 THEN 940 +910 IF MC>CL THEN CA(SL)=CA(SL)+1000*(L+RP)+200:MC=1 +920 MC=MC+1 +930 GOTO 960 +940 CA(SL)=CA(SL)+1000*(L+RP)+100 +950 MC=MC+1 +960 NEXT K +970 NEXT J +980 CL=CL+5:RP=RP+1 +990 NEXT L +1000 REM +1010 L=0:KL=7*(CY-1971) +1020 FOR J=1TO7 +1030 MG=10000 +1040 FOR K=0TO71:CB$(K)=" ":NEXTK +1050 L=L+1:M=HP(L-1):IF M<>0 THEN CB$(M)="$":GOTO 1050 +1060 CP=KL+J:K=HN(CP-1) +1070 IF K=0 THEN FOR I=48TO53:CB$(I)="$":NEXTI:GOTO 1120 +1080 FOR N=1 TO 5:LP=K\MG:K=K-LP*MG +1090 IF LP<>0 THEN CB$(LP+47)="$" +1100 MG=MG\10 +1110 NEXT N +1120 LPRINTTAB(5);:FOR I=0 TO 71:LPRINT CB$(I);:NEXT I:LPRINT +1130 NEXT J +1140 PRINT +1150 FOR I=0TO71:CB$(I)=" ":NEXT I +1160 LPRINT:LPRINTTAB(23);"BIORHYTHM CALENDAR FOR ";N$:LPRINT +1170 LPRINT:LPRINTTAB(11);"P=PHYSICAL S=SENSITIVITY I=INTELLECTUAL" +1180 LPRINTTAB(18);"+ = CURVE RISING - = CURVE FALLING" +1190 LPRINTTAB(25);"** = TRIPLE CRITICAL DAY!":LPRINT +1200 FOR L=1 TO 12 STEP 3 +1210 ON L\3+1 GOSUB 1560,1570,1580,1590 +1220 LPRINTTAB(5);" S M T W T F S S M T W T F S S M T W T F S":LPRINT +1230 N=6*(L-1)+1 +1240 FOR M=1 TO 6 +1250 LP=3 +1260 RP=N +1270 JL=RP+12 +1280 FOR K=0 TO 71:CB$(K)=" ":NEXT K +1290 IF RP>JL THEN 1500 +1300 FOR K=1 TO 7 +1310 IF CA(K+7*(RP-1))=0 THEN 1460 +1320 SL=K+7*(RP-1) +1330 IF CA(SL)>8500 THEN CB$(LP)="*":CB$(LP-1)="*":GOTO1460 +1340 IF CA(SL)>8200 THEN CB$(LP)="I":CB$(LP-1)="S":GOTO1460 +1350 IF CA(SL)>6200 THEN CB$(LP)="I":CB$(LP-1)="P":GOTO1460 +1360 IF CA(SL)>5200 THEN CB$(LP)="+":CB$(LP-1)="I":GOTO1460 +1370 IF CA(SL)>5100 THEN CB$(LP)="-":CB$(LP-1)="I":GOTO1460 +1380 IF CA(SL)>4200 THEN CB$(LP)="S":CB$(LP-1)="P":GOTO1460 +1390 IF CA(SL)>3200 THEN CB$(LP)="+":CB$(LP-1)="S":GOTO1460 +1400 IF CA(SL)>3100 THEN CB$(LP)="-":CB$(LP-1)="S":GOTO1460 +1410 IF CA(SL)>1200 THEN CB$(LP)="+":CB$(LP-1)="P":GOTO1460 +1420 IF CA(SL)>1100 THEN CB$(LP)="-":CB$(LP-1)="P":GOTO1460 +1430 CB$(LP)=MID$(STR$(CA(SL) MOD 10),2) +1440 CB$(LP-1)=MID$(STR$(CA(SL)\10),2) +1450 IF CB$(LP-1)="0"THENCB$(LP-1)=" " +1460 LP=LP+3 +1470 NEXT K +1480 RP=RP+6:LP=LP+4 +1490 GOTO 1290 +1500 LPRINTTAB(5);:FOR I=0 TO 71:LPRINTCB$(I);:NEXT I:LPRINT +1510 N=N+1 +1520 NEXT M +1530 LPRINT +1540 NEXT L +1550 END +1560 LPRINTTAB(5);" J A N U A R Y F E B R U A R Y M A R C H":LPRINT:RETURN +1570 LPRINTTAB(5);" A P R I L M A Y J U N E":LPRINT:RETURN +1580 LPRINTTAB(5);" J U L Y A U G U S T S E P T E M B E R":LPRINT:RETURN +1590 LPRINTTAB(5);" O C T O B E R N O V E M B E R D E C E M B E R":LPRINT:RETURN +1600 DIM HP(49) +1610 FOR I=0TO48:READHP(I):NEXT +1620 DATA 21,29,30,31,32,38,39,40,41,42,43,0,20,21,28,33,38,43,0 +1630 DATA 19,21,28,32,33,41,42,0,21,29,30,31,33,40,0,21,32,40,0 +1640 DATA 21,31,40,0,19,20,21,22,30,40,0 +1650 DIM MV(24) +1660 FOR I=0TO23:READMV(I):NEXT +1670 DATA 31,28,31,30,31,30,31,31,30,31,30,31,31,28,31,30,31,30,31,31 +1680 DATA 30,31,30,31 +1690 DIM SD(9) +1700 FOR I=0TO8:READSD(I):NEXT +1710 DATA 6,7,2,3,4,5,7,1,2 +1720 DIM HN(63) +1730 FOR I=49 TO 55:READHN(I):NEXT +1740 DATA 2345,16,16,2345,16,16,2345 +1750 PRINT:PRINT +1760 RETURN +1770 F=365*Z+Y+31*(X-1)+INT((Z-1)/4)-INT(.75*(INT((Z-1)/100)+1)):RETURN +1780 F=365*Z+Y+31*(X-1)-INT(.4*X+2.3)+INT(Z/4)-INT(.75*(INT(Z/100)+1)):RETURN +NT((Z-1)/4)-INT(.75*(INT((Z-1)/10 \ No newline at end of file diff --git a/disks/images/b/BIRTHDAY.ASC b/disks/images/b/BIRTHDAY.ASC new file mode 100644 index 0000000..902840d --- /dev/null +++ b/disks/images/b/BIRTHDAY.ASC @@ -0,0 +1,154 @@ +100 REM BIRTHDAY UPDATED 5-5-77 TO "MITS" BY D. NIXON +110 DIM Z$(12),L(12),N(60),Y$(7) +120 DIM G$(12),H$(32) +130 FOR I=1 TO 12:READ Z$(I):NEXT +140 FOR I=1 TO 12:READ L(I):NEXT +150 FOR I=1 TO 7:READ Y$(I): NEXT +160 FOR I=1 TO 12:READ G$(I):NEXT +170 FOR I=1 TO 32:READ H$(I):NEXT +180 DATA JANUARY,FEBRUARY,MARCH,APRIL,MAY,JUNE,JULY,AUGUST: +190 DATA SEPTEMBER,OCTOBER,NOVEMBER,DECEMBER: +200 DATA 31,28,31,30,31,30,31,31,30,31,30,31: +210 DATA THURS,FRI,SATUR,SUN,MON,TUES,WEDNES: +220 DATA THE MOON,THE SUN,THE EARTH,THE PLANET MERCURY,VENUS,MARS: +230 DATA JUPITER,SATURN,THE PLANET URANUS,THE PLANET NEPTUNE: +240 DATA THE PLANET PLUTO,PEANUT BUTTER: +250 DATA JUXTAROTATION,CONTRAPOSITION,CONTRASTING PHASES,TRANSPOSITION: +260 DATA SATISFIED,HAPPY,INTERESTING,TOLERANT: +270 DATA OFTEN,OCCASIONALLY,SOMETIMES: +280 DATA TEND TO BE,ARE,ARE INCLINED TO BE: +290 DATA SHORT OF PATIENCE,UNEASY,AT ODDS: +300 DATA OTHERS.,CLOSE FRIENDS.,YOUNGER PEOPLE.,THOSE IN AUTHORITY.: +310 DATA ": BEWARE OF "," AVOID " +320 DATA APPLE PIE,BEING ALONE,DARK PLACES,STRANGERS,UNUSUAL SITUATIONS: +330 DATA BE TAKING A TRIP YOU HAVE NOT MADE BEFORE. +340 DATA BE MEETING SOMEONE YOU WILL KNOW FOR THE REST OF YOUR LIFE. +350 DATA MAKE SEVERAL IMPORTANT DECISIONS INVOLVING OTHERS. +360 DATA BECOME ILL IF YOU DO NOT LESSEN YOUR UNUSUAL ACTIVITIES. +370 PRINT "TYPE IN TODAY'S DATE NUMERICALLY: MO,DAY,YEAR"; +380 INPUT X1,Y1,Z1 +390 IF Z1>99 GOTO 410 +400 Z1=Z1+1900 +410 XF=X1:YF=Y1:ZF=Z1:GOSUB 1220:U=ND +420 PRINT "TODAY IS ";Y$(U-7*INT(U/7)+1);"DAY (I HOPE)" +430 PRINT +440 PRINT "HI, I'M A MICROPROCESSOR." +450 PRINT "TELL ME YOUR NAME"; +460 INPUT N$ +470 I=INSTR(N$," ")-1 +480 IF I<0 THEN 580 +490 K$=LEFT$(N$,I) +500 PRINT "ARE YOU USUALLY CALLED ";K$; +510 INPUT A$ +520 GOSUB 1140 +530 ON NA GOTO 540,560,510 +540 PRINT "WHAT DO YOU LIKE TO BE CALLED"; +550 INPUT K$ +560 PRINT "SO YOUR FULL NAME IS ";N$;", BUT YOU" +570 PRINT "LIKE TO BE CALLED ";K$;"." +580 PRINT "HOW OLD ARE YOU, ";K$; +590 INPUT A +600 A=INT(A) +610 IF INT((A-5)/95)=0 GOTO 640 +620 PRINT "COME ON, ";K$;", YOU'RE PULLING MY LEG." +630 GOTO 580 +640 PRINT "SO YOU ARE";A;"YEARS OLD." +650 PRINT "DO YOU KNOW, OFF HAND, HOW MANY DAYS OLD YOU ARE"; +660 INPUT A$ +670 GOSUB 1140 +680 ON NA GOTO 720,690,660 +690 PRINT "OK, SMARTY, HOW MANY?" +700 PRINT "SORRY, ";K$;", YOU'LL HAVE TO BE FASTER THAN THAT!" +710 GOTO 1600 +720 PRINT "OK, I'LL TELL YOU." +730 PRINT "IN WHAT MONTH WERE YOU BORN"; +740 INPUT M$ +750 FOR X=1 TO 12 +760 IF M$=Z$(X) GOTO 800 +770 NEXT X +780 PRINT K$;", YOU MAY BE NICE BUT YOU CAN'T SPELL." +790 GOTO 730 +800 PRINT "ON WHAT DAY"; +810 INPUT Y +820 Z=Z1-A +830 IF INT((Y-1)/L(X))=0 GOTO 870 +840 IF (X-1)*(Y-28)*(Z-4*INT(Z/4)+1)=1 GOTO 870 +850 PRINT "COME ON, ";N$;", YOU'RE GIVING ME A HARD TIME." +860 GOTO 800 +870 REM +880 XF=X1:YF=Y1:ZF=Z:GOSUB 1220:W=ND +890 XF=X:YF=Y:ZF=Z:GOSUB 1220:V=ND +900 IF W=> V GOTO 920 +910 Z=Z-1 +920 IF ABS(W-V)>30 GOTO 990 +930 ON SGN(W-V)+2 GOTO 940,980,960 +940 PRINT "YOU HAVE A BIRTHDAY COMING UP IN ONLY";V-W;"DAYS!" +950 GOTO 990 +960 PRINT "YOUR BIRTHDAY WAS ONLY";W-V;"DAYS AGO. CONGRATULATIONS!" +970 GOTO 990 +980 PRINT "HAPPY BIRTHDAY, DEAR ";K$;", HAPPY BIRTHDAY TO YOU." +990 XF=X:YF=Y:ZF=Z:GOSUB 1220:V=ND +1000 PRINT "YOU WERE BORN ON ";Y$(V-7*INT(V/7)+1);"DAY, ";Z$(X);Y;",";Z +1010 PRINT "WHICH MAKES YOU";U-V;"DAYS OLD." +1020 PRINT "YOU WERE BORN ON THE DAY";V;"AD, AND ON JAN. 1, 2000" +1030 PRINT "YOU WILL BE";730480!-V;"DAYS OLD." +1040 PRINT "HOW ABOUT THAT!!!" +1050 PRINT +1060 GOSUB 1350 +1070 PRINT "WELL, ";N$; +1080 IF N$=K$ GOTO 1100 +1090 PRINT " (ALIAS ";K$;")" +1100 PRINT " IT HAS BEEN NICE CHATTING WITH YOU. DO COME AGAIN." +1110 PRINT "GOOD BYE" +1120 GOTO 1600 +1130 REM SUBROUTINE FOR YES NO REQUEST +1140 NA=1 +1150 IF A$="NO" GOTO 1210 +1160 IF A$="N0" GOTO 1210 +1170 NA=2 +1180 IF A$="YES" GOTO 1210 +1190 NA=3 +1200 PRINT "A SIMPLE YES OR NO WILL DO! " +1210 RETURN +1220 REM SUBROUTINE TO SOLVE FOR NUMBER OF DAYS +1230 ND=YF-1 +1240 FOR I1=1 TO XF-1 +1250 ND=ND+L(I1) +1260 NEXT I1 +1270 I1=INT(ZF/100) +1280 IF ZF<>4*INT(ZF/4) GOTO 1330 +1290 IF ZF/100=I1 GOTO 1330 +1300 IF ND>59 GOTO 1330 +1310 IF XF=3 GOTO 1330 +1320 ND=ND-1 +1330 ND=ND+36524!*I1+INT(365.25*(ZF-100*I1)) +1340 RETURN +1350 REM GENERATE RANDOM HOROSCOPE +1360 R1=INT(12*RND(1))+1 +1370 R2 = INT(12*RND(1))+1 +1380 IF R1=R2 GOTO 1370 +1390 R=1 +1400 X=4:GOSUB 1570 +1410 PRINT "YOU WERE BORN UNDER THE ";H$(NR);" OF ";G$(R1) +1420 X=4:GOSUB 1570 +1430 PRINT "AND ";G$(R2);". YOU ARE A BASICALLY ";H$(NR) +1440 X=3:GOSUB 1570 +1450 PRINT "PERSON BUT ";H$(NR); +1460 GOSUB 1570 +1470 PRINT " YOU ";H$(NR) +1480 GOSUB 1570:N1=NR:X=4:GOSUB 1570:N2=NR:X=2:GOSUB 1570 +1490 PRINT H$(N1);" WITH ";H$(N2);H$(NR) +1500 X=5:GOSUB 1570 +1510 PRINT H$(NR);" FOR THE NEXT WEEK. I PREDICT YOU WILL SOON" +1520 X=4:GOSUB 1570 +1530 PRINT H$(NR) +1540 PRINT +1550 RETURN +1560 REM SUBROUTINE TO SELECT RANDOM WORDS +1570 NR=INT(X*RND(1))+R +1580 R=R+X +1590 RETURN +1600 END + +1550 RETURN +1560 REM SUBROUTINE TO SELECT \ No newline at end of file diff --git a/disks/images/b/BLACKJCK.ASC b/disks/images/b/BLACKJCK.ASC new file mode 100644 index 0000000..280e9c1 --- /dev/null +++ b/disks/images/b/BLACKJCK.ASC @@ -0,0 +1,167 @@ +100 REM *** B L A C K J A C K *** +101 WIDTH 80 +110 DIM D(208),H(16),O(16),P(16,11),Q(11),S(16),X(16) +120 PRINT:PRINT"WELCOME TO THE CASINO" +130 PRINT "WE PLAY VEGAS STYLE BLACKJACK" +140 PRINT:INPUT"INSTRUCTIONS? (YES-NO) ";M$: IF M$="NO" THEN GOTO 160 +150 IF M$="YES" THEN GOSUB 1640:GOTO 160 ELSE GOTO 140 +160 R=16:PRINT"HOW MANY DECKS (1-4)"; +170 INPUTN:IFN<1ORN>4THENPRINT"1 TO 4 DECKS ONLY. REENTER";:GOTO170 +180 E=N*52:GOSUB870:B=1:GOSUB890:A=1 +190 PRINT:G=1 +200 INPUT"BET PLEASE";U:IF U>0 THENGOTO220 ELSE IF U=0 THEN GOTO1600 +210 B=1:GOSUB 890:GOTO 200 +220 IF U<=500 THEN GOTO240 ELSEPRINT"SORRY, THE HOUSE LIMIT IS $500!" +230 GOTO 200 +240 GOSUB930:H(1)=U:N=Q(2):PRINT:PRINT"MY UP CARD";:GOSUB1050:N=P(R,1) +250 PRINT : PRINT"YOUR 1ST CARD";:GOSUB1050:PRINT"YOUR 2ND CARD";:N=P(R,2) +260 GOSUB 1050 +270 GOSUB1170:IFM<>11THEN GOTO 280 ELSE GOSUB 1550 +280 IF W<>21 THEN GOTO 320 ELSE PRINT : PRINT"I HAVE BLACKJACK, "; +290 IF X(1)<>21 THEN GOTO 310 ELSE PRINT"SO DO YOU, WE PUSH" +300 GOSUB 1510:GOTO 190 +310 PRINT"YOU LOSE":V=V-U:GOTO300 +320 IF X(1)<>21 THEN GOTO340 ELSE PRINT"YOU HAVE BLACKJACK, YOU WIN!" +330 V=V+3*U/2:GOTO300 +340 PRINT:PRINT"PLAY ";:IF R=1 THEN GOTO 350 ELSE PRINT"FOR HAND";G; +350 PRINT:PRINT"YOUR TOTAL IS";X(G);:INPUT F:IF F>-1 THEN GOTO 370 +360 PRINT"ONLY 0-3 IS VALID, REENTER";:GOTO350 +370 IF F>3 THEN GOTO 360 ELSE IF F<>1 THEN GOTO 550 +380 REM ******** PLAYER HIT ROUTINE ************* +390 IF A<=E THEN GOTO 400 ELSE GOSUB 1220 +400 M=S(G):M=M+1:S(G)=M:N=D(A):P(G,M)=N:PRINT"YOUR CARD IS";:GOSUB 1050 +410 GOSUB 1010:A=A+1:IF N<>11 THEN GOTO 420 ELSE O(G)=O(G)+1 +420 X(G)=X(G)+N +430 IF X(G)<22 THEN GOTO 340 ELSE IF O(G)=0 THEN 450 +440 O(G)=O(G)-1:X(G)=X(G)-10:GOTO 430 +450 PRINT:PRINT"YOU BUSTED WITH";X(G):X(G)=0:Y=Y-1:PRINT +460 REM ********* CHECK FOR END OF PLAY ************ +470 IF G0 GOTO 620 +560 REM *********PLAYER STAND ALONE ROUTINE ************ +570 IF X(G)<22 GOTO 470 +580 IF O(G)=0 GOTO 450 +590 X(G)=X(G)-10 +600 O(G)=O(G)-1 +610 G=G+1 +620 IF F<>2 GOTO 730 +630 IF S(G)=2 GOTO 670 +640 PRINT "DOUBLE ON 1ST 2 CARDS ONLY" +650 GOTO 340 +660 REM ***** DOUBLE DOWN ROUTINE ********** +670 IF A<=E THEN GOTO 680 ELSE 1220 +680 H(G)=2*U:N=D(A):P(G,3)=N:A=A+1:PRINT "YOU DRAW THE";:GOSUB 1050 +690 GOSUB 1010:IF N=11 THEN O(G)=O(G)+1 +700 X(G)=X(G)+N +710 IF X(G)<22 THEN GOTO 470 +720 IF O(G)=0 THEN GOTO 450 ELSE O(G)=O(G)-1:X(G)=X(G)-10:GO1350 +730 N=P(G,1):Y=Y+1:GOSUB 1010:M=N:N=P(G,2):GOSUB1010:IFM=NTHENGOTO760 +740 PRINT "YOU MAY ONLY SPLIT PAIRS": GOTO 340 +750 REM *********PAIR SPLIT ROUTINE ********** +760 R=R+1:Y=Y+1:P(R,1)=P(G,2):S(G)=1:S(R)=1:X(G)=X(G)/2:X(R)=X(G) +770 H(R)=U:IF N<>11 THEN GOTO 340 +780 REM **********ACES WERE SPLIT - 1 CARD EACH ********* +790 IF A>E THEN GOSUB 1220 +800 N=D(A):P(G,2)=N:PRINT "1ST ACE GETS A";:GOSUB 1050: GOSUB 1010 +810 IF N=11 THEN N=1 +820 X(G)=X(G)+N:A=A+1:IF A>E THEN GOSUB 1220 +830 N=D(A):P(R,2)=N:PRINT "2ND ACE GETS A";:GOSUB 1050:GOSUB 1010 +840 IF N=11 THEN N=1 +850 X(R)=X(R)+N:A=A+1:GOTO480 +860 REM ************ BUILD 1 TO 4 DECKS ************ +870 FOR I=1 TO N: J=(I-1)*52: FOR K =1 TO 52: D(J+K)=K:NEXT K,I:RETURN +880 REM *********SHUFFLE THE CARDS *********** +890 PRINTCHR$(26):PRINT "I'M SHUFFLING.... ":FOR I=B TO E +900 C=RND(1)*E:IF CE THEN B=1:GOSUB 890 +950 PRINT "DEALING":P(R,1)=D(A):Q(1)=D(A+1):P(R,2)=D(A+2):Q(2)=D(A+3) +960 A=A+4:T=2:S(1)=2:GOSUB980:M=N:RETURN +970 REM ********** COMPUTE THE VALUE OF THE DEALERS HAND ********* +980 Z=0:W=0:FOR I=1 TO 2:N=Q(I):GOSUB 1010:IF N=11 THEN Z=Z+1 +990 W=W+N:NEXT I :RETURN +1000 REM **********COMPUTE THE VALUE OF A CARD **********: +1010 IF N<14 THEN GOTO 1020 ELSE N=N-13:GOTO 1010 +1020 IF N=1 THEN N=11:RETURN ELSE GOTO 1030 +1030 IF N<11 THEN RETURN ELSE N=10:RETURN +1040 **********PRINT A CARD ********** +1050 I=0 +1060 IF N>=14 THEN N=N-13:I=I+1:GOTO1060 +1070 IF N=1 THEN PRINT TAB(17);"ACE ";:GOTO1130 +1080 IF N<10 THEN PRINT TAB(18);N;:GOTO1130 +1090 IF N<11 THEN PRINT TAB(17);N;:GOTO 1130 +1100 IF N<12 THEN PRINT TAB(16);"JACK ";:GOTO1130 +1110 IF N<13 THEN PRINT TAB(15);"QUEEN ";:GOTO 1130 +1120 PRINT TAB(16);"KING "; +1130 PRINT "OF ";:IF I=0 THEN PRINT "SPADES":RETURN +1140 IF I=1 THEN PRINT "HEARTS":RETURN +1150 IF I=2 THEN PRINT "DIAMONDS":RETURN ELSE PRINT "CLUBS":RETURN +1160 REM ********* COMPUTE VALUE OF PLAYERS HAND *********: +1170 O(G)=0:X(G)=0:FOR I =1 TO 2: N=P(G,I):GOSUB 1010:X(G)=X(G)+N +1180 IF N<>11 THEN GOTO 1200 +1190 O(G)=O(G)+1 +1200 NEXT I:RETURN +1210 REM *********SAVE THE CARDS THAT ARE ALREADY DEALT AND SHUFFLE** +1220 K=T:FOR I=1 TO R:K=K+S(I):NEXT I +1230 FOR I=1TOK:A=A-1:J=D(I):D(I)=D(A):D(A)=J:NEXTI:B=K+1:GOSUB890:RETURN +1240 REM *******DEALERS LOGIC **********: +1250 N=Q(1):PRINT "MY HOLE CARD";:GOSUB 1050:IF Y=0 THEN GOTO 1390 +1260 IF W<17 THEN GOTO 1300 +1270 IF W>17 THEN GOTO 1340 +1280 IF Z=0 THEN GOTO 1380 +1290 W=W-10:Z=Z-1 +1300 IF A>E THEN GOSUB 1220 +1310 N=D(A):T=T+1:A=A+1:PRINT:PRINT "I DRAW THE";:GOSUB1050:GOSUB1010 +1320 IF N=11 THEN Z=Z+1 +1330 W=W+N:GOTO 1260 +1340 IF W<22 THEN GOTO 1380 +1350 IF Z=0 THEN GOTO 1370 +1360 Z=Z-1:W=W-10:GOTO1260 +1370 PRINT "I BUSTED "; +1380 PRINT "MY TOTAL IS ";W +1390 FOR I =1 TO R:PRINT "YOU ";:IF X(I)<>0 THEN GOTO 1410 +1400 PRINT "LOST ";:V=V-H(I):GOTO 1460 +1410 IF W<22 THEN GOTO 1430 +1420 PRINT "WON ";:V=V+H(I):GOTO 1460 +1430 IF W<>X(I) THEN GOTO 1450 +1440 PRINT "PUSHED ON ";:GOTO1460 +1450 IF W1 THEN GOTO 1470 ELSE PRINT "THE HAND":GOTO 1480 +1470 PRINT "HAND ";I +1480 NEXT I +1490 REM ********* PRINT THE PLAYERS WON/LOST STANDING ******* +1500 PRINT +1510 PRINT "YOU'RE ";:IF V=0 THEN PRINT "EVEN":RETURN +1520 IF V<0 THEN PRINT "BEHIND $"V:RETURN ELSE PRINT "AHEAD $";V:RETURN +1530 PRINT "AHEAD $";V +1540 REM ********INSURANCE ROUTINE ************ +1550 INPUT "INSURANCE (YES-NO)";M$:IF M$="NO" THEN RETURN +1560 IF M$<>"YES" THEN GOTO 1550 +1570 PRINT "YOUR INSURANCE BET ";:IF W=21 THEN PRINT "WINS":V=V+U:RETURN +1580 PRINT "LOSES":V=V-U/2:RETURN +1590 REM ******END OF GAME WRAP UP ************** +1600 PRINT "THANKS FOR PLAYING":PRINT "HOPE YOU ENJOYED YOURSELF" +1610 PRINT "HERE'S YOUR FINAL STANDING!":GOSUB 1510 +1620 IFV>0THENPRINT"NOW, JUST YOU TRY TO COLLECT !!":END +1630 IF V=0THENPRINT"BIG DEAL......":END ELSEPRINT"PAY UP, OR ELSE":END +1640 REM ******** INSTRUCTIONS *********** +1650 PRINT:PRINT"THE DEALER STANDS ON 17 OR MORE" +1660 PRINT"BUT WILL HIT A SOFT 17." +1670 PRINT"YOU MAY SPLIT ANY PAIR.":PRINT"YOU MAY DOUBLE THE 1ST 2 CARDS" +1680 PRINT"AND GET ONLY 1 MORE CARD.":PRINT:PRINT"PLAY CODES:" +1690 PRINT " 0 - STAND":PRINT " 1 - HIT":PRINT " 2 - DOUBLE DOWN" +1700 PRINT " 3 - SPLIT A PAIR":PRINT:PRINT "A ZERO BET ENDS THE GAME" +1710 PRINT "A NEGATIVE BET FORCES A SHUFFLE" +1720 PRINT "GOOD LUCK - LET'S START":RETURN +T:PRINT "A ZERO BET ENDS THE GAME" +1710 PRINT "A NEGATIVE BET FORCES A SHUFFLE" +1720 PRINT "GOOD LUC \ No newline at end of file diff --git a/disks/images/b/BUDGET.ASC b/disks/images/b/BUDGET.ASC new file mode 100644 index 0000000..87be9ef --- /dev/null +++ b/disks/images/b/BUDGET.ASC @@ -0,0 +1,218 @@ +100 REM TYPED BY CONNIE FOSTER ,CORRECTED BY C.FOSTER ,PROG BY O.E.DIAL +110 REM ALL REM STATEMENTS CAN BE CHANGED TO ALLOW USE OF TWO TERMINALS +120 REM SEE ARTICLE IN PERSONAL COMPUTING MAY/JUNE 77 +130 Q=27:V$="###.#":W$="$$#####,":U$="###" +140 DIMD(18),E$(Q),V(Q),F(Q) +150 PRINTTAB(19)"RECURSIVE BUDGETING MODEL":PRINT:PRINTTAB(28)"* * *" +160 DATASALARY/WAGES,OTHER INCOME,FED INC TAX,STATE & LOCAL TAX +170 DATASOCIAL SECURITY,UNEMPLOYMENT INS,HEALTH INS +180 DATALIFE INS,CONTRIBUTIONS,OTHER DEDUCTIONS +190 DATARENT/MORTGAGE,LIFE INS,HEALTH INS,HOUSE INS +200 DATAAUTO INS,CAR PAYMENTS,LOAN PAYMENTS,TRASH REMOVAL +210 DATAOTHER FIXED EXP +220 DATAFOOD/BEVERAGES,CLOTHING,DRY CLEANING,BARBER/BEAUTY +230 DATAHOME MAINT,HOME HEAT'G FUEL,WATER,ELECTRICITY, TELEPHONE +240 DATAGAS/OIL,AUTO MAINT,FARES/TOLLS/PARKING,DENTIST +250 DATAPHYSICIAN,DRUGS/SUNDRIES,SCHOOL EXPENSE,FAMILY ALLOWANCE +260 DATACLUBS/LODGES,THEATER/SPORTS,RESTAURANTS +270 DATAOTHER ENT'MENT,MAG'S/BOOKS/PAPERS,SITTERS,CHILD CARE +280 DATAVACATION SAVING,OTHER SAVINGS,CONTRIBUTIONS,OTHER EXPENSES +290 PRINT:PRINT"SELECT YOUR BUDGETING PERIOD BY NUMBER. LATER ON IT WILL" +300 PRINT"BE EXTENDED TO ONE YEAR.":PRINT +310 PRINTTAB(3)"1-WEEKLY"TAB(15)"2-BIWEEKLY"TAB(30)"3-SEMIMONTHLY"; +320 PRINTTAB(45)"4-MONTHLY":PRINT +330 INPUTP:IFP>4THENPRINT"TRY AGAIN":GOTO290 +340 IFP=1THENP=52ELSEIFP=2THENP=26ELSEIFP=3THENP=24ELSEIFP=4THENP=12 +350 PRINT:PRINT"ALRIGHT,FIRST LET'S LOOK AT INCOME FOR THE PERIOD.":PRINT +360 READA$:PRINTA$;" $";:INPUTD(0):READA$:PRINTA$;" $";:INPUTD(1) +370 TI=D(0)+D(1):PRINT +380 PRINT:PRINT"OK,NOW LET'S LOOK AT PAYCHECK DEDUCTIONS.":PRINT +390 FORJ=2TO9:READA$:PRINTA$;:INPUT" $";D(J):TD=TD+D(J):NEXTJ:PRINT +400 PRINT"OK,NOW LET'S LOOK AT FIXED EXPENSES.":PRINT +410 FORJ=10TO18:READA$:PRINTA$;:INPUT" $";D(J):TF=TF+D(J):NEXTJ +420 DF=TD+TF:SI=TI-DF:S=64 +430 PRINT:PRINT"OK,AT THIS TIME OUR TABLE LOOKS LIKE THIS:":PRINT +440 REM +450 GOSUB1900:PRINT:PRINTTAB(19); +460 PRINT"RECURSIVE BUDGETING MODEL":PRINT:PRINTTAB(27)"* * *":PRINT +470 GOSUB1900 +480 PRINT:PRINTTAB(20)"SPENDABLE INCOME SUMMARY":PRINT +490 GOSUB1890:PRINTTAB(3)"ACCOUNT"TAB(42)"PERIOD"TAB(57)"ANNUAL" +500 GOSUB1890:PRINT"TOTAL INCOME" TAB(40);:PRINTUSINGW$;TI;:PRINTTAB(55) +510 PRINTUSINGW$;TI*P:PRINT:PRINTTAB(3)"PAYCHECK DEDUCTIONS"TAB(25); +520 PRINTUSINGW$;TD*(-1):PRINT +530 PRINTTAB(3)"FIXED EXPENSES"TAB(25);:PRINTUSINGW$;TF*(-1); +540 PRINTTAB(40);:PRINTUSINGW$;DF*(-1);:PRINTTAB(55); +550 PRINTUSINGW$;DF*(-1)*P +560 PRINTTAB(41)"-------"TAB(55)"--------":PRINT"SPENDABLE INCOME"; +570 PRINTTAB(40);:PRINTUSINGW$;SI;:PRINTTAB(55);:PRINTUSINGW$;SI*P +580 PRINTTAB(41)"======="TAB(55)"========":PRINT: +590 GOSUB1900:PRINT: PRINT +600 REM +610 GOSUB1910:RO=0 +620 PRINT:PRINT "OK,NOW FOR THE FIRST ROUND OF VARIABLE EXPENSE. DON'T" +630 PRINT"PINCH YOURSELF IN YOUR ESTIMATES (WITHIN REASON). LET THE" +640 PRINT"COMPUTER HELP YOU REFINE YOUR BUDGET LATER ON.":PRINT +650 FORJ=0TOQ:READE$(J) :PRINTE$(J);:INPUT" $";V(J):VT=VT+V(J):NEXTJ +660 RESTORE:PRINT:PRINT +670 PRINT"YOUR BUDGET FOR THE FIRST ROUND TOTALLED $"VT". THIS" +680 PRINT"COMPARES TO SPENDABLE INCOME OF $"SI". WE HAVE" +690 PRINT"PRORATED THE DIFFERENCE, $"SI-VT",OVER ALL VARIABLE EXPENSE" +700 PRINT"ACCOUNTS.":PRINT +710 GOSUB1910:FORJ=0TOQ:V(J)=INT(V(J)/VT*SI):NEXTJ:VT=SI:PRINT +720 PRINT"NOW WE BEGIN THE BUDGET REFINEMENT PHASE. MAKE AS MANY" +730 PRINT"PASSES AS YOU LIKE. AS YOU REVIEW EACH ACCOUNT,DECIDE" +740 PRINT"WHETHER TO FREEZE IT OR TO LEAVE IT FOR ANOTHER PASS.":PRINT +750 PRINT"HINT: DON'T BE IN A HURRY TO FREEZE AN ACCOUNT.":PRINT +760 PRINT"YOUR TASK IS FINISHED WHEN ALL ACCOUNTS ARE FROZEN.":PRINT +770 GOSUB1910 +780 FORJ=0TOQ:PRINT:IFV(J)=0THEN980 +790 PRINTE$(J);" $";V(J):INPUT"CHANGE ('Y' OR 'N')";A$ +800 IFA$="N"THEN840ELSEIFA$="Y"THEN820ELSEIFA$<>"Y"THEN790 +810 GOTO790 +820 INPUT"REVISED AMOUNT $";A:IFA"Y" THEN 110 +150 PRINT "YOU ARE '*' IN A HIGH VOLTAGE MAZE WITH 5" +160 PRINT "SECURITY MACHINES '+' TRYING TO DESTROY YOU" +170 PRINT "YOU MUST MANEUVER THE SECURITY MACHINES INTO" +180 PRINT "THE MAZE 'X' TO SURVIVE. GOOD LUCK !!!" +190 PRINT "MOVES ARE 7,8,9" +200 PRINT " 4,5,6" +210 PRINT " 1,2,3 0 TO END THE GAME" +220 PRINT +230 DIM A(10,20),E(21),F(21) +240 LET G=0 +250 FOR B=1 TO 10 +260 FOR C=1 TO 20 +270 LET A(B,C)=0 +280 IF B=1 THEN 330 +290 IF B=10 THEN 330 +300 IF C=1 THEN 330 +310 IF C=20 THEN 330 +320 GOTO 340 +330 LET A(B,C)=1 +340 NEXT C +350 NEXT B +360 FOR D=1 TO 21 +370 LET B=INT(RND(1)*8)+2 +380 LET C=INT(RND(1)*18)+2 +390 IF A(B,C)<>0 THEN 370 +400 LET A(B,C)=1 +410 IF D<6 THEN 430 +420 GOTO 440 +430 LET A(B,C)=2 +440 IF D=6 THEN 460 +450 GOTO 470 +460 LET A(B,C)=3 +470 LET E(D)=B +480 LET F(D)=C +490 NEXT D +500 FOR B=1 TO 10 +510 FOR C=1 TO 20 +520 IF A(B,C)<>0 THEN 550 +530 PRINT " "; +540 GOTO 630 +550 IF A(B,C)<>1 THEN 580 +560 PRINT "X"; +570 GOTO 630 +580 IF A(B,C)<>2 THEN 610 +590 PRINT "+"; +600 GOTO 630 +610 IF A(B,C)<>3 THEN 630 +620 PRINT "*"; +630 NEXT C +640 PRINT +650 NEXT B +660 LET B=E(6) +670 LET C=F(6) +680 LET A(B,C)=0 +690 INPUT Y +700 ON Y+1 GOTO 1040,730,730,730,740,780,740,710,710,710 +710 LET B=B-1 +720 GOTO 740 +730 LET B=B+1 +740 ON Y GOTO 750,780,770,750,780,770,750,780,770 +750 LET C=C-1 +760 GOTO 780 +770 LET C=C+1 +780 IF A(B,C)=1 THEN 1060 +790 IF A(B,C)=2 THEN 1080 +800 LET A(B,C)=3 +810 LET E(6)=B +820 LET F(6)=C +830 FOR D=1 TO 5 +840 IF A(E(D),F(D))<>2 THEN 1020 +850 LET A(E(D),F(D))=0 +860 IF E(D)>=B THEN 890 +870 LET E(D)=E(D)+1 +880 GOTO 910 +890 IF E(D)=B THEN 910 +900 LET E(D)=E(D)-1 +910 IF F(D)>=C THEN 940 +920 LET F(D)=F(D)+1 +930 GOTO 960 +940 IF F(D)=C THEN 960 +950 LET F(D)=F(D)-1 +960 IF A(E(D),F(D))=3 THEN 1080 +970 IF A(E(D),F(D))=0 THEN 1000 +980 LET G=G+1 +990 GOTO 1010 +1000 LET A(E(D),F(D))=2 +1010 IF G=5 THEN 1100 +1020 NEXT D +1030 GOTO 500 +1040 PRINT "SORRY TO SEE YOU QUIT" +1050 GOTO 1110 +1060 PRINT "ZAP!!! YOU TOUCHED THE FENCE !!!!!" +1070 GOTO 1110 +1080 PRINT "** YOU HAVE BEEN DESTROYED BY A LUCKY COMPUTER **" +1090 GOTO 1110 +1100 PRINT "YOU ARE LUCKY **YOU DESTROYED ALL THE ENEMY**" +1110 PRINT "WANT TO PLAY AGAIN"; +1120 INPUT C$ +1130 IF LEFT$(C$,1)="Y" THEN 240 +1140 IF LEFT$(C$,1)<>"N" THEN 1110 +1150 PRINT "HOPE YOU DON'T FEEL FENCED IN." +1160 PRINT "TRY AGAIN SOMETIME" +1170 END +0 +1140 IF LEFT$(C$,1)<>"N" THEN 1110 +1150 PRINT "HOPE YOU DON'T FEEL FENCED IN." +1160 PRINT "TRY AGAIN SOMET \ No newline at end of file diff --git a/disks/images/b/CHESS.ASC b/disks/images/b/CHESS.ASC new file mode 100644 index 0000000..3198ffd --- /dev/null +++ b/disks/images/b/CHESS.ASC @@ -0,0 +1,498 @@ +100 REM--CHESS BY RANDY MILLER, JAN, 1976 +110 DEFINT A-Z:DEFSNG E:DEFSNG M:DEFSNG P +120 DIM PS(70,3),MV(35,2),V(32) +130 DIM B(8,8),TM(8,8) +140 DEF FNL(X)=X\10 +150 DEF FNM(X)=X MOD(10) +160 TM(1,1)=0 +170 FOR X=1 TO 32 +180 READ V(X) +190 NEXT +200 FOR Y=1 TO 8 +210 FOR X=1 TO 8 +220 READ B(X,Y) +230 NEXT X:NEXT Y +240 DATA -2,1,-1,2,1,2,2,1,2,-1,1,-2,-1,-2,-2,-1 +250 DATA 8,12,19,21,-8,-12,-19,-21 +260 DATA 1,9,10,11,-1,-9,-10,-11 +270 DATA 4,2,3,6,5,3,2,4,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0 +280 DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,-1,-1,-1,-1 +290 DATA -1,-1,-1,-1,-4,-2,-3,-6,-5,-3,-2,-4 +300 CB=3:CW=3 +310 PRINT:PRINT:PRINT:PRINT TAB(10);"**** CHESS ****" +320 INPUT "DO YOU WANT TO BE WHITE OR BLACK";C$ +330 IF LEFT$(C$,1)="B" THEN 370 +340 B(4,1)=5:B(4,8)=-5 +350 B(5,1)=6:B(5,8)=-6 +360 GOTO 380 +370 PRINT "THANK YOU, THAT MEANS I GET TO GO FIRST":PRINT +380 FOR Y=1 TO 8 +390 FOR X=1 TO 8 +400 TM(X,Y)=B(X,Y) +410 NEXT X:NEXT Y +420 IF LEFT$(C$,1)<>"B" THEN 840 +430 NB=1 +440 REM -- COMPILE LIST OF POSSIBLE MOVES -- +450 FOR X=1 TO 8 +460 FOR Y=1 TO 8 +470 IF SGN(B(X,Y))<>1 THEN 550 +480 GOSUB 1870 +490 FOR D=1 TO N +500 IF MV(D,1)=0 THEN 540 +510 PS(NB,1)=MV(D,1) +520 PS(NB,2)=MV(D,2) +530 NB=NB+1 +540 NEXT D +550 NEXT Y +560 NEXT X +570 PRINT:PRINT "NUMBER OF POSSIBLE MOVES FOR COMPUTER";NB-1:PRINT +580 IF NB>1 THEN PRINT "FROM TO BOARD VALUE":GOTO 620 +590 PRINT "I DON'T BELIEVE IT! - YOU WON!!!" +600 END +610 REM -- EVALUATE EACH POSSIBLE MOVE -- +620 FOR D=1 TO NB-1 +630 D1=FNL(PS(D,1)) +640 D2=FNM(PS(D,1)) +650 D3=FNL(PS(D,2)) +660 D4=FNM(PS(D,2)) +670 D5=B(D3,D4) +680 TM(D3,D4)=TM(D1,D2) +690 TM(D1,D2)=0 +700 GOSUB 1530 +710 PS(D,3)=EV +720 TM(D1,D2)=TM(D3,D4) +730 TM(D3,D4)=D5 +740 PRINT PS(D,1);PS(D,2);TAB(12);PS(D,3) +750 NEXT D +760 REM +770 MZ=PS(1,3):MX=1 +780 IF NB=2 THEN 830 +790 FOR D=2 TO NB-1 +800 IF PS(D,3)<=MZ THEN 820 +810 MX=D:MZ=PS(D,3) +820 NEXT D +830 GOSUB 1290 +840 GOSUB 870 +850 PRINT +860 GOTO 430 +870 REM -- INPUT ROUTINE -- +880 GOTO 910 +890 INPUT "YOUR MOVE";M,N +900 IF M<>0 THEN 930 +910 FOR P=1 TO 8:FOR P1=1 TO 8:PRINT B(P1,P);:NEXT P1:PRINT:NEXT P +920 GOTO 890 +930 X1=FNL(M):Y1=FNM(M):X2=FNL(N):Y2=FNM(N) +940 IF X1>8 OR X1<1 OR Y1>8 OR Y1<1 THEN 970 +950 IF X2>8 OR X2<1 OR Y2>8 OR Y2<1 THEN 970 +960 IF SGN(B(X1,Y1))=-1 THEN 990 +970 PRINT "YOU CAN'T DO THAT." +980 GOTO 890 +990 REM +1000 FOR P=1 TO 8 +1010 FOR P1=1 TO 8 +1020 TM(P,P1)=B(P,P1) +1030 NEXT P1 +1040 NEXT P +1050 GOSUB 3690 +1060 IF LG=0 THEN 970 +1070 TM(X2,Y2)=TM(X1,Y1) +1080 TM(X1,Y1)=0 +1090 B(X2,Y2)=B(X1,Y1) +1100 B(X1,Y1)=0 +1110 PRINT "ACCEPTED." +1120 IF Y2<>1 OR B(X2,Y2)<>-1 THEN 1180 +1130 PRINT "TO PROMOTE YOUR PAWN TO A KNIGHT, TYPE 2; FOR A BISHOP," +1140 PRINT "TYPE 3; FOR A ROOK, TYPE 4; FOR A QUEEN, TYPE 5"; +1150 INPUT P +1160 IF P>5 OR P<2 THEN 1130 +1170 B(X2,Y2)=-P:TM(X2,Y2)=-P +1180 IF B(X2,Y2)<>-6 OR ABS(X1-X2)<>2 THEN 1240 +1190 IF X1-X2=2 THEN 1250 +1200 B(8,8)=0:TM(8,8)=0 +1210 B(X2-1,8)=-4:TM(X2-1,8)=-4 +1220 CB=(CB AND -3) +1230 PRINT "IT'S ABOUT TIME YOU CASTLED!":PRINT +1240 RETURN +1250 B(1,8)=0:TM(1,8)=0 +1260 B(X2+1,8)=-4:TM(X2+1,8)=-4 +1270 CB=(CB AND -3) +1280 GOTO 1230 +1290 REM -- OUTPUT ROUTINE -- +1300 IF PS(MX,3)<200 THEN 1350 +1310 PRINT "HA - LET'S SEE YOU GET OUT OF THIS -" +1320 PRINT "I MOVE";PS(MX,1);"TO";PS(MX,2) +1330 PRINT "THANKS FOR THE GOOD GAME..." +1340 END +1350 ON INT(RND(1)*4)+1 GOTO 1360,1370,1380,1390 +1360 PRINT "I RECKON I'LL MOVE ";:GOTO 1400 +1370 PRINT "I GUESS I'LL TAKE";:GOTO 1400 +1380 PRINT "MY MOVE IS";:GOTO 1400 +1390 PRINT "I LIKE"; +1400 PRINT PS(MX,1);"TO";PS(MX,2):PRINT +1410 D1=FNL(PS(MX,1)) +1420 D2=FNM(PS(MX,1)) +1430 D3=FNL(PS(MX,2)) +1440 D4=FNM(PS(MX,2)) +1450 B(D3,D4)=B(D1,D2) +1460 B(D1,D2)=0 +1470 IF D4<>8 OR B(D3,D4)<>1 THEN 1500 +1480 PRINT "I PROMOTE MY PAWN TO A QUEEN!" +1490 B(D3,D4)=5 +1500 RETURN +1510 REM +1520 EV=RND(1):RETURN +1530 EV=RND(1)/2:US=0 +1540 EV=EV+D4/7 +1550 FOR PJ=1 TO 8 +1560 IF TM(PJ,8)<>1 THEN 1590 +1570 TM(PJ,8)=5 +1580 GOTO 1610 +1590 NEXT PJ +1600 IF SGN(D5)=-1 THEN EV=EV-D5 +1610 FOR X=1 TO 8 +1620 FOR Y=1 TO 8 +1630 CX=TM(X,Y):CS=SGN(CX) +1640 IF CS<>-1 THEN 1750 +1650 EV=EV+CX +1660 GOSUB 1840 +1670 IF N=0 THEN 1750 +1680 US=US+N:EV=EV-.166666 +1690 FOR UX=1 TO N +1700 U1=MV(UX,1):U2=MV(UX,2) +1710 IF SGN(TM(FNL(U2),FNM(U2)))<>1 THEN 1740 +1720 IF SGN(TM(FNL(U1),FNM(U1)))<>-1 THEN 1740 +1730 EV=EV-2*TM(FNL(U2),FNM(U2)) +1740 NEXT UX +1750 NEXT Y +1760 NEXT X +1770 IF US>0 THEN 1800 +1780 EV=EV+1000 +1790 GOTO 1810 +1800 FOR X=3 TO 6:FOR Y=3 TO 6:EV=EV+TM(X,Y)/3:NEXTY:NEXTX +1810 IF PJ>8 THEN 1830 +1820 TM(PJ,8)=1 +1830 RETURN +1840 REM +1850 R=0 +1860 GOTO 1880 +1870 R=1 +1880 MV(1,1)=0 +1890 S1=SGN(TM(X,Y)) +1900 AA=X*10+Y +1910 N=1 +1920 ON ABS(TM(X,Y)) GOSUB 2330,2770,2880,3140,3400,3440 +1930 IF N=1 THEN 1950 +1940 IF R=1 THEN 1970 +1950 N=N-1 +1960 RETURN +1970 REM -- IF RESTRICTED -- +1980 N1=N-1 +1990 N=N1 +2000 FOR K=1 TO N1 +2010 C1=FNL(MV(K,1)) +2020 C2=FNM(MV(K,1)) +2030 C3=FNL(MV(K,2)) +2040 C4=FNM(MV(K,2)) +2050 IF ABS(TM(C3,C4))=6 THEN 2070 +2060 IF SGN(TM(C3,C4))<>S1 THEN 2080 +2070 MV(K,1)=0:MV(K,2)=0:GOTO 2290 +2080 C5=TM(C3,C4) +2090 TM(C3,C4)=TM(C1,C2) +2100 TM(C1,C2)=0 +2110 REM -- FIND KING -- +2120 FOR Y2=1 TO 8 +2130 FOR X2=1 TO 8 +2140 IF TM(X2,Y2)=6*S1 THEN 2170 +2150 NEXT X2 +2160 NEXT Y2 +2170 REM +2180 FOR Y1=1 TO 8 +2190 FOR X1=1 TO 8 +2200 IF SGN(TM(X1,Y1))<>-S1 THEN 2250 +2210 IF TM(X1,Y1)<>-S1 THEN 2230 +2220 IF X1=X2 AND ABS(Y2-Y1)>2 THEN 2250 +2230 GOSUB 3660 +2240 IF LG=1 THEN 2310 +2250 NEXT X1 +2260 NEXT Y1 +2270 TM(C1,C2)=TM(C3,C4) +2280 TM(C3,C4)=C5 +2290 NEXT K +2300 RETURN +2310 MV(K,1)=0:MV(K,2)=0 +2320 GOTO 2250 +2330 REM -- RAW PAWN MOVE -- +2340 IF S1=-1 THEN 2560 +2350 IF Y+1>8 THEN 2550 +2360 IF TM(X,Y+1)<>0 THEN 2450 +2370 MV(N,1)=AA +2380 MV(N,2)=X*10+Y+1 +2390 N=N+1 +2400 IF Y>2 THEN 2450 +2410 IF TM(X,Y+2)<>0 THEN 2450 +2420 MV(N,1)=AA +2430 MV(N,2)=X*10+Y+2 +2440 N=N+1 +2450 IF X=1 THEN 2500 +2460 IF SGN(TM(X-1,Y+1))<>-S1 THEN 2500 +2470 MV(N,1)=AA +2480 MV(N,2)=(X-1)*10+Y+1 +2490 N=N+1 +2500 IF X=8 THEN 2550 +2510 IF SGN(TM(X+1,Y+1))<>-S1 THEN 2550 +2520 MV(N,1)=AA +2530 MV(N,2)=(X+1)*10+Y+1 +2540 N=N+1 +2550 RETURN +2560 IF Y-1<1 THEN 2760 +2570 IF TM(X,Y-1)<>0 THEN 2660 +2580 MV(N,1)=AA +2590 MV(N,2)=X*10+Y-1 +2600 N=N+1 +2610 IF Y<7 THEN 2660 +2620 IF TM(X,Y-2)<>0 THEN 2660 +2630 MV(N,1)=AA +2640 MV(N,2)=X*10+Y-2 +2650 N=N+1 +2660 IF X=1 THEN 2710 +2670 IF SGN(TM(X-1,Y-1))<>-S1 THEN 2710 +2680 MV(N,1)=AA +2690 MV(N,2)=(X-1)*10+Y-1 +2700 N=N+1 +2710 IF X=8 THEN 2760 +2720 IF SGN(TM(X+1,Y-1))<>-S1 THEN 2760 +2730 MV(N,1)=AA +2740 MV(N,2)=(X+1)*10+Y-1 +2750 N=N+1 +2760 RETURN +2770 REM -- RAW KNIGHT MOVE -- +2780 FOR C6=1 TO 15 STEP 2 +2790 KL=V(C6):KM=V(C6+1) +2800 XT=X+KL +2810 YT=Y+KM +2820 IF XT>8 OR XT<1 OR YT>8 OR YT<1 THEN 2860 +2830 MV(N,1)=AA +2840 MV(N,2)=XT*10+YT +2850 N=N+1 +2860 NEXT C6 +2870 RETURN +2880 REM -- RAW BISHOP MOVE -- +2890 EL=(8-Y)*-(8-Y<=8-X)+(8-X)*-(8-X < 8-Y) +2900 IF EL=0 THEN 2930 +2910 C6=11 +2920 GOSUB 3060 +2930 EL=(8-Y)*-(8-Y <= X-1)+(X-1)*-(X-1 < 8-Y) +2940 IF EL=0 THEN 2970 +2950 C6=-9 +2960 GOSUB 3060 +2970 EL=(8-X)*-(8-X <= Y-1)+(Y-1)*-(Y-1 < 8-X) +2980 IF EL=0 THEN 3010 +2990 C6=9 +3000 GOSUB 3060 +3010 EL=(Y-1)*-(Y-1 <= X-1)+(X-1)*-(X-1 < Y-1) +3020 IF EL=0 THEN 3050 +3030 C6=-11 +3040 GOSUB 3060 +3050 RETURN +3060 FOR E=1 TO EL +3070 F=C6*E +3080 MV(N,1)=AA +3090 MV(N,2)=AA+F +3100 N=N+1 +3110 IF TM(FNL(AA+F),FNM(AA+F))<>0 THEN 3130 +3120 NEXT E +3130 RETURN +3140 REM -- RAW ROOK MOVE -- +3150 EL=8-Y +3160 IF EL=0 THEN 3190 +3170 C6=1 +3180 GOSUB 3320 +3190 EL=Y-1 +3200 IF EL=0 THEN 3230 +3210 C6=-1 +3220 GOSUB 3320 +3230 EL=8-X +3240 IF EL=0 THEN 3270 +3250 C6=10 +3260 GOSUB 3320 +3270 EL=X-1 +3280 IF EL=0 THEN 3310 +3290 C6=-10 +3300 GOSUB 3320 +3310 RETURN +3320 FOR E=1 TO EL +3330 F=C6*E +3340 MV(N,1)=AA +3350 MV(N,2)=AA+F +3360 N=N+1 +3370 IF TM(FNL(AA+F),FNM(AA+F))<>0 THEN 3390 +3380 NEXT E +3390 RETURN +3400 REM -- RAW QUEEN MOVE -- +3410 GOSUB 2880 +3420 GOSUB 3140 +3430 RETURN +3440 REM -- RAW KING MOVE -- +3450 IF X=8 THEN 3510 +3460 C6=10:GOSUB 3620 +3470 IF Y=1 THEN 3500 +3480 C6=9:GOSUB 3620 +3490 IF Y=8 THEN 3520 +3500 C6=11:GOSUB 3620 +3510 IF X=1 THEN 3570 +3520 C6=-10:GOSUB 3620 +3530 IF Y=8 THEN 3570 +3540 C6=-9:GOSUB 3620 +3550 IF Y=1 THEN 3570 +3560 C6=-11:GOSUB 3620 +3570 IF Y=1 THEN 3590 +3580 C6=-1:GOSUB 3620 +3590 IF Y=8 THEN 3610 +3600 C6=1:GOSUB 3620 +3610 RETURN +3620 MV(N,1)=AA +3630 MV(N,2)=AA+C6 +3640 N=N+1 +3650 RETURN +3660 REM +3670 RR=0 +3680 GOTO 3700 +3690 RR=1 +3700 IF TM(X1,Y1)<>0 THEN 3720 +3710 LG=0:RETURN +3720 S=SGN(TM(X1,Y1)) +3730 A=X1*10+Y1 +3740 B=X2*10+Y2 +3750 ON ABS(TM(X1,Y1)) GOSUB 4070,4270,4340,4510,4630,4680 +3760 IF LG=0 THEN RETURN +3770 IF RR=1 THEN 3790 +3780 LG=1:RETURN +3790 REM -- IF RESTRICTED -- +3800 IF S=SGN(TM(X2,Y2)) THEN 3710 +3810 T1=X1:T2=Y1:T3=X2:T4=Y2:T=TM(X2,Y2) +3820 TM(X2,Y2)=TM(X1,Y1):TM(X1,Y1)=0 +3830 SV=S +3840 REM -- FIND KING -- +3850 FOR Y2=1 TO 8 +3860 FOR X2=1 TO 8 +3870 IF TM(X2,Y2)=6*S THEN 3910 +3880 NEXT X2 +3890 NEXT Y2 +3900 END +3910 REM +3920 FOR Y1=1 TO 8 +3930 FOR X1=1 TO 8 +3940 P=TM(X1,Y1):IF SGN(P)=S OR P=0 OR ABS(P)=6 THEN 3980 +3950 GOSUB 3660 +3960 S=SV +3970 IF LG=1 THEN 4050 +3980 NEXT X1 +3990 NEXT Y1 +4000 LG=1 +4010 TM(T1,T2)=TM(T3,T4) +4020 TM(T3,T4)=T +4030 X1=T1:Y1=T2:X2=T3:Y2=T4 +4040 RETURN +4050 LG=0 +4060 GOTO 4010 +4070 REM -- RAW PAWN MOVE -- +4080 IF SGN(Y2-Y1)=S THEN 4110 +4090 LG=0:RETURN +4100 LG=1:RETURN +4110 IF S=-1 THEN 4190 +4120 IF B-A=1 OR B-A=2 THEN 4160 +4130 IF TM(X2,Y2)=0 THEN 4090 +4140 IF B-A=-9 OR B-A=11 THEN 4100 +4150 GOTO 4090 +4160 IF Y2=2 THEN 4100 +4170 IF B-A=1 THEN 4100 +4180 GOTO 4090 +4190 IF A-B=1 OR A-B=2 THEN 4230 +4200 IF TM(X2,Y2)=0 THEN 4090 +4210 IF A-B=-9 OR A-B=11 THEN 4100 +4220 GOTO 4090 +4230 IF Y2=7 THEN 4100 +4240 IF A-B=1 THEN 4100 +4250 IF Y1=7 AND A-B=2 THEN 4100 +4260 GOTO 4090 +4270 REM -- RAW KNIGHT MOVE -- +4280 FOR P=17 TO 24 +4290 P1=V(P) +4300 IF A+P1<>B THEN 4320 +4310 LG=1:RETURN +4320 NEXT P +4330 LG=0:RETURN +4340 REM -- RAW BISHOP MOVE -- +4350 IF Y2=Y1 OR X2=X1 THEN 4420 +4360 SP=-9 +4370 IF X2P THEN 4420 +4460 GOTO 4490 +4470 IF Y120 THEN 4890 +4700 IF A-B=20 THEN 4730 +4710 IF CB<>1 AND CB<>3 THEN 4880 +4720 GOTO 4740 +4730 IF CB=0 OR CB=1 THEN 4880 +4740 PS=SGN(A-B):FORP2=28+50*((PS=-1)*-1)TOA+10-20*((PS=-1)+1)STEP10*P +4750 IF TM(FNL(P2),FNM(P2))<>0 THEN 4880 +4760 NEXT P2:T1=X1:T2=Y1:T3=X2:T4=Y2 +4770 FOR P2=A TO 18+70*((PS=-1)*-1) STEP 10*-PS +4780 X2=FNL(P2):Y2=FNM(P2) +4790 FOR X1=1 TO 8 +4800 FOR Y1=1 TO 8 +4810 IF SGN(TM(X1,Y1))<>1 THEN 4840 +4820 GOSUB 3690 +4830 IF LG=1 THEN 4880 +4840 NEXT Y1:NEXT X1:NEXT P2 +4850 LG=1 +4860 X1=T1:Y1=T2:X2=T3:Y2=T4 +4870 RETURN +4880 LG=0:GOTO 4860 +4890 FOR P=25 TO 32 +4900 P1=V(P) +4910 IF B=A+P1 THEN 4940 +4920 NEXT P +4930 LG=0:RETURN +4940 LG=1:RETURN +4950 REM +4960 LG=0 +4970 IF P=0 THEN STOP +4980 IF P>1 THEN 5000 +4990 LG=1:RETURN +5000 FOR P1=1 TO P-1 +5010 P2=A+SP*P1 +5020 IF TM(FNL(P2),FNM(P2))<>0 THEN RETURN +5030 NEXT P1 +5040 LG=1:RETURN +5050 END + +5000 FOR P1=1 TO \ No newline at end of file diff --git a/disks/images/b/CIVILWAR.ASC b/disks/images/b/CIVILWAR.ASC new file mode 100644 index 0000000..dd90d9c --- /dev/null +++ b/disks/images/b/CIVILWAR.ASC @@ -0,0 +1,241 @@ +100 LET L=0:LET W=0:LET R1=0:LET P1=0 +110 LET Q1=0:LET M3=0:LET M4=0 +120 LET P2=0:LET T1=0:LET T2=0 +130 REMARKABLE PROGRAM BY L. CRAM , L. GOODIE , AND D. HIBBARD +140 PRINT "DO YOU WANT DESCRIPTIONS (0=YES, 1=NO)"; +150 INPUT Z +160 FOR U=1 TO 6 +170 PRINT +180 NEXT U +190 IF Z=1 THEN 420 +200 PRINT "THIS IS A CIVIL WAR SIMULATION." +210 PRINT "TO PLAY, TYPE A RESPONSE WHEN THE COMPUTER ASKS." +220 PRINT "REMEMBER THAT ALL FACTORS ARE INTERRELATED AND THAT YOUR" +230 PRINT "RESPONSES COULD CHANGE HISTORY. FACTS AND FIGURES USED ARE" +240 PRINT "BASED ON THE ACTUAL OCCURENCE. MOST BATTLES TEND TO RESULT" +250 PRINT "AS THEY DID IN THE CIVIL WAR, BUT IT ALL DEPENDS ON YOU!!" +260 PRINT +270 PRINT "THE OBJECT OF THE GAME IS TO WIN AS MANY BATTLES AS POSSIBLE" +280 PRINT +290 PRINT "YOUR CHOICES FOR DEFENSIVE STRATEGY ARE:" +300 PRINT " (1) ARTILLERY ATTACK" +310 PRINT " (2) FORTIFICATION AGAINST FRONTAL ATTACK" +320 PRINT " (3) FORTIFICATION AGAINST FLANKING MANUEVERS" +330 PRINT " (4) FALLING BACK" +340 PRINT "YOUR CHOICES FOR OFFENSIVE STRATEGY ARE:" +350 PRINT " (1) ARTILLERY ATTACK" +360 PRINT " (2) FRONTAL ATTACK" +370 PRINT " (3) FLANKING MANUEVERS" +380 PRINT " (4) ENCIRCLEMENT" +390 PRINT "YOU MAY SURRENDER BY TYPING A '5' FOR YOUR STRATEGY." +400 PRINT +410 PRINT "YOU ARE THE CONFEDERACY. GOOD LUCK!" +420 READ M1,M2,C1,C2,M,A,U +430 LET I1=10+(L-W)*2 +440 LET I2=10+(W-L)*2 +450 LET D1=100*INT((M1*(100-I1)/2000)*(1+(R1-Q1)/(R1+1))+.5) +460 LET D2=100*INT(M2*(100-I2)/2000+.5) +470 LET F1=5*M1/6 +480 LET A1=Z +490 FOR U=1 TO 4 +500 PRINT +510 NEXT U +520 PRINT "THIS IS THE BATTLE OF "; +530 GOSUB 1530 +540 PRINT " ","CONFEDERACY"," UNION" +550 PRINT "MEN"," ";INT(M1*(1+(P1-T1)/(M3+1)))," "; +560 PRINT INT(M2*(1+(P2-T2)/(M4+1))) +570 PRINT "MONEY","$";D1,"$";D2 +580 PRINT "INFLATION"," ";I1+15;"%"," ";I2;"%" +590 PRINT +600 PRINT "HOW MUCH DO YOU WISH TO SPEND FOR FOOD"; +610 INPUT F +620 IF F<0 THEN 1480 +630 PRINT "HOW MUCH DO YOU WISH TO SPEND FOR SALARIES"; +640 INPUT S +650 IF S<0 THEN 1480 +660 PRINT "HOW MUCH DO YOU WISH TO SPEND FOR AMMUNITION"; +670 INPUT B +680 IF B<0 THEN 1480 +690 PRINT +700 IF F+S+B<=D1 THEN 730 +710 PRINT "THINK AGAIN! YOU HAVE ONLY $" D1 +720 GOTO 590 +730 LET O=((2*F^2+S^2)/F1^2+1) +740 IF O<10 THEN 770 +750 PRINT "MORALE IS HIGH" +760 GOTO 810 +770 IF O<5 THEN 800 +780 PRINT "MORALE IS FAIR" +790 GOTO 810 +800 PRINT "MORALE IS POOR" +810 IF M<>3 THEN 840 +820 PRINT "YOU ARE ON THE OFFENSIVE" +830 GOTO 880 +840 IF M<>1 THEN 870 +850 PRINT "YOU ARE ON THE DEFENSIVE" +860 GOTO 880 +870 PRINT "BOTH SIDES ARE ON THE OFFENSIVE" +880 PRINT +890 PRINT "YOUR STEGY"; +900 INPUT Y +910 IF Y=5 THEN 2380 +920 IF ABS(Y-3)<3 THEN 950 +930 PRINT "YOU JERK! USE THE OTHER SET OF STRATEGIES!!" +940 GOTO 880 +950 PRINT +960 PRINT " ","CONFEDERACY","UNION" +970 LET C5=(2*C1/5)*(1+1/(2*(ABS(INT(4*RND(1)+1)-Y)+1))) +980 LET C5=INT(C5*(1+1/O)*(1.28+F1/(B+1))+.5) +990 IF C5+100/O=0 THEN 1110 +1090 PRINT "YOUR CASUALTIES WERE"INT(100*(C1-C5)/C1+.5);"% LESS THAN" +1100 GOTO 1120 +1110 PRINT "YOUR CASUALTIES WERE"INT(100*(C5-C1)/C1+.5);"% MORE THAN" +1120 PRINT "THE ACTUAL CASUALITIES AT "; +1130 LET A1=1 +1140 GO SUB800 +1150 IF U=1 THEN 1170 +1160 IF C5+E<17*C2*C1/(C5*20)+5*O THEN 1200 +1170 PRINT "YOU LOSE "; +1180 LET L=L+1 +1190 GOTO 1220 +1200 PRINT "YOU WIN "; +1210 LET W=W+1 +1220 GOSUB 1530 +1230 IF W=8 THEN 2400 +1240 LET T1=T1+C5+E +1250 LET T2=T2+17*C2*C1/(C5*20)+5*O +1260 LET P1=P1+C1 +1270 LET P2=P2+C2 +1280 LET Q1=Q1+(F+S+B) +1290 LET R1=R1+M1*(100-I1)/20 +1300 LETM3=M3+M1 +1310 LET M4=M4+M2 +1320 IF A=14 THEN 2410 +1330 GOTO 420 +1340 DATA 18000,18500,1967,2708,1,1,0 +1350 DATA 40000,44894,10699,13047,3,2,0 +1360 DATA 95000,115000,20614,15849,3,3,0 +1370 DATA 54000,63000,10000,14000,2,4,0 +1380 DATA 40000,50000,10000,12000,3,5,0 +1390 DATA 75000,120000,5377,12653,1,6,0 +1400 DATA 38000,45000,11000,12000,1,7,0 +1410 DATA 32000,90000,13000,17197,2,8,0 +1420 DATA 50000,70000,12000,19000,1,9,0 +1430 DATA 72500,85000,20000,23000,3,10,0 +1440 DATA 66000,60000,18000,16000,2,11,0 +1450 DATA 37000,60000,6700,5800,2,12,0 +1460 DATA 62000,110000,17723,18000,2,13,0 +1470 DATA 65000,100000,8500,3700,1,14,0 +1480 PRINT "GO TO JAIL." +1490 PRINT "GO DIRECTLY TO JAIL." +1500 PRINT "DO NOT PASS GO." +1510 PRINT "DO NOT COLLECT $200" +1520 GOTO 490 +1530 IF A<>1 THEN 1600 +1540 PRINT "BULL RUN" +1550 IF A1=1 THEN 2360 +1560 PRINT"JULY 21,1861 GEN. BEAUREGARD COMMANDING THE SOUTH MET THE" +1570 PRINT"UNION FORCES WITH GEN MCDOWELL IN A PREMATURE BATTLE AT BULL" +1580 PRINT"RUN. GEN. JACKSON HELPED PUSH BACK THE UNION ATTACK." +1590 GOTO 2360 +1600 IF A<>2 THEN 1660 +1610 PRINT "SHILOH" +1620 IF A1=1 THEN 2360 +1630 PRINT"APRIL 6-7,1862 THE CONFEDERATE SURPRISE ATTACK AT SHILOH" +1640 PRINT"FAILED DUE TO POOR ORGANIZATION." +1650 GOTO 2360 +1660 IF A<>3 THEN 1730 +1670 PRINT "SEVEN DAYS" +1680 IF A1=1 THEN 2360 +1690 PRINT"JUNE 25-JULY 1,1862 GENERAL LEE (CSA) UPHELD THE OFFENSIVE" +1700 PRINT"THROUGHOUT THE BATTLE AND FORCED GEN. MCCLELLAN AND THE UNION" +1710 PRINT"FORCES AWAY FROM RICHMOND." +1720 GOTO 2360 +1730 IF A<>4 THEN 1790 +1740 PRINT "THE SECOND BULL RUN" +1750 IF A1=1 THEN 2360 +1760 PRINT"AUG 29-30,1862 THE COMBINED CONFEDERATE FORCES UNDER LEE AND" +1770 PRINT"JACKSON DROVE THE UNION FORCES BACK INTO WASHINGTON." +1780 GOTO 2360 +1790 IF A<>5 THEN 1850 +1800 PRINT "ANTIETAM" +1810 IF A1=1 THEN 2360 +1820 PRINT"SEPT 17,1862 THE SOUTH FAILED TO INCORPORATE MARYLAND INTO" +1830 PRINT"THE CONFEDERACY." +1840 GOTO 2360 +1850 IF A<>6 THEN 1910 +1860 PRINT "FREDERICKSBURG" +1870 IF A1=1 THEN 2360 +1880 PRINT"DEC 13,1862 THE CONFEDERACY UNDER LEE SUCESSFULLY REPULSED" +1890 PRINT"AN ATTACK BY THE UNION UNDER GEN. BURNSIDE." +1900 GOTO 2360 +1910 IF A <>7 THEN 1960 +1920 PRINT "MURFREESBORO" +1930 IF A1=1 THEN 2360 +1940 PRINT"DEC 31,1862 THE SOUTH UNDER GEN. BRAGG WON A CLOSE BATTLE" +1950 GOTO 2360 +1960 IF A<>8 THEN 2020 +1970 PRINT "CHANCELLORSVILLE" +1980 IF A1=1 THEN 2360 +1990 PRINT"MAY 1-6,1863 THE SOUTH HAD A COSTLY VICTORY AND LOST ONE" +2000 PRINT"OF THEIR OUTSTANDING GENERALS, 'STONEWALL' JACKSON." +2010 GOTO 2360 +2020 IF A<>9 THEN 2080 +2030 PRINT "VICKSBURG" +2040 IF A1=1 THEN 2360 +2050 PRINT"JULY 4,1863 VICKSBURG WAS A COSTLY DEFEAT FOR THE SOUTH" +2060 PRINT"BECAUSE IT GAVE THE UNION ACCESS TO THE MISSISSIPPI." +2070 GOTO 2360 +2080 IF A<>10 THEN 2140 +2090 PRINT "GETTYSBURG" +2100 IF A1=1 THEN 2360 +2110 PRINT"JUNE 30,1863 A SOUTHERN MISTAKE BY GEN. LEE AT GETTYSBURG" +2120 PRINT"COST THEM ONE OF THE MOST CRUCIAL BATTLES OF THR WAR." +2130 GOTO 2360 +2140 IF A<>11 THEN 2200 +2150 PRINT "CHICKAMAUGA" +2160 IF A1=1 THEN 2360 +2170 PRINT"NOV 25,1863 AFTER THE SOUTH HAD SIEGED GEN. ROSENCRANS'" +2180 PRINT"ARMY FOR THREE MONTHS, GEN. GRANT BROKE THE SIEGE." +2190 GOTO 2360 +2200 IF A<>12 THEN 2260 +2210 PRINT "CHATTANOOGA" +2220 IF A1=1 THEN 2360 +2230 PRINT"SEPT 15,1863 CONFUSION IN A FOREST NEAR CHICKAMAUGA LED" +2240 PRINT"TO A COSTLY SOUTHERN VICTORY." +2250 GOTO 2360 +2260 IF A<>13 THEN 2320 +2270 PRINT "SPOTSYLVANIA" +2280 IF A1=1 THEN 2360 +2290 PRINT"MAY 5,1864 GRANT'S PLAN TO KEEP LEE ISOLATED BEGAN TO FAIL" +2300 PRINT"HERE, AND CONTINUED AT COLD HARBOR AND PETERSBURG." +2310 GOTO 2360 +2320 PRINT "ATLANTA" +2330 IF A1=1 THEN 2360 +2340 PRINT"AUGUST, 1864 SHERMAN AND THREE VETERAN ARMIES CONVERGED ON" +2350 PRINT"ATLANTA AND DEALT THE DEATH BLOW TO THE CONFEDERACY." +2360 PRINT +2370 RETURN +2380 PRINT "THE CONFEDERACY HAS SURRENDERED" +2390 GOTO 2410 +2400 PRINT "THE UNION HAS SURRENDERED" +2410 PRINT +2420 PRINT "YOU HAVE WON" W; "BATTLES AND LOST" L; "BATTLES." +2430 IF Y=5 THEN 2470 +2440 IF W<=L THEN 2470 +2450 PRINT "THE CONFEDERACY HAS WON THE WAR" +2460 STOP +2470 PRINT "THE UNION HAS WON THE WAR" +2480 END +IF W<=L THEN 2470 +2450 PRINT "THE CONFED \ No newline at end of file diff --git a/disks/images/b/CLIMATES.ASC b/disks/images/b/CLIMATES.ASC new file mode 100644 index 0000000..2ccbe5b --- /dev/null +++ b/disks/images/b/CLIMATES.ASC @@ -0,0 +1,200 @@ +100 REM--E.A.GALLETTA,PATCHOGUE-H.S.,4/22/69 EARTH SIENCE (BIICAC) +110 REM--PROGRAM ON CLIMATES +120 REM--REWRITTEN--7/28/69--BASIC-- +130 REM REVISED BY TONY PEREZ, WALT WHITMAN HS, 8-69 +140 REM RE-REVISED BY C.LOSIK 8-26-70 +150 DIML(56) +160 READN,L(N) +170 IFN<>56THEN 160 +180 T=0 +190 PRINT"O.K., HERE ARE SOME VALUES FOR THE PRECIPIATION (P) AND FOR +200 PRINT"THE POTENTIAL EVAPOTRANSPIRATION (PE) OF AN AREA:" +210 PRINT +220 PRINT" ","MONTH"," P"," PE" +230 PRINT" ","=====","=====","======" +240 P=INT(10*RND(1)) +250 IFP>6THEN240 +260 IFP<1THEN240 +270 E=INT(10*RND(1)) +280 IFE>4THEN270 +290 IFE<1THEN270 +300 Z=5*E+6*P +310 IF (Z-21)*(Z-22)*(Z-17)*(Z-38)=0 THEN 240 +320 FORI=1TO12 +330 PRINT" ",I, +340 IFP>1THEN360 +350 P1=12*COS(.261*I)^2+2*RND(1) +360 IFP<>2THEN380 +370 P1=12*SIN(.261*I)+2*RND(1) +380 IFP<>3THEN400 +390 P1=2+3*RND(1) +400 IFP<>4THEN420 +410 P1=2*RND(1) +420 IFP<>5THEN440 +430 P1=7+10*RND(1) +440 IFP<>6THEN460 +450 P1=3*COS(.5+.15*I)^2 +460 PRINTINT(P1), +470 IFE>1THEN490 +480 E1=10*SIN(.261*I)^2 +490 IFE<>2THEN510 +500 E1=12*SIN(.261*I)^2 +510 IFE<>3THEN530 +520 E1=2*SIN(.5+.15*I)^2 +530 IFE<>4THEN550 +540 E1=8+4*RND(1) +550 T=T+INT(P1) +560 PRINTINT(E1+(E1/10)*2) +570 NEXTI +580 PRINT +590 PRINT"TOTAL PRECIPITATION =";T;"INCHES" +600 PRINT +610 PRINT"O.K., PLOT YOUR GRAPH ON THE PAPER PROVIDE YOU" +620 PRINT"AND WHEN YOU ARE READY TO CONTINUE.... MEREY TYPE" +630 PRINT"ANY NUMBER AND THE RETURN KEY. "; +640 INPUTQ +650 PRINT +660 PRINT"READY? GOOD, NOW TELL ME . . . DOES YOUR GRAPH SHOW THAT" +670 PRINT"THE CLIMATE HAS DEFINITE WET AND DRY SEASONS (1=YES, 0=NO) " +680 INPUT S +690 PRINT +700 IFS=0THEN880 +710 IF S<>1 THEN 660 +720 IFP<3THEN990 +730 B=0 +740 GOSUB 1960 +750 PRINT"TELL ME, IS THE CLIMATE [1] WET, [2] DRY, R [3] MODERATE ALL" +760 PRINT"YEAR"; +770 INPUT S +780 PRINT +790 IFS=1THEN920 +800 IFS=3THEN960 +810 IF S<>2 THEN 750 +820 IFT<13THEN1130 +830 IFT>80THEN860 +840 GOSUB1950 +850 GOTO1140 +860 GOSUB1910 +870 GOTO1140 +880 IFP>2THEN750 +890 IFP=2THEN820 +900 GOSUB1910 +910 GOTO990 +920 IFT>80THEN1130 +930 IFT>=13THEN840 +940 GOSUB1930 +950 GOTO1140 +960 IF(T-13)*(80-T)>=0THEN1130 +970 IFT<13THEN940 +980 IFT>80THEN860 +990 PRINT"TELL ME, WHICH IS THE WET SEASON, [1] THE WINTER OR [2] THE" +1000 PRINT"SUMMER"; +1010 PRINT +1020 INPUT S +1030 PRINT +1040 IFS=1THEN1090 +1050 IF S<>2 THEN 990 +1060 IFP=2THEN1130 +1070 GOSUB1910 +1080 GOTO1140 +1090 IFP=1THEN1130 +1100 GOSUB1910 +1110 GOTO1140 +1120 PRINT +1130 PRINT"NICE GOING, SMARTY PANTS. KEEP UP THE GOODWORK." +1140 PRINT"BY CHECKING THE PE CURVE ON YOUR GRAPH, WOUD YOU SAY THAT THE" +1150 PRINT"SUMMERS ARE [1] HOT, [2] WARM, OR [3] COOL" +1160 INPUT S +1170 PRINT +1180 IFS=2THEN1260 +1190 IFS=3THEN1300 +1200 IF S<>1 THEN 1130 +1210 IFE=2THEN1320 +1220 IFE=4THEN1320 +1230 IF E=1 THEN 1320 +1240 GOSUB1910 +1250 GOTO1330 +1260 IFE=1THEN1320 +1270 IFE<>3THEN1240 +1280 GOSUB1950 +1290 GOTO1330 +1300 IFE=3THEN1320 +1310 IFE<>3THEN1240 +1320 PRINT"YOU HAVE RESTORED MY FAITH IN TEENAGERS." +1330 PRINT"FROM THE SAME INFORMATION (PE GRAPH), WOULD YOU SAY THAT THE" +1340 PRINT"WINTERS ARE [1] COLD, [2] MILD, OR [3] WARM"; +1350 INPUT S +1360 PRINT +1370 IFS=2THEN1450 +1380 IFS=3THEN1490 +1390 IF S<>1 THEN 1330 +1400 IFE<3THEN1520 +1410 GOSUB1930 +1420 GOTO1530 +1430 GOSUB1950 +1440 GOTO1530 +1450 IFE=3THEN1520 +1460 IFE=4THEN1430 +1470 GOSUB1910 +1480 GOTO1530 +1490 IFE=3THEN1410 +1500 IFE=4THEN1530 +1510 GOTO1470 +1520 PRINT"IT WARMS MY HEART TO HEAR YOU SAY THAT. GOOD GOING." +1530 PRINT +1540 PRINT"WELL, BY NOW YOU MUST HAVE AN INKLING AS TO THE TYPE OF" +1550 PRINT"CLIMATE WE HAVE HERE. BELOW IS A COMPLETE LISTING OF ALL THE +1560 PRINT"CLIMATES IN THE WORLD. REFER TO THEM BY THEIR NUMBER ONLY." +1570 PRINT +1580 PRINT +1590 PRINT"NUMBER","NAME OF CLIMATE" +1600 PRINT"======","===============" +1610 PRINT"1","TROPICAL RAINFOREST" +1620 PRINT"2","TROPICAL EAST COAST" +1630 PRINT"3","TROPICAL MONSOON" +1640 PRINT"4","TROPICAL SAVANNA" +1650 PRINT"5","TROPICAL DESERT" +1660 PRINT"6","MEDITERRANEAN" +1670 PRINT"7","MARINE WEST COAST" +1680 PRINT"8","HUMID CONTINENTAL" +1690 PRINT"9","HUMID SUBTROPICAL" +1700 PRINT"10","MIDDLE LATITUDE GRASSLANDS" +1710 PRINT"11","MIDDLE LATITUDE DESERT" +1720 PRINT"12","SUBARTIC CLIMATES" +1730 PRINT"13 OR 14","HIGHLAND CLIMATES" +1740 PRINT" ","(TROPICAL OR MIDDLE LATITUDES)" +1750 PRINT"15","POLAR TUNDRA" +1760 PRINT"16","POLAR ICECAP" +1770 PRINT +1780 PRINT"WHAT IS THE NUMBER OF THE CLIMATE WE HAVE (WE'LL ACCEPT THE" +1790 PRINT "FACT THAT THEY MAY OVERLAP)"; +1800 INPUTS +1810 PRINT +1820 PRINT +1830 PRINT +1840 IFS=L(Z)THEN1880 +1850 PRINT"MY SUGGESTION - STICK TO LANGUAGES OR SOCIAL STUDIES." +1860 PRINT"YOU SHOULD HAVE SAID";L(Z);". GOOD DAY TO YOU." +1870 STOP +1880 PRINT"YOUR FORTUNE AS A METEOROLOGIST IS BUDDING. IT WAS" +1890 PRINT"VERY NICE TO WORK WITH YOU. SO LONG." +1900 STOP +1910 B=1 +1920 GOTO1960 +1930 B=2 +1940 GOTO1960 +1950 B=3 +1960 PRINT"AW C'MON, YOU COULDN'T POSSIBLY MEAN THAT..." +1970 PRINT"YOU SHOULD HAVE SAID";B +1980 PRINT +1990 RETURN +2000 DATA11,6,16,7,23,10,26,3,27,15 +2010 DATA28,8,29,11,32,3,33,13,34,11 +2020 DATA 35,9,39,16,40,8,41,13,44,5 +2030 DATA46,10,45,16,50,1,51,12,56,4 +2040 DATA39,4,44,5,35,9,40,8,45,1,41,15,46,12,51,5,56,16 +2050 DATA0,0 +2060 END +,44,5 +2030 DATA46,10,45,16,50,1,51,12,56,4 +2040 DATA39,4,44,5,35,9,40,8,45,1,41,15,46,12,51,5,56,16 \ No newline at end of file diff --git a/disks/images/b/CLOUD-9.ASC b/disks/images/b/CLOUD-9.ASC new file mode 100644 index 0000000..a03d675 --- /dev/null +++ b/disks/images/b/CLOUD-9.ASC @@ -0,0 +1,199 @@ +10 REM--A.C.CAGGIANO+E.A.GALLETTA, PATCHOGUE H.S., 11-20-68 +11 REM--REVISED BY CHARLES LOSIK AND TONY PEREZ 7/18/69 +12 REM RE-REVISED BY C.LOSIK 8-26-70 +20 REM--THIS PROGRAM IS ASSOCIATED WITH CLOUD FORMATION +25 REM PHASE I OF PROGRAM BEGINS HERE. STUDENTS WILL BE GIVEN +26 REM INTRODUCTORY INFORMATION AND BE ALLOWED TO ASK AND ANSWER +27 REM ANY NUMBER OF PROBLEMS. WHEN THEY INPUT NO. 2 (LINES 554-556) +28 REM PROGRAM SENDS THEM TO PHASE II (LINE 561 AND FOLLOWING). +30 PRINT" ","CLOUD NINE" +40 PRINT" ","===== ====" +45 DIM B(2), T(4), Q(3), A(3), C(3) +50 PRINT +60 PRINT" STRONG CONVECTION CURRENTS ARE CAUSING ADIABATIC" +70 PRINT"COOLING OF AIR WHERE YOU ARE AND ARE RESPONSIBLE FOR THE" +80 PRINT"FORMATION OF A CLOUD. BOTH THE DRY AND THE MOIST ADIABATIC" +90 PRINT"(AS WELL AS THE NORMAL LAPSE RATES) ARE CONSIDERED IN THIS" +91 PRINT"PROGRAM." +100 PRINT +105 PRINT +110 PRINT" ","LEGEND" +120 PRINT" ","======" +140 PRINT"1="; +150 GOSUB1000 +160 PRINT"2="; +170 GOSUB1010 +180 PRINT"3="; +190 GOSUB1020 +200 PRINT"4="; +210 GOSUB1030 +220 PRINT +225 PRINT +230 PRINT"CHOOSE ANY TWO OF THE ABOVE VARIABLES AND SELECT VALUES FOR" +231 PRINT"THEM. TYPE THEM IN AS:" +232 PRINT"VARIABLE CODE ,VALUE, VARIABLE CODE ,VALUE...(E.G. 1,50,2,30)" +233 PRINT +240 X=0 +242 Y=0 +245 A=0 +246 B=0 +247 B(1)=0 +248 B(2)=0 +250 INPUTB(1),A,B(2),B +290 PRINT +300 FORI=1TO4 +310 IFB(1)=ITHEN330 +320 NEXTI +330 T(I)=A +340 FORJ=1TO4 +350 IFB(2)=JTHEN370 +360 NEXTJ +370 T(J)=B +380 IFI<>JTHEN405 +390 PRINT"YOU CAN'T USE THE SAME VALUES TWICE." +395 GOTO250 +405 PRINT"OKAY, TYPE IN YOUR CALCULATED VALUE FOR"; +406 PRINT +410 IFJ*I<>2THEN425 +411 T=(T(1)-T(2))/4.5 +412 T(4)=1000*T +413 T(3)=T(2)-T +414 GOSUB1020 +415 GOSUB1050 +416 GOSUB1030 +417 INPUTX,Y +418 IFABS(X-T(3))>=.6THEN500 +419 IFABS(Y-T(4))>=.6THEN500 +420 GOTO550 +425 IFJ*I<>3THEN440 +426 T=(T(1)-T(3))/5.5 +427 T(4)=1000*T +428 T(2)=T+T(3) +429 GOSUB1010 +430 GOSUB1050 +431 GOSUB1030 +432 INPUTX,Y +433 IFABS(X-T(2))>=.6THEN500 +434 IFABS(Y-T(4))>=.6THEN500 +435 GOTO550 +440 IFJ*I<>4THEN455 +441 T=T(4)/1000 +442 T(2)=T(1)-4.5*T +443 T(3)=T(2)-T +444 GOSUB1010 +445 GOSUB1050 +446 GOSUB1020 +447 INPUTX,Y +448 IFABS(X-T(2))>=.6THEN500 +449 IFABS(Y-T(3))>=.6THEN500 +450 PRINT"OKAY, TYPE IN YOUR CALCULATED VALUE FOR" +455 IFJ*I<>6THEN470 +456 T=T(2)-T(3) +457 T(4)=1000*T +458 T(1)=T(3)+5.5*T +459 GOSUB1000 +460 GOSUB1050 +461 GOSUB1030 +462 INPUTX,Y +463 IFABS(X-T(1))>=.6THEN500 +464 IFABS(Y-T(4))>=.6THEN500 +465 GOTO550 +470 IFJ*I<>8THEN485 +471 T=T(4)/1000 +472 T(3)=T(2)+T +473 T(1)=T(2)+6.5*T +474 GOSUB1010 +475 GOSUB1050 +476 GOSUB1020 +477 INPUTX,Y +478 IFABS(X-T(1))>=.6THEN500 +479 IFABS(Y-T(3))>=.6THEN500 +480 GOTO550 +481 IFABS(X-T(3))>=.6THEN500 +485 IFJ*I<>12THEN390 +486 T=T(4)/1000 +487 T(1)=T(3)+5.5*T +488 T(2)=T(3)+T +489 GOSUB1000 +490 GOSUB1050 +491 GOSUB1010 +492 INPUTX,Y +493 IFABS(X-T(1))>=.6THEN500 +494 IFABS(Y-T(2))>=.6THEN500 +495 GOTO550 +500 PRINT +502 PRINT"IT LOOKS LIKE WE GOOFED SOME PLACE." +505 PRINT"LET'S SEE WHAT THE CORRECT VALUES ARE." +507 PRINT +510 PRINT T(1);"DEGREES - "; +512 GO SUB 1000 +515 PRINT T(2);"DEGREES - "; +517 GO SUB 1010 +520 PRINT T(3);"DEGREES - "; +522 GO SUB 1020 +525 PRINT T(4);"FEET - "; +527 GO SUB 1030 +530 PRINT +535 GOTO554 +550 PRINT +552 PRINT"VERY GOOD. VERY, VERY GOOD." +553 PRINT +554 PRINT"DO YOU HAVE ANY OTHER PROBLEMS YOU WOULD LIKE TO TRY?" +555 PRINT "(1=YES, 0=NO) : "; +556 INPUT P +557 IFP<1THEN561 +558 PRINT +559 PRINT"USING THE SAME LEGEND AS BEFORE..." +560 GOTO230 +561 H=(T(1)-T(3))*2000-7*T(4) +562 REM LINE 561 CALCULATES ALTITUDE FOR TOP OF CLOUD AND BEGINS +563 REM PHASE II OF PROGRAM. PROBLEM NO.2 IN THIS PART (CALCULATION +564 REM OF TEMP. ABOVE CLOUD TOP) INVOLVES USE OF THE NORMAL LAPSE RATE. +565 PRINT +567 PRINT"WELL, BEFORE YOU LEAVE, I HAVE A FEW I'D LIKE YOU TO TRY..." +570 PRINT"BASED ON YOUR VALUES, THE HEIGHT OF THE CLOUD" +580 PRINT"(MEASURED FROM THE CLOUD BASE) IS ";H;"FT. CAN YOU TELL ME:" +600 Q(1)=.7*T(4) +601 Q(2)=T(4)+1.5*H +602 Q(3)=T(4)+.5*H +610 A(1)=T(1)-T(4)*3.85E-03 +611 A(2)=T(1)-(T(4)+1.5*H)*3.5E-03 +612 A(3)=T(3)-1.5E-03*H +614 PRINT +615 PRINT"WHAT IS THE TEMPERATURE AT EACH OF THESE ALTITUDES:" +620 FORN=1TO3 +625 PRINT" ",N;INT(Q(N)+.5);"FT" +627 NEXT N +628 PRINT +629 FORN=1TO3 +630 PRINT"THE TEMPERATURE AT ";INT(Q(N)+.5);" FT. IS "; +631 INPUTC(N) +635 IFABS(C(N)-A(N))>1.1THEN750 +640 NEXTN +699 PRINT +700 PRINT"WOW, YOU MUST BE A BRAIN. AND YOU PROBALLY KNOW" +710 PRINT"A LOT ABOUT CLOUDS AND THINGS LIKE THAT. IT WAS VERY" +720 PRINT"NICE TO WORK WITH SOMEONE WHO UNDERSTANDS ME." +730 PRINT" ","THANK YOU AND . . . . PEACE AND LONG LIFE" +740 STOP +750 PRINT +755 PRINT"SORRY. YOU WERE DOING GREAT THERE FOR A WHILE." +760 PRINT"WELL, BACK TO THE BOOKS. THE VALUES YOU SHOULD HAVE ARE:" +765 PRINT +770 FORN=1TO3 +774 PRINTN; +780 PRINT"THE TEMPERATURE AT";INT(Q(N)+.5);"FEET IS ";A(N);"DEGREES" +790 NEXTN +830 STOP +1000 PRINT"THE TEMPERATURE ON THE GROUND" +1005 RETURN +1010 PRINT"THE DEW POINT TEMPERATURE ON THE GROUND" +1015 RETURN +1020 PRINT"THE TEMPERATURE AT THE BASE OF THE CLOUD" +1025 RETURN +1030 PRINT"THE ELEVATION, IN FEET, OF THE CLOUD BASE" +1035 RETURN +1050 PRINT"FOLLOWED BY A COMMA, AND THEN TYPE IN YOUR VALUE FOR " +1055 RETURN +2000 END + \ No newline at end of file diff --git a/disks/images/b/CRAPS.ASC b/disks/images/b/CRAPS.ASC new file mode 100644 index 0000000..e997f3a --- /dev/null +++ b/disks/images/b/CRAPS.ASC @@ -0,0 +1,147 @@ +100 REM SOURCE UNKNOWN: REVISED BY D. KURLAND 11/16/75 +110 PRINT " ------ C - R - A - P - S ------" +120 PRINT "DO YOU KNOW HOW TO PLAY"; +130 INPUT T$ +140 IF T$="YES" OR T$="Y" THEN 270 +150 PRINT "YOU ARE NOW ENTERING THE CASINO UNIVAC 1108 LOCATED" +160 PRINT "IN DOWNTOWN LAS VEGAS. YOU'VE JUST WON $25000 FROM THE" +170 PRINT "READERS DIGEST SWEEPSTAKES, AND ARE FEELING FREE AND" +180 PRINT "EASY. YOUR KEEN EYES LOCATE A CRAP TABLE. THE GREEN" +190 PRINT "FELT LOOKS VERY INVITING. YOU SEE A GIRL IN A" +200 PRINT "PLAYBOY BUNNY OUTFIT. SHE DECIDES TO START A CONVER-" +210 PRINT "SATION WITH YOU." +220 PRINT +230 PRINT "HI THERE, I AM THE ONE AND ONLY MISS TELETYPE. I'M SINGLE" +240 PRINT "AND LONELY. I'M ALSO THE DIRTIEST DICE THROWER THIS SIDE" +250 PRINT "OF IBM." +260 PRINT +270 PRINT "WHAT IS YOUR NAME"; +280 INPUT T$ +290 PRINT "HOW ABOUT IT, ";T$ +300 PRINT "WANT TO TRY YOUR LUCK"; +310 INPUT R$ +320 IF R$="NO" OR R$="N" THEN 1250 +330 PRINT "HERE'S YOUR SELECTION OF DICE:" +340 PRINT +350 PRINT " 1. BUNNY BLUE " +360 PRINT " 2. GROSS GREEN " +370 PRINT " 3. UNIVAC YELLOW " +380 X=25000 +390 PRINT "PLEASE INPUT ONLY ONE NUMBER, HONEY"; +400 INPUT F +410 IF F=1 THEN 440 +420 IF F=2 THEN 460 +430 IF F=3 THEN 480 +440 PRINT "I SEE YOU'RE THE SEXY TYPE" +450 GOTO 490 +460 PRINT "I SEE YOU'RE A REALLY BIG SPENDER" +470 GOTO 490 +480 PRINT "SO YOU'RE THE CONSERVATIVE TYPE" +490 PRINT "NOW YOU HAVE YOUR OWN COLORED DICE. YOU'VE GOT $25000" +500 PRINT "AND BEST OF ALL YOU ARE SITTING NEXT TO A PLAYBOY BUNNY" +510 PRINT +520 PRINT "MISS TELETYPE SAYS, BETS PLEASE" +530 PRINT "AND HOW MUCH IS OUR READERS DIGEST WINNER GOING TO WAGER" +540 PRINT "YOU HAVE GOT A MAXIMUM OF";X +550 INPUT A +560 IF A>X THEN 540 +570 IF A<0 THEN 1520 +580 IF A<=100 THEN 600 +590 IF A>=1000 THEN 660 +600 PRINT "BOY, WHAT A CHEAPSKATE" +610 GOTO 670 +620 PRINT "THAT'S A GOOD HONEST BET" +630 GOTO 670 +640 PRINT "NOW YOU ARE IN BUSINESS, LOVER" +650 GOTO 670 +660 PRINT "WHAT A SPENDER, LOVER, AND ALTOGETHER KOOL PERSON" +670 W=0 +680 W=W+1 +690 PRINT "YOU'RE NOW SHAKING YOUR DICE" +700 PRINT "YOU BLOW ON THEM FOR LUCK" +710 PRINT "YOU ROLL THEM" +720 R=INT (RND(1)*10)+1 +730 IF R>6 THEN 720 +740 Z=INT (RND(1)*10)+1 +750 IF Z>6 THEN 740 +760 PRINT "YOU'RE THROW WAS";R+Z +770 PRINT +780 IF W=1 THEN 820 +790 IF R+Z=7 OR R+Z=11 THEN 900 +800 IF R+Z=F THEN 920 +810 GOTO 850 +820 F=R+Z +830 IF F=7 OR F=11 THEN 870 +840 IF F=2 OR F=3 OR F=12 THEN 900 +850 PRINT "MUST SHAKE AGAIN. YOU HAVE NEITHER WON NOR LOST" +860 GOTO 1180 +870 PRINT "YOU HAVE JUST DOUBLED YOUR BET" +880 PRINT "YOU HAVE WON $";2*A +890 GOTO 950 +900 PRINT "YOU HAVE LOST WHAT YOU BET" +910 GOTO 1030 +920 PRINT "YOU HAVE JUST WON YOUR BET" +930 PRINT "YOU HAVE WON $";A +940 GOTO 990 +950 X=X+2*A +960 PRINT "YOUR TOTAL IS NOW $";X +970 IF X<0 THEN 1080 +980 GOTO 1100 +990 X = X+A +1000 PRINT "YOUR TOTAL IS NOW $";X +1010 IF X<0 THEN 1080 +1020 GOTO 1060 +1030 PRINT "YOU LOST $";A +1040 X=X-A +1050 PRINT "YOUR TOTAL IS NOW $"X +1060 IF X<0 THEN 1080 +1070 GOTO 1100 +1080 PRINT "YOU OWE MISS TELETYPE $";X +1090 GOTO 1480 +1100 PRINT +1110 IF X<0 THEN 1080 +1120 PRINT +1130 PRINT +1140 PRINT "DO YOU WANT TO TRY AGAIN"; +1150 INPUT P$ +1160 IF X<0 THEN 1080 +1170 IF P$="NO" OR P$="N" THEN 1490 ELSE 540 +1180 IF W>6 THEN 1230 +1190 IF W=6 THEN 1250 +1200 IF W=4 THEN 1460 +1210 IF W=5 THEN 1270 +1220 GOTO 1290 +1230 PRINT "THIS IS THE TIME FOR A KILLING, ";T$ +1240 GOTO 1290 +1250 PRINT "THE ODDS ARE GETTING BETTER YET" +1260 GOTO 1290 +1270 PRINT "THE ODDS ARE COMIN IN YOURE FAVOR, BABY. BET A LITTLE MORE" +1280 PRINT +1290 PRINT "DO YOU WISH TO INCREASE YOUR BET, ";T$; +1300 INPUT D$ +1310 IF D$="NO" OR D$="N" THEN 680 +1320 IF X-A>0 THEN 1370 +1330 IF X-A<0 THEN 1350 +1340 IF X-A=0 THEN 1390 +1350 PRINT "LISTEN, HONEY. YOU OWE ME $"X +1360 PRINT +1370 PRINT "HOW MUCH DO YOU WISH TO INCREASE YOUR WAGER BY, ";T$ +1380 GOTO 1410 +1390 PRINT "YOU HAVE NO MONEY TO BET WITH. YOU MUST HOPE FOR THE BEST" +1400 GOTO 680 +1410 PRINT +1420 PRINT "YOU'VE GOT $";X-A;"TO BET WITH." +1430 INPUT Z +1440 A=A+Z +1450 GOTO 680 +1460 PRINT "DO OR DIE SPEND IT RIGHT NOW, ";T$ +1470 GOTO 1370 +1480 PRINT "CREDIT NOT GOOD IN THIS CASINO" +1490 PRINT "YOUR TOTAL IS $";X +1500 PRINT "THANK YOU FOR COMING TO THE CASINO UNIVAC 1108" +1510 GOTO 1540 +1520 PRINT "YOU MUST BET A POSITIVE VALUE" +1530 GOTO 540 +1540 END +MING TO THE CASINO UNIVAC 1108" +1510 \ No newline at end of file diff --git a/disks/images/b/CRAZY-8.ASC b/disks/images/b/CRAZY-8.ASC new file mode 100644 index 0000000..ba5879a --- /dev/null +++ b/disks/images/b/CRAZY-8.ASC @@ -0,0 +1,267 @@ +100 REM SOURCE UNKNOWN: REVISED BY D. KURLAND 11/16/75 +110 PRINT "THIS IS THE GAME OF CRAZY EIGHTS" +120 DIM A(52),D(52),G(52),H(52) +130 DIM T(52),S(52),V(52) +140 DIM Z(52),U$(4),C$(13) +150 READ U$(1),U$(2),U$(3),U$(4) +160 FOR I=1 TO 13 +170 READ C$(I) +180 NEXT I +190 FOR I=1 TO 52 +200 READ Z(I) +210 NEXT I +220 DATA CLUBS,DIAMONDS,HEARTS,SPADES +230 DATA "2","3","4","5","6","7","8","9","10",JACK,QUEEN,KING,ACE +240 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +250 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +260 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +270 DATA 2,3,4,5,6,7,50,9,10,10,10,10,1 +280 PRINT "DO YOU KNOW HOW TO PLAY"; +290 INPUT A$ +300 IF A$="YES" OR A$="Y" THEN 400 +310 PRINT "WHEN ASKED WHICH CARD YOU WISH TO PLAY, YOUR ANSWER SHOULD" +320 PRINT "OF THE FORM: CARD,SUIT . ANY EIGHT MAY BE" +330 PRINT "PLAYED AT ANY TIME REGARDLESS OF SUIT TO CHANGE THE SUIT." +340 PRINT "IF YOU ARE UNABLE OR UNWILLING TO PLAY, YOU WILL BE GIVEN" +350 PRINT "ANOTHER CARD FROM THE DRAW STACK. IF ALL CARDS HAVE BEEN" +360 PRINT "DRAWN, ANY PERSON WHO IS ABLE TO PLAY MUST DO SO." +370 PRINT "AT THE END OF THE GAME, THE PERSON HOLDING CARDS HAS POINTS" +380 PRINT "SCORED AGAINST HIM AS FOLLOWS: EIGHTS=50, ACE=1, FACE" +390 PRINT "CARD=10, INDEX VALUE FOR EACH OTHER CARD." +400 PRINT : PRINT "GAME WILL START SHORTLY..." +410 L=0 : FOR I=1 TO 4 +420 FOR J=1 TO 13 +430 L=L+1 +440 S(L)=I +450 V(L)=J +460 NEXT J +470 NEXT I +480 N1=0 +490 N2=0 +500 N3=0 +510 S1=0 +520 S2=0 +530 FOR I=1 TO 52 +540 G(I)=0 +550 H(I)=0 +560 A(I)=RND(1) +570 NEXT I +580 W1=0 +590 B1=0 +600 P1=1 +610 P2=1 +620 J=0 +630 M1=99999! +640 FOR I=1 TO 52 +650 IF A(I)>=M1 THEN 680 +660 M1=A(I) +670 I1=I +680 NEXT I +690 J=J+1 +700 D(J)=I1 +710 A(I1)=99999! +720 IF J<52 THEN 630 +730 FOR I=1 TO 7 +740 G(D(52-2*I+2))=1 +750 H(D(52-2*I+1))=1 +760 NEXT I +770 T(1)=D(38) +780 T1=1 +790 P=S(T(1)) +800 H1=7 +810 H2=7 +820 D1=37 +830 GOSUB 1390 +840 GOSUB 1510 +850 IF W1=1 THEN 910 +860 IF B1=1 THEN 910 +870 GOSUB 2020 +880 IF W1=1 THEN 910 +890 IF B1=1 THEN 910 +900 GOTO 830 +910 GOSUB 1140 +920 PRINT "YOUR SCORE IS";C1 +930 PRINT "MY SCORE IS";C2 +940 IF C2>=C1 THEN 980 +950 PRINT "YOU WON THAT HAND." +960 N1=N1+1 +970 GOTO 1000 +980 PRINT "I WON THAT HAND." +990 N2=N2+1 +1000 PRINT +1010 N3=N3+1 +1020 PRINT "DO YOU WISH TO PLAY AGAIN"; +1030 INPUT A$ +1040 IF A$="YES" OR A$="Y" THEN 530 +1050 PRINT +1060 PRINT "OUT OF";N3;"HANDS YOU WON";N1 +1070 PRINT "YOUR TOTAL SCORE IS";S1;": MINE IS";S2;"." +1080 IF S1<=S2 THEN1110 +1090 PRINT "LOOKS LIKE YOU'RE HIGH SCORER." +1100 GOTO 1120 +1110 PRINT "LOOKS LIKE I AM THE HIGH SCORER." +1120 PRINT "BYE." +1130 STOP +1140 C1=0 +1150 C2=0 +1160 IF H2=0 THEN 1240 +1170 PRINT +1180 PRINT "CARDS LEFT IN MY HAND" +1190 FOR I=1 TO 52 +1200 IF H(I)=0 THEN 1230 +1210 PRINT C$(V(I));TAB(6);"OF ";U$(S(I)) +1220 C1=C1+Z(I) +1230 NEXT I +1240 IF H1=0 THEN 1360 +1250 FOR I=1 TO 52 +1260 IF G(I)=0 THEN 1280 +1270 C2=C2+Z(I) +1280 NEXT I +1290 IF C1=0 THEN 1360 +1300 IF C1>=C2 THEN 1340 +1310 C2=C2-C1 +1320 C1=0 +1330 GOTO 1360 +1340 C1=C1-C2 +1350 C2=0 +1360 S1=S1+C1 +1370 S2=S2+C2 +1380 RETURN +1390 PRINT +1400 PRINT "YOUR HAND IS" +1410 FOR I=1 TO 52 +1420 IF G(I)=0 THEN 1440 +1430 PRINT C$(V(I));TAB(6);"OF ";U$(S(I)) +1440 NEXT I +1450 PRINT +1460 PRINT "THE LAST CARD PLAYED WAS THE "; +1470 PRINT C$(V(T(T1)));" OF ";U$(S(T(T1))) +1480 IF V(T(T1))<>7 THEN 1500 +1490 PRINT "THE SUIT CALLED FOR IS ";U$(P) +1500 RETURN +1510 PRINT "DO YOU WISH TO PLAY A CARD"; +1520 INPUT A$ +1530 AZ$=LEFT$(A$,1) +1531 IF AZ$<>"Y" AND AZ$<>"N" THEN PRINT "(Y OR N) PLEASE ! "; : GOTO 1520 +1540 IF D1<>0 THEN 1570 +1550 PRINT "ALL THE CARDS HAVE BEEN DEALT---YOU ARE BLOCKED" +1560 GOTO 1980 +1570 I=D(D1) +1580 D1=D1-1 +1590 H1=H1+1 +1600 G(I)=1 +1610 PRINT "YOUR NEW CARD IS THE ";C$(V(I));" OF ";U$(S(I)) +1620 GOTO 1510 +1630 PRINT "WHICH OF YOUR CARDS DO YOU WISH TO PLAY"; +1640 INPUT X$,Y$ +1650 GOSUB 2610 +1660 IF V9>0 THEN 1680 ELSE PRINT "UNKNOWN CARD, TRY AGAIN"; +1670 GOTO 1640 +1680 GOSUB 2500 +1690 IF S9>0 THEN 1710 ELSE PRINT "UNKNOWN SUIT, TRY AGAIN"; +1700 GOTO 1640 +1710 IF V9=7 THEN 1760 +1720 IF S9=P THEN 1760 +1730 IF V9=V(T(T1)) THEN 1760 +1740 PRINT "THAT IS NOT A LEGAL PLAY." +1750 GOTO 1510 +1760 FOR I=1 TO 52 +1770 IF G(I)=0 THEN 1800 +1780 IF V(I)<>V9 THEN 1800 +1790 IF S(I)=S9 THEN 1830 +1800 NEXT I +1810 PRINT "YOU DO NOT HAVE THAT CARD." +1820 GOTO 1510 +1830 G(I)=0 +1840 H1=H1-1 +1850 T1=T1+1 +1860 T(T1)=I +1870 IF V9<>7 THEN 1930 +1880 PRINT "WHAT SUIT DO YOU WISH"; +1890 INPUT Y$ +1900 GOSUB 2500 +1910 IF S9>0 THEN 1930 ELSE PRINT "UNKNOWN SUIT, TRY AGAIN"; +1920 GOTO 1890 +1930 P=S9 +1940 P1=1 +1950 IF H1<>0 THEN 1970 +1960 W1=1 +1970 RETURN +1980 IF P2<>0 THEN 2000 +1990 B1=1 +2000 P1=0 +2010 RETURN +2020 I=53 +2030 I=I-1 +2040 IF H(I)=0 THEN 2080 +2050 IF V(I)=7 THEN 2080 +2060 IF S(I)=P THEN 2220 +2070 IF V(I)=V(T(T1)) THEN 2220 +2080 IF I>1 THEN 2030 +2090 FOR I=1 TO 52 +2100 IF V(I)<>7 THEN 2120 +2110 IF H(I)<>0 THEN 2220 +2120 NEXT I +2130 IF D1=0 THEN 2460 +2140 I=D(D1) +2150 D1=D1-1 +2160 IF V(I)=7 THEN 2240 +2170 IF S(I)=P THEN 2240 +2180 IF V(I)=V(T(T1)) THEN 2240 +2190 H2=H2+1 +2200 H(I)=1 +2210 GOTO 2130 +2220 H(I)=0 +2230 H2=H2-1 +2240 T1=T1+1 +2250 T(T1)=I +2260 P=S(I) +2270 IF V(I)<>7 THEN 2420 +2280 FOR J=1 TO 4 +2290 Y(J)=0 +2300 K1=13*(J-1)+1 +2310 K2=13*J +2320 FOR K=K1 TO K2 +2330 IF H(I)=0 THEN 2350 +2340 Y(J)=Y(J)+1 +2350 NEXT K +2360 NEXT J +2370 P=1 +2380 FOR J=2 TO 4 +2390 IF Y(J)<=Y(P) THEN 2410 +2400 P=J +2410 NEXT J +2420 P2=1 +2430 IF H2<>0 THEN 2450 +2440 W1=1 +2450 RETURN +2460 IF P1<>0 THEN 2480 +2470 B1=1 +2480 P2=0 +2490 RETURN +2500 FOR I0 = 1 TO 4 +2510 IF Y$=U$(I0) THEN 2590 +2520 NEXT I0 +2530 S9 = 0 +2540 IF Y$="C" THEN S9=1 +2550 IF Y$="D" THEN S9=2 +2560 IF Y$="H" THEN S9=3 +2570 IF Y$="S" THEN S9=4 +2580 RETURN +2590 S9 = I0 +2600 RETURN +2610 FOR I0 = 1 TO 13 +2620 IF X$=C$(I0) THEN 2700 +2630 NEXT I0 +2640 V9 = 0 +2650 IF X$="J" THEN V9=10 +2660 IF X$="Q" THEN V9=11 +2670 IF X$="K" THEN V9=12 +2680 IF X$="A" THEN V9=13 +2690 RETURN +2700 V9 = I0 +2710 RETURN +2720 END +THEN V9=11 +2670 IF X$="K" THEN V9=12 +2680 IF X$="A" \ No newline at end of file diff --git a/disks/images/b/CRUN2.COM b/disks/images/b/CRUN2.COM new file mode 100644 index 0000000..1399e69 Binary files /dev/null and b/disks/images/b/CRUN2.COM differ diff --git a/disks/images/b/GALAXY.ASC b/disks/images/b/GALAXY.ASC new file mode 100644 index 0000000..db5101b --- /dev/null +++ b/disks/images/b/GALAXY.ASC @@ -0,0 +1,19 @@ +10 REM << GALAXY >> +20 WIDTH 79 +30 A$="*":B$="+":C$=".":D$="*" +40 FOR I=1 TO 100 +50 GOSUB 90 +60 PRINT TAB(A);A$; TAB(B);B$; TAB(C);C$ +70 NEXT +80 GOTO 40 +90 A=INT(RND(1)*28) : B=INT(RND(1)*25)+28 : C=INT(RND(1)*25)+55 +100 X=RND(1) +110 IF X<.15 THEN SWAP A$,B$ : GOTO 170 +120 IF X<.3 THEN SWAP B$,C$ : GOTO 170 +130 IF X<.45 THEN SWAP A$,C$ : GOTO 170 +140 IF X<.6 THEN SWAP A$,D$ : GOTO 170 +150 IF X<.75 THEN SWAP B$,D$ : GOTO 170 +160 IF X<.9 THEN SWAP C$,D$ +170 RETURN +170 +140 IF X<.6 THEN SWAP \ No newline at end of file diff --git a/disks/images/b/GALAXY2.ASC b/disks/images/b/GALAXY2.ASC new file mode 100644 index 0000000..79686b2 --- /dev/null +++ b/disks/images/b/GALAXY2.ASC @@ -0,0 +1,48 @@ +100 REM << GALAXY >> +101 WIDTH 79 +102 DIM G$(15) +103 FOR X=1 TO 15 : READ G$(X) : NEXT +104 A$="*":B$="+":C$=".":D$="*" +105 FOR I=1 TO 40 +106 GOSUB 113 +107 PRINT TAB(A);A$; TAB(B);B$; TAB(C);C$ +108 NEXT +109 Z1=INT(RND(1)*15)+1 +110 Z$=G$(Z1) +111 PRINT TAB(20) Z$ +112 GOTO 105 +113 A=INT(RND(1)*28) : B=INT(RND(1)*25)+28 : C=INT(RND(1)*25)+55 +114 X=RND(1) +115 IF X<.15 THEN SWAP A$,B$ : GOTO 121 +116 IF X<.3 THEN SWAP B$,C$ : GOTO 121 +117 IF X<.45 THEN SWAP A$,C$ : GOTO 121 +118 IF X<.6 THEN SWAP A$,D$ : GOTO 121 +119 IF X<.75 THEN SWAP B$,D$ : GOTO 121 +120 IF X<.9 THEN SWAP C$,D$ +121 RETURN +122 DATA YOU ARE A TRAVELLER LOST IN SPACE +123 DATA I AM BUT A TRAVELLER LOST IN SPACE +124 DATA ALL MANKIND BUT EXPLORERS LOST IN SPACE +125 DATA CAN WE FIND EACH OTHER IN SPACE ? +126 DATA HOW DOES LIFE SEEM FROM UP THERE ? +127 DATA I CAN SEE YOU CLEARLY NOW FROM HERE +128 DATA THE YEARS SEEM TO PASS SO QUICKLY +129 DATA WE'LL MEET HERE IN A MILLION YEARS +130 DATA GREETINGS FROM WHERE THE RATS CRAWL +131 DATA GREETINGS FROM THE CRACKS IN THE WALL +132 DATA I SEE ALL THAT YOU EVER ARE DOING +133 DATA THE SKY IS FALLING ON US ALL !!! +134 DATA I'M AFRAID THAT THE END IS COMING +135 DATA IN WHICH REMOTE PLACE CAN GOD BE MET ? +136 DATA WE'LL MEET AGAIN DON'T KNOW WHERE OR WHEN +137 DATA TIME RUNS QUITE SHORT FOR YOU AND ME +138 DATA YOU GROW OLD AT THE SPEED OF LIGHT +139 DATA HAVE YOU MADE PEACE WITH YOUR MAKER ? +140 DATA HAVE YOU EXISTED AS A GIVER OR A TAKER ? +141 DATA WILL YOU BE ABLE TO MEET ME OUT HERE ? +142 DATA REMEMBER ALL THE GREAT TIMES WE HAD ? +143 DATA WE SHALL NEVER LEAVE THIS PLACE TILL WE DIE +144 DATA ETERNAL ENERGY BEYOND THE DREAMS OF MAN +145 DATA SOME PEOPLE WILL ALWAYS BE FREE FOREVER +146 DATA SOME PEOPLE WILL NEVER TASTE FREEDOM + \ No newline at end of file diff --git a/disks/images/b/LIB.COM b/disks/images/b/LIB.COM new file mode 100644 index 0000000..21be8c1 Binary files /dev/null and b/disks/images/b/LIB.COM differ diff --git a/disks/images/b/LINK.COM b/disks/images/b/LINK.COM new file mode 100644 index 0000000..fe55743 Binary files /dev/null and b/disks/images/b/LINK.COM differ diff --git a/disks/images/b/LK80.COM b/disks/images/b/LK80.COM new file mode 100644 index 0000000..5f2ee79 Binary files /dev/null and b/disks/images/b/LK80.COM differ diff --git a/disks/images/b/MBASIC.COM b/disks/images/b/MBASIC.COM new file mode 100644 index 0000000..a3a50d3 Binary files /dev/null and b/disks/images/b/MBASIC.COM differ diff --git a/disks/images/b/SQUARE.ASC b/disks/images/b/SQUARE.ASC new file mode 100644 index 0000000..5b29680 --- /dev/null +++ b/disks/images/b/SQUARE.ASC @@ -0,0 +1,200 @@ +100 REM ** SQUARE ** +110 REM +120 REM WRITTEN BY MAC OGLESBY +130 REM AS DESCRIBED IN VOL. 1, ISSUE 3 +140 REM OF CALCULATORS-COMPUTERS MAGAZINE +150 REM +160 CS$=CHR$(126)+CHR$(28) 'CURSOR CONTROL CODES TO CLEAR SCREEN +170 DEFINT A-Z +180 PRINTCS$;"ENTER PASSWORD";:INPUTA$:Z=0 +190 A=0:FORI=1TOLEN(A$):A=A+ASC(MID$(A$,I,1)):NEXT:A=RND(-A) +200 DIM Q(50),S$(50),S(24,12),U(12),V(50) +210 P$(1)="X":P$(2)="O":F=1 +220 FOR R0=0 TO 4:FOR C0=0 TO 4:D$(R0,C0)=".":NEXTC0:NEXTR0 +230 INPUT"WANT INSTRUCTIONS FOR 'SQUARE'";A$ +240 IFLEFT$(A$,1)="N"THEN400 +250 PRINTCS$; 'CLEAR SCREEN +260 PRINT" THE GAME OF SQUARE IS FOR 1 OR 2 PLAYERS. THE NORMAL" +270 PRINT"BOARD LOOKS LIKE THIS AT THE START:":GOSUB2000 +280 PRINT" THE PLAYERS GO IN TURN AND CHOOSE ANY UNOCCUPIED POINT" +290 PRINT"(SHOWN AS A DOT). EACH PLAYER HAS 12 MARKERS (X'S OR O'S)" +300 PRINT"WHICH ARE USED TO IDENTIFY CHOSEN POINTS.":PRINT +310 INPUT" ENTER 'C' TO CONTINUE";A$:PRINT +320 PRINT" THE WINNER IS THE FIRST PLAYER WHO HAS CHOSEN 4 POINTS" +330 PRINT"WHICH FORM THE CORNERS OF A SQUARE." +340 PRINT" TO CHOOSE A POINT, TYPE 2 DIGITS (0 TO 4) SEPARATED BY A" +350 PRINT"COMMA. THE FIRST DIGIT TELLS THE DISTANCE OVER (TO T"; +360 PRINT"HE RIGHT)":PRINT"FROM POINT 0,0 (THE ORIGIN). THE SECOND"; +370 PRINT" DIGIT TELLS THE DISTANCE UP.":PRINT +380 PRINT"REMEMBER: OVER,UP.":PRINT +390 INPUT" ENTER 'C' TO CONTINUE";A$:PRINT +400 PRINT:INPUT"DO YOU WANT TO PLAY THE EXPERTS' GAME";A$ +410 B0=1:IFLEFT$(A$,1)="Y"THENB0=2 +420 IFB0=1THEN440 +430 D$(2,2)=" ":N=38:GOTO450 +440 N=50 +450 IFZ=1THENGOTO490ELSEPRINT:INPUT"HOW MANY PLAYERS (1 OR 2)";P0 +460 IFP0=2THEN510 +470 IF P0=1THEN480ELSEPRINT"PLEASE ENTER 1 OR 2":GOTO450 +480 PRINTCS$;"OK, I WILL PLAY THE X'S":PRINT +490 INPUT"DO YOU WANT TO GO FIRST";A$:F=1 +500 IFLEFT$(A$,1)="Y"THENF=2 +510 PRINTCS$;"OK...HERE WE GO..." +520 IFZ=1THEN940 +530 RESTORE:FORJ=0TO24:READS(J,0):NEXT +540 DATA 4,7,8,7,4,7,10,11,10,7,8,11,12,11,8,7,10,11,10,7,4,7,8,7,4 +550 FORJ=0TO24:FORK=1TOS(J,0):READS(J,K):NEXTK:NEXTJ +560 DATA 1,13,35,43 +570 DATA 1,2,15,20,28,31,36 +580 DATA 2,3,21,24,29,43,44,47 +590 DATA 3,4,16,25,30,31,35 +600 DATA 4,13,36,44 +610 DATA 1,5,15,24,30,32,37 +620 DATA 1,2,5,14,22,25,38,39,47,48 +630 DATA 2,3,15,16,17,23,26,32,33,39,40 +640 DATA 3,4,6,14,20,27,37,40,47,49 +650 DATA 4,6,16,21,28,33,38 +660 DATA 5,7,20,26,29,43,45,48 +670 DATA 5,7,15,17,18,21,27,31,34,39,41 +680 DATA 39,40,41,42,43,44,45,46,47,48,49,50 +690 DATA 6,8,16,17,19,22,24,31,34,40,42 +700 DATA 6,8,23,25,29,44,46,49 +710 DATA 7,9,18,22,28,32,35 +720 DATA 7,9,10,14,23,24,36,41,48,50 +730 DATA 10,11,17,18,19,20,25,32,33,41,42 +740 DATA 8,11,12,14,21,26,35,42,49,50 +750 DATA 8,12,19,27,30,33,36 +760 DATA 9,13,37,45 +770 DATA 9,10,18,26,30,34,38 +780 DATA 10,11,22,27,29,45,46,50 +790 DATA 11,12,19,23,28,34,37 +800 DATA 12,13,38,46 +810 FORJ=1TON:READS$(J):NEXT +820 DATA 00011110,01021211,02031312,03041413,10112120 +830 DATA 13142423,20213130,23243433,30314140,31324241 +840 DATA 32334342,33344443,00044440,11133331 +850 DATA 01122110,03142312,12233221,21324130,23344332 +860 DATA 01133220,02143321,11234230,12244331 +870 DATA 02233110,03243211,12334120,13344221 +880 DATA 01144330,02244220,03344110 +890 DATA 01032321,10123230,12143432,21234341 +900 DATA 00033330,01043431,10134340,11144441 +910 DATA 11122221,12132322,21223231,22233332 +920 DATA 00022220,02042422,20224240,22244442 +930 DATA 02132211,11223120,13243322,22334231 +940 IFA(1)<>89THEN960 +950 IFB0=2THEN960ELSEPRINT:GOTO970 +960 GOSUB2000 +970 T=T+1 +980 REM ** MAIN MOVE LOOP: J=121212... OR J=212121... +990 FORJ=FTO3-FSTEP3-2*F +1000 IFP0=2THEN1730 +1010 IFJ=2THEN1730 +1020 REM ** GENERATE COMPUTER'S MOVE +1030 IFT<>1THEN1100 +1040 IFD$(2,2)<>"."THEN1060 +1050 R1=2:C1=2:GOTO1710 +1060 IFF=1THEN1080 +1070 Q0=9:GOTO1130 +1080 R1=1+INT(RND(1)*3):C1=1+INT(RND(1)*3) +1090 IFD$(R1,C1)<>"."THENGOTO1080ELSEGOTO1710 +1100 IFT<>2THEN1380 +1110 IFF=1THEN1130 +1120 Q0=19 +1130 K9=0 +1140 FORJ1=1TON:IFQ(J1)<>1+Q0THEN1160 +1150 K9=K9+1:U(K9)=J1 +1160 NEXTJ1 +1170 IFK9=0THEN1370 +1180 FORJ2=K9TO1STEP-1:T9=1+INT(RND(1)*J2):J1=U(T9) +1190 FORK1=1TO8STEP2:R1=VAL(MID$(S$(J1),K1,1)) +1200 C1=VAL(MID$(S$(J1),K1+1,1)) +1210 IFD$(R1,C1)<>"."THEN1320 +1220 IFQ0+T<3THEN1240 +1230 GOTO1710 +1240 S0=5*R1+C1:M0=0:FORJ3=1TOS(S0,0) +1250 IFB0=1THEN1280 +1260 IFS(S0,J3)<=38THEN1280 +1270 GOTO1310 +1280 IFQ(S(S0,J3))>1THEN1300 +1290 M0=M0+1 +1300 NEXTJ3 +1310 IFM0<8-B0THENGOTO1320ELSEGOTO1710 +1320 NEXTK1 +1330 IFJ2=T9THEN1350 +1340 T8=U(J2):U(J2)=U(T9):U(T9)=T8 +1350 NEXTJ2 +1360 REM *** AS A LAST RESORT, PICK ANY VACANT POINT +1370 R1=RND(1)*5:C1=RND(1)*5:IFD$(R1,C1)<>"."THENGOTO1370ELSEGOTO1710 +1380 IFT=3THEN1430 +1390 REM ** SEE IF 'X' CAN COMPLETE A SQUARE +1400 FORJ1=1TON:IFQ(J1)<>3THENGOTO1410ELSEGOTO1190 +1410 NEXTJ1 +1420 REM ** SEE IF 'O' CAN COMPLETE A SQUARE +1430 FORJ1=1TON:IFQ(J1)<>30THENGOTO1440ELSEGOTO1190 +1440 NEXTJ1 +1450 REM ** CAN 'X' CHOOSE A 3RD CORNER? +1460 K9=0:FORJ1=1TON:IFQ(J1)<>2THEN1480 +1470 K9=K9+1:U(K9)=J1 +1480 NEXTJ1 +1490 IFK9=0THEN1700 +1500 FORI0=1TO2:FORJ0=K9TO1STEP-1:M9=1+INT(RND(1)*J0):J1=U(M9):T9=0 +1510 FORK1=1TO8STEP2:R1=VAL(MID$(S$(J1),K1,1)) +1520 C1=VAL(MID$(S$(J1),K1+1,1)):IFD$(R1,C1)<>"."THEN1540 +1530 T9=T9+1:R(T9)=R1:C(T9)=C1 +1540 NEXTK1 +1550 FORJ2=1TO2:FORJ3=1TO50:V(J3)=Q(J3):NEXTJ3:S0=5*R(J2)+C(J2) +1560 FORJ3=1TOS(S0,0):V(S(S0,J3))=V(S(S0,J3))+1:NEXTJ3 +1570 S0=5*R(3-J2)+C(3-J2) +1580 FORJ3=1TOS(S0,0):V(S(S0,J3))=V(S(S0,J3))+10:NEXTJ3 +1590 FORJ3=1TON:IFV(J3)<>4-I0THEN1610 +1600 R1=R(J2):C1=C(J2):GOTO1710 +1610 NEXTJ3 +1620 NEXTJ2 +1630 IFJ0=M9THEN1650 +1640 T8=U(J0):U(J0)=U(M9):U(M9)=T8 +1650 NEXTJ0 +1660 NEXTI0 +1670 REM ** NO GOOD MOVE AVAILABLE...PICK ANY 3RD CORNER +1680 J1=U(1+INT(RND(1)*K9)):GOTO1190 +1690 REM ** SEE IF WE CAN ANNOY THE HUMAN +1700 Q0=I9:GOTO1130 +1710 PRINT"THE ";P$(J);"'S MOVE TO ";STR$(C1);",";STR$(R1):GOTO1780 +1720 REM ** GET PLAYER'S CHOICE +1730 IFT>1THEN1750 +1740 PRINT"THE ";P$(J);"'S MOVE TO WHICH POINT";:GOTO1760 +1750 PRINTP$(J);"'S CHOICE"; +1760 INPUTC1,R1 +1770 IFD$(R1,C1)<>"."THEN1850 +1780 D$(R1,C1)=P$(J) +1790 REM ** Q() TELLS WHO OWNS CORNERS OF WHICH SQUARES +1800 S0=5*R1+C1:FORJ1=1TOS(S0,0):Q(S(S0,J1))=Q(S(S0,J1))+1+(J-1)*9 +1810 IFQ(S(S0,J1))<>4+(J-1)*36THEN1830 +1820 PRINT:PRINT"*** THE ";P$(J);"'S WIN!! ***":GOTO1910 +1830 NEXTJ1 +1840 GOTO1880 +1850 PRINT"** ILLEGAL POINT! **":GOTO1870 +1860 PRINT"YOU MUST TYPE 2 DIGITS (0 TO 4) SEPARATED BY A COMMA!" +1870 PRINT"** INPUT IGNORED! PLEASE TRY AGAIN...":GOTO1750 +1880 NEXTJ +1890 IFT<12THEN1970 +1900 PRINT:PRINT"THE GAME IS A DRAW; NEITHER PLAYER MADE A SQUARE!" +1910 FORK1=1TO8STEP2:R1=VAL(MID$(S$(S(S0,J1)),K1,1)) +1920 C1=VAL(MID$(S$(S(S0,J1)),K1+1,1)):D$(R1,C1)=CHR$(64):NEXT:GOSUB2000 +1930 INPUT"WANT TO PLAY AGAIN";A$:IFLEFT$(A$,1)<>"Y"THENEND +1940 Z=1:FORJ2=0TO4:FORJ3=0TO4:D$(J2,J3)=".":NEXTJ3:NEXTJ2 +1950 FORJ2=1TO50:Q(J2)=0:V(J2)=0:NEXTJ2:FORJ2=1TO12:U(J2)=0:NEXTJ2 +1960 T=0:K9=0:GOTO400 +1970 GOSUB2000 +1980 GOTO970 +1990 REM ** PRINT THE BOARD +2000 PRINT:FORR0=4TO0STEP-1:PRINTSTR$(R0);" "; +2010 FORC0=0TO4:PRINTD$(R0,C0);:IFC0=4THEN2030 +2020 PRINT" "; +2030 NEXTC0:PRINT:IFR0=0THEN2050 +2040 PRINT:PRINT +2050 NEXTR0:PRINT:PRINT" 0 1 2 3 4":PRINT:RETURN +2060 END + NEXTC0:PRINT:IFR0=0THEN2050 +2040 PRINT:PRINT +2050 NEXTR0:PRINT:PRINT" 0 1 2 3 4":PRINT \ No newline at end of file diff --git a/disks/images/b/STARTREK.TXT b/disks/images/b/STARTREK.TXT new file mode 100644 index 0000000..2eceb36 --- /dev/null +++ b/disks/images/b/STARTREK.TXT @@ -0,0 +1,1614 @@ +1 REM *** SUPER STAR TREK *** +2 REM INTELLEC MDS VERSION +3 REM WRITTEN IN BASIC BY RON WILLIAMS +4 REM INTEL CORP. - 5/15/76 +5 REM ADAPTED FROM A FORTRAN VERSION WRITTEN +6 REM FOR THE CDC 6600 IN 1974. +7 DIM G1$(16),V$(5,5),C$(20),G(8,8),D$(12),Q$(10,10),D4(12),D9(106) +10 DIM S2(8,8):Q$="?" +15 DATA S.R. SENSORS,L.R. SENSORS,PHASERS,PHOTON TUBES,LIFE SUPPORT +20 DATA WARP ENGINES,IMPULSE ENGINES,SHIELDS,SUBSPACE RADIO +21 DATA SHUTTLE CRAFT,COMPUTER,TRANSFER PANEL,ABANDON,CHART,COMPUTER +22 DATA DAMAGES,DESTRUCT,DOCK,IDLE,IMPULSE,LRSCAN,NAVIGATE,PHASERS,QUIT +23 DATA SHIELDS,SOS,SRSCAN,STATUS,TORPEDO,TRANSFER,VISUAL,WARP,SHORT +24 DATA MEDIUM,LONG,BEGINNER,NOVICE,SENIOR,EXPERT,COURSE,WCOST,ICOST +25 DATA PEFFECT,SCORE,END,ANTARES,SIRIUS,RIGEL,MERAK,PROCYON,CAPELLA +26 DATA VEGA,DENEB,CANOPUS,ALDEBARAN,ALTAIR,REGULUS,BELLATRIX,ARCTURUS +27 DATA POLLUX,SPICA,10.5,12,1.5,9,0,3,7.5,6,4.5 +28 DEF FNA(X)=INT(8*RND(X))+1:DEF FNB(X)=INT(10*RND(X))+1 +29 DEF FND(X)=X/60 +30 DEFFNR(X)=INT(X*10+.5)/10:DEFFNS(X)=INT(X*100+.5)/100 +40 FORI=1TO12:READD$(I):NEXT:FORI=1TO20:READC$(I):NEXT +43 FORI=1TO3:READT$(I):NEXT:FORI=1TO4:READS$(I):NEXT:FORI=1TO6 +44 READC2$(I):NEXT:FORI=1TO16:READG1$(I):NEXT:FORI=1TO9:READC5(I):NEXT +45 REM CALL SETUP +46 GOSUB24000:S7$(1)="":S7$(2)=" ":S7$(3)=" ":S7$(4)="" +70 IFA2<>0THEN900 +75 J4=0:T1=0:PRINT:INPUT"COMMAND";A$:IFLEN(A$)>1THEN110 +80 PRINT"USE AT LEAST 2 LETTERS, PLEASE.":GOTO75 +110 FORI=1TO20 +120 IFA$=LEFT$(C$(I),LEN(A$))THEN150 +130 NEXT +135 INPUT"ILLEGAL COMMAND - DO YOU NEED A LIST";B$ +136 IFLEFT$(B$,1)="N" THEN70 +140 PRINT:FORI=1TO20STEP4 +141 PRINTC$(I);TAB(12);C$(I+1);TAB(22);C$(I+2);TAB(32);C$(I+3) +142 NEXT:PRINT:GOTO70 +150 ONIGOTO200,225,250,275,290,300,325,350,375,400 +160 ONI-10GOTO425,450,475,500,525,540,550,575,600,625 +170 PRINT"ERROR AT 170 - SHOULD NOT BE HERE" +180 STOP +200 REM-ABANDON +201 GOSUB 35000 +210 GOTO70 +225 REM-CHART +226 GOSUB 3000 +230 GOTO70 +250 REM-COMPUTER +251 GOSUB5000 +260 GOTO70 +275 REM-DAMAGES +276 GOSUB8000 +280 GOTO70 +290 REM - DESTRUCT +291 GOSUB36000:GOTO70 +300 REM-DOCK +301 GOSUB7000 +310 GOTO70 +325 REM-IOLE +326 GOSUB33000 +330 IFJ3=0THEN70 +331 IFA2<>0THEN900 +332 IFG(Q1,Q2)=1000THEN750 +340 GOSUB1000 +345 GOTO70 +350 REM-IMPULSE +351 GOSUB13000 +352 IFJ3=0THEN70 +353 GOTO700 +375 REM-LRSCAN +376 GOSUB14000 +377 GOTO70 +400 REM-NAVIGATE +401 GOSUB34000 +402 IFJ3=0THEN70 +410 GOTO700 +425 REM-PHASERS +426 GOSUB20000 +427 IFJ3=0THEN70 +428 GOSUB1000 +429 GOTO70 +450 REM-QUIT +455 GOTO900 +460 PRINT"TOO BAD...WE HATE TO LOSE GOOD ASTRONAUTS!" +465 GOTO37010 +475 REM-SHIELDS +476 GOSUB26000 +477 IFJ3=0THEN70 +478 IFA2<>0THEN900 +479 GOSUB1000 +480 S9=0 +485 GOTO70 +500 REM-SOS +501 GOSUB11000 +502 GOTO70 +525 REM-SRSCAN +526 GOSUB29000 +530 GOTO70 +540 REM - STATUS +541 PRINT +545 GOSUB37000:GOTO70 +550 REM-TORPEDOS +551 GOSUB21000 +552 IFJ3=0THEN70 +555 GOTO700 +575 REM-TRANSFER +576 GOSUB31000 +580 IFJ3=0THEN70 +585 IFA2<>0THEN900 +590 IFG(Q1,Q2)<>1000THEN70 +595 GOTO750 +600 REM-VISUAL +601 GOSUB32000 +602 IFJ3=0THEN70 +603 IFA2<>0THEN900 +610 IFG(Q1,Q2)<>1000THEN70 +615 GOTO750 +625 REM-WARP +627 GOSUB25000 +630 GOTO70 +700 REM-AFTERMOVINGSTARSHIP +710 IFA2<>0THEN900 +720 IFT1<>0THENGOSUB9000 +730 IFA2<>0THEN900 +740 IFG(Q1,Q2)<1000THEN790 +750 GOSUB2000 +760 IFA2<>0THEN900 +770 GOTO740 +790 GOSUB1000 +795 GOTO70 +900 REM-WE'RE FINISHED +901 PRINT:PRINT:INPUT"WOULD YOU LIKE TO TRY AGAIN";A$ +910 IFLEFT$(A$,1)="Y"THEN45 +920 GOTO460 +940 REM-BEGINSUBROUTINES +1000 REM-ATTACK +1010 IF(C3<>0)AND(J4=0)THENGOSUB16000 +1020 IFK3=0THENRETURN +1030 IFA2<>0THENRETURN +1040 P2=1/I8 +1050 J5=0 +1060 PRINT +1070 IFC5$="DOCKED"THEN1780 +1080 H2=0:H3=0:C6=1 +1090 IFS9=1THENC6=.5+.5*RND(1) +1100 A3=0 +1110 FORL=1TOK3 +1120 IFK6(L)<0THEN1540 +1130 A3=1 +1140 D6=.8+.05*RND(1) +1150 H4=K6(L)*D6^K8(L) +1160 IF(S4=0)AND(S9=0)THEN1230 +1170 P3=.1:IFP2*S3>P3THENP3=P2*S3 +1180 H5=P3*C6*H4+1 +1190 IFH5>S3THENH5=S3 +1195 S3=S3-H5 +1200 H4=H4-H5 +1210 IF(P3>.1)AND(H4<.005*E1)THEN1540 +1230 J5=1 +1240 PRINTFNR(H4);"UNIT HIT ON THE ";S5$;" FROM "; +1250 J6=K4(L):J7=K5(L) +1260 IFQ$(J6,J7)="K"THENPRINT"KLINGON AT"; +1270 IFQ$(J6,J7)="C"THENPRINT"COMMANDER AT"; +1280 PRINTJ6;"-";J7 +1290 IFH4>H2THENH2=H4 +1300 H3=H3+H4 +1310 IFH4<(275-25*S8)*(1+.5*RND(1))THEN1530 +1320 N4=1+INT(H4/(500+100*RND(1))) +1330 PRINT"***CRITICAL HIT--"; +1340 K9=1 +1350 FORW4=1TON4 +1360 J9=INT(12*RND(1))+1 +1370 C5(W4)=J9 +1380 E3=(H4*D5)/(N4*(75+25*RND(1))) +1390 IFJ9=6THENE3=E3/3 +1395 D4(J9)=D4(J9)+E3 +1400 IFW4=1THEN1470 +1420 FORV=1TOW4 +1430 IFJ9=C5(V-1)THEN1480 +1440 NEXTV +1450 K9=K9+1 +1460 IFK9=3THENPRINT +1465 PRINT " AND "; +1470 PRINTD$(J9); +1480 NEXTW4 +1490 PRINT " DAMAGED." +1500 IFD4(8)=0THEN1530 +1510 IFS4<>0THENPRINT"*** SHIELDS KNOCKED DOWN." +1520 S4=0 +1530 E1=E1-H4 +1540 NEXTL +1550 IFA3=0THENRETURN +1560 IFE1<=0THEN1750 +1570 P4=100*P2*S3+.5 +1580 IFJ5<>0THEN1610 +1590 PRINT"KLINGONS ATTACK--SHIELD STRENGTH REDUCED TO "; +1600 GOTO1650 +1610 PRINT"ENERGY LEFT:";FNS(E1);" SHIELDS "; +1620 IFS4<>0THENPRINT"UP,"; +1630 IF(S4=0)AND(D4(8)=0)THENPRINT"DOWN, "; +1640 IFD4(8)>0THENPRINT"DAMAGED, "; +1650 PRINTINT(P4);"%" +1660 IF(H2<200)AND(H3<500)THEN1800 +1670 J8=INT(H3*RND(1)*.015) +1680 IFJ8<2THEN1800 +1690 PRINT +1700 PRINT"MCCOY - 'SICKBAY TO BRIDGE. WE SUFFERED "; +1710 PRINTJ8;"CASUALTIES" +1720 PRINT" IN THAT LAST ATTACK'" +1730 C4=C4+J8 +1740 GOTO1800 +1750 F9=5 +1760 GOSUB10000 +1770 RETURN +1780 PRINT"*** KLINGONS ATTACK-- STARBASE SHIELDS PROTECT "; +1790 PRINT"THE ";S5$ +1800 FORW4=1TOK3 +1810 K8(W4)=K7(W4) +1820 NEXTW4 +1830 GOSUB28000 +1840 RETURN +2000 REM-AUTOVER +2001 PRINT +2010 IFJ4=0THEN2050 +2020 PRINT"*** RED ALERT! RED ALERT!" +2030 PRINT"***THE ";S5$;" HAS STOPPED IN A QUADRANT "; +2040 PRINT "CONTAINING A SUPERNOVA." +2050 PRINT "*** EMERGENCY AUTO-OVERRIDE ATTEMPTS TO HURL "; +2060 PRINTS5$ +2070 PRINT" SAFELY OUT OF THE QUADRANT." +2080 S2(Q1,Q2)=1 +2090 GOSUB18000 +2100 IFD4(6)=0THEN2290 +2110 PRINT +2120 PRINT"WARP ENGINES DAMAGED." +2130 PRINT +2140 PRINT"ATTEMPTING TO ENGAGE IMPULSE ENGINES..." +2150 IFD4(7)=0THEN2190 +2160 PRINT"IMPULSE ENGINES DAMAGED." +2165 F9=8 +2170 GOSUB10000 +2180 RETURN +2190 P2=.75*E1 +2200 D6=.004*(P2-50) +2210 D7=1.4142+1.2*RND(1) +2220 D1=D6 +2230 IFD6>D7THEND1=D7 +2240 T1=D1/.4 +2250 D2=12*RND(1) +2260 J4=0 +2270 GOSUB13200 +2280 GOTO2400 +2290 W1=6+2*RND(1) +2300 W2=W1*W1 +2310 P2=.75*E1 +2320 D6=P2/(W1*W1*W1*(S4+1)) +2330 D7=1.4142+2*RND(1) +2340 D1=D6 +2350 IFD6>D7THEND1=D7 +2360 T1=10*D1/W2 +2370 D2=12*RND(1) +2380 J4=0 +2390 GOSUB34500 +2400 IFJ4<>0THEN2440 +2410 F9=8 +2420 GOSUB10000 +2430 RETURN +2440 IFR1<>0THENRETURN +2450 F9=1 +2460 GOSUB10000 +2470 RETURN +3000 REM-CHART +3001 PRINT:PRINT" 1 2 3 4 5 6 7 8" +3010 PRINT" --- --- --- --- --- --- --- ---" +3020 FORI=1TO8 +3030 PRINTI;" "; +3040 FORJ=1TO8 +3060 ONSGN(S2(I,J))+2GOTO3070,3090,3110 +3065 PRINT"ERR AT 3065":STOP +3070 PRINT" .1."; +3080 GOTO 3160 +3090 PRINT" ..."; +3100 GOTO3160 +3110 IFS2(I,J)>1000THEN3150 +3120 IFG(I,J)<1000THENPRINTS7$(LEN(STR$(G(I,J))));STR$(G(I,J)); +3130 IFG(I,J)=1000THENPRINT" ***"; +3140 GOTO3160 +3150 PRINTS2(I,J)-1000; +3160 NEXTJ +3170 PRINT +3180 NEXTI:GOSUB18400 +3185 PRINT +3190 PRINT"THE ";S5$;" IS CURRENTLY IN ";G2$;" (";Q1;"-";Q2;")" +3200 RETURN +4000 REM-CHOOSE +4001 FORI=1TO10:PRINT:NEXT:FORI=1TO41:PRINT"*";:NEXT:PRINT +4002 PRINT"**";TAB(39);"**" +4003 PRINT"** WELCOME TO THE WORLD OF STAR TREK **" +4008 PRINT"**";TAB(39);"**":FORI=1TO41:PRINT"*";:NEXT:PRINT +4010 PRINT:PRINT +4070 S8=0:L2=0 +4090 PRINT"HOW LONG A GAME WOULD YOU LIKE"; +4095 INPUTA$ +4100 FOR I=1TO3 +4110 IFA$=LEFT$(T$(I),LEN(A$))THEN4150 +4120 NEXTI +4130 PRINT"WOULD YOU LIKE A SHORT, MEDIUM OR LONG GAME"; +4140 GOTO4095 +4150 L2=I +4160 PRINT"ARE YOU A BEGINNER, NOVICE, SENIOR OR EXPERT PLAYER"; +4170 INPUTA$ +4180 FORI=1TO4 +4190 IFA$=LEFT$(S$(I),LEN(A$))THEN4220 +4200 NEXTI +4210 GOTO4160 +4220 S8=I +4230 INPUT"ENTER YOUR MISSION PASSWORD...";X$ +4244 PRINT +4245 PRINT"....SETTING UP THE GALAXY...." +4250 J=RND(1) +4260 REM-INITIALIZE +4270 D5=.5*S8 +4280 I2=INT(L2+1+RND(1)*3) +4290 IFI2>5THENI2=5 +4300 R3=I2 +4310 I5=7*L2 +4320 R5=I5 +4340 R7=(S8-2*RND(1)+1)*S8*.1+.1 +4350 IFR7<.2THENR7=R7+.1 +4360 I1=INT(2*R7*I5) +4370 R1=I1 +4380 I4=INT(S8+.0625*I1*RND(1)) +4390 R2=I4 +4400 I3=(I1+4*I4)*I5 +4410 R4=I3 +4420 RETURN +5000 REM-COMPUTE +5001 IFD4(11)=0THEN5030 +5010 PRINT"LIBRARY COMPUTER DISABLED" +5020 RETURN +5030 PRINT"----LIBRARY COMPUTER ACTIVE----" +5040 INPUT"PROGRAM NAME";B$ +5050 FORI=1TO6 +5060 IFB$=LEFT$(C2$(I),LEN(B$))THEN5120 +5070 NEXT +5080 PRINT"VALID PROGRAMS ARE:" +5090 PRINT" COURSE WCOST ICOST" +5100 PRINT" PEFFECT SCORE END" +5110 GOTO5040 +5120 ON IGOTO5200,5300,5400,5500,5600,5700 +5200 REM-COURSE&DIRECTION +5210 INPUT "ENTER QUADRANT AND SECTOR - ";A3,A4 +5220 IF(A3<>INT(A3))OR(A4<>INT(A4))THEN5990 +5221 IFA3<0THEN5040 +5222 IFA3=0THENA3=10*Q1+Q2 +5223 A3=A3+.5 +5225 K=INT(A3/10) +5226 IF(K<1)OR(K>8)THEN5990 +5227 C6(1)=K:K=INT(A3-C6(1)*10) +5228 IF(K<1)OR(K>8)THEN5990 +5229 C6(2)=K:A4=A4+.5 +5230 K=INT(A4/100) +5231 IF(K<1)OR(K>10)THEN5990 +5232 C6(1)=C6(1)+(K-1)/10:K=INT(A4-K*100) +5233 IF(K<1)OR(K>10)THEN5990 +5234 C6(2)=C6(2)+(K-1)/10 +5235 X=Q1+((S6-1)/10)-C6(1):Y=Q2+((S7-1)/10)-C6(2) +5236 D1=0:D2=0:IF(X=0)AND(Y=0)THEN5250 +5237 D1=SQR(X*X+Y*Y) +5238 IFX<0THENZ7=SGN(Y)*(3.1416-ATN(ABS(Y/X))) +5239 IFX=0THENZ7=SGN(Y)*1.5708 +5240 IFX>0THENZ7=ATN(Y/X) +5245 D2=12-Z7*1.9098593:IFD2>12THEND2=D2-12 +5250 PRINT"COURSE IS";FNS(D2);" FOR A DISTANCE OF"; +5260 PRINTFNS(D1);"QUADRANTS.":GOTO5040 +5300 REM-COST FOR WARP DRIVE +5302 INPUT"ENTER DISTANCE AND WARP FACTOR";D1,A4 +5304 IF(D1<0)THEN5040 +5310 C7=D1*A4*A4*A4 +5315 T1=(10*D1)/(A4*A4) +5320 PRINT"IT WOULD TAKE";FNS(T1);"STARDATES AND USE" +5325 PRINTFNR(C7);"UNITS OF ENERGY (";FNR(C7+C7);"IF SHIELDS ARE UP)" +5330 GOTO5040 +5400 REM-COST FOR IMPULSE POWER +5410 INPUT"ENTER DISTANCE...";D1 +5420 IFD1<0THEN5040 +5430 C7=250*D1+50:T1=D1/.4 +5440 PRINT"IT WOULD TAKE";FNR(T1);"STARDATES AND USE" +5450 PRINTC7;"UNITS OF ENERGY" +5460 GOTO5040 +5500 REM-PHASER EFFECTIVENESS +5510 INPUT"ENTER PHASER RANGE IN QUADRANTS";A3 +5520 IFA3<0THEN5040 +5530 A3=A3*10:C7=(.9^A3)*100 +5540 PRINT"PHASERS ARE ";LEFT$(STR$(C7),5);"% EFFECTIVE AT THAT RANGE" +5550 GOTO5040 +5600 REM- SCORE +5610 GOSUB23000 +5620 GOTO5040 +5700 RETURN +5990 PRINT"FORMAT IS MN,XXYY...WHERE MN IS THE QUADRANT" +5991 PRINT"AND XXYY IS THE SECTOR...E.G. 64,0307 REFERS" +5992 PRINT"TO QUADRANT 6-4, SECTOR 3-7." +5993 PRINT"NOTE: SECTOR COORDINATES MUST BE 4 DIGITS." +5995 GOTO 5040 +6000 REM - DEADKL +6001 IFT2$<>"C"THEN6100 +6010 C3=0:PRINT"***COMMANDER AT"; +6020 FORF=1TOR2 +6030 IF(C1(F)=Q1)AND(C2(F)=Q2)THEN6050 +6040 NEXTF +6050 C1(F)=C1(R2):C2(F)=C2(R2):C1(R2)=0:C2(R2)=0 +6060 R2=R2-1:F1(2)=1E30 +6070 IFR2<>0THENF1(2)=D0-(I4/R2)*LOG(RND(1)) +6080 K2=K2+1 +6090 GOTO6120 +6100 PRINT"***KLINGON AT"; +6110 K1=K1+1 +6120 PRINTA5;"-";A6;"DESTROYED." +6130 Q$(A5,A6)=".":R1=R1-1 +6140 IFR1=0THENRETURN +6150 R5=R4/(R1+4*R2) +6160 G(Q1,Q2)=G(Q1,Q2)-100 +6170 FORF=1TOK3 +6180 IF(K4(F)=A5)AND(K5(F)=A6)THEN6200 +6190 NEXTF +6200 K3=K3-1 +6210 IFF>K3THEN6250 +6220 FORG=FTOK3 +6230 K4(G)=K4(G+1):K5(G)=K5(G+1):K6(G)=K6(G+1) +6235 K7(G)=K7(G+1):K8(G)=K7(G) +6240 NEXTG +6250 K4(K3+1)=0:K5(K3+1)=0:K7(K3+1)=0:K8(K3+1)=0:K6(K3+1)=0 +6260 RETURN +7000 REM-DOCK +7001 IFC5$="DOCKED"THEN7100 +7010 IFB6=0THEN7020 +7015 IF(ABS(S6-B6)<=1)AND(ABS(S7-B7)<=1)THEN7040 +7020 PRINTS5$;" NOT ADJACENT TO A BASE." +7030 RETURN +7040 C5$="DOCKED" +7050 PRINT"HELMSMAN SULU - 'DOCKING MANEUVER COMPLETED.'" +7060 E1=I7:S3=I8:T4=I9:L1=J1 +7070 RETURN +7100 PRINT"MR. SULU - 'BUT CAPTAIN, WE'RE ALREADY DOCKED!'" +7110 RETURN +8000 REM-DREPORT +8001 J=0 +8003 PRINT +8005 FORI=1TO12 +8010 IFD4(I)<=0THEN8070 +8020 IFJ<>0THEN8060 +8030 PRINT" DEVICE";SPC(12);"-REPAIR TIMES-" +8040 PRINTSPC(21);"IN FLIGHT DOCKED" +8050 J=1 +8060 PRINT" ";D$(I);TAB(23);FNS(D4(I));TAB(33);FNS(D3*D4(I)) +8070 NEXTI +8080 IFJ=0THENPRINT"MR. SPOCK - 'ALL DEVICES FUNCTIONAL, CAPTAIN'" +8090 RETURN +9000 REM-EVENTS +9001 M=0:D7=D0+T1 +9010 FORL=1TO5 +9020 IFF1(L)>D7THEN9040 +9030 M=L:D7=F1(L) +9040 NEXTL +9050 X6=D7-D0:D0=D7 +9060 R4=R4-(R1+4*R2)*X6 +9070 R5=R4/(R1+4*R2) +9080 IFR5>0THEN9120 +9090 F9=2 +9100 GOSUB10000 +9110 RETURN +9120 IF(D4(5)=0)OR(C5$="DOCKED")THEN9180 +9130 IF(L1>=X6)OR(D4(5)<=L1)THEN9160 +9140 F9=3:GOSUB10000 +9150 RETURN +9160 L1=L1-X6 +9170 IFD4(5)<=X6THENL1=J1 +9180 R=X6 +9190 IFC5$="DOCKED"THENR=X6/D3 +9200 FORL=1TO12 +9210 IFD4(L)<=0THEN9230 +9220 D4(L)=D4(L)-R +9225 IFD4(L)<0THEND4(L)=0 +9226 IFD4(L)<>0THEN9230 +9227 PRINT:PRINT"DAMAGE CONTROL- '";D$(L);" NOW OPERATIONAL.'" +9230 NEXTL +9240 IFM=0THENRETURN +9250 T1=T1-X6 +9260 ONMGOTO9270,9290,9340,9350,9470 +9270 REM-SUPERNOVA +9280 X2=0:Y2=0:GOSUB27000 +9285 F1(1)=D0-.5*I5*LOG(RND(1)) +9286 IFG(Q1,Q2)=1000THENRETURN +9287 GOTO9001 +9290 REM-TRACTOR BEAM +9291 IFR2=0THEN9330 +9292 IFC5$="DOCKED"THEN9325 +9293 I=INT(RND(1)*R2)+1 +9294 Y6=(C1(I)-Q1)^2+(C2(I)-Q2)^2 +9295 IFY6=0THEN9325 +9296 Y6=SQR(Y6):T1=.17778*Y6 +9297 PRINT:PRINT"***";S5$;" CAUGHT IN LONG-RANGE TRACTOR BEAM--" +9298 Q1=C1(I):Q2=C2(I) +9299 S6=FNB(1):S7=FNB(1) +9300 PRINT" PULLED TO QUADRANT";Q1;"-";Q2;", SECTOR";S6;"-";S7 +9301 IFR6<>0THENPRINT"(REMAINDER OF IDLE PERIOD CANCELLED)" +9302 R6=0 +9303 IFS4<>0THEN9320 +9304 IF(D4(8)=0)AND(S3>0)THEN9310 +9305 PRINT"(SHIELDS NOT CURRENTLY USABLE.)" +9307 GOTO9320 +9310 GOSUB26500 +9315 S9=0 +9320 GOSUB18000 +9325 F1(2)=D0+T1-1.5*(I5/R2)*LOG(RND(1)) +9326 GOTO9001 +9330 F1(2)=1E30:GOTO9001 +9340 D9(1)=D0:D9(2)=R1:D9(3)=R2:D9(4)=R3:D9(5)=R4:D9(6)=R5 +9342 D9(7)=S1:D9(8)=B1:D9(9)=K1:D9(10)=K2 +9343 FORI=1TO8:FORJ=1TO8:D9(I-1+8*(J-1)+11)=G(I,J):NEXTJ:NEXTI +9344 FORI=75TO84:D9(I)=C1(I-74):NEXT +9345 FORI=85TO94:D9(I)=C2(I-84):NEXT +9346 FORI=95TO99:D9(I)=B2(I-94):NEXT +9347 FORI=100TO104:D9(I)=B3(I-99):NEXT +9348 D9(105)=B4:D9(106)=B5 +9349 S0=1:F1(3)=D0-.3*I5*LOG(RND(1)):GOTO9001 +9350 REM - STARBASE ATTACK +9355 IF(R2=0)OR(R3=0)THEN9400 +9360 FORI=1TOR3:FORJ=1TOR2:IF(B2(I)=C1(J))AND(B3(I)=C2(J))THEN9410 +9370 NEXTJ:NEXTI +9380 F1(4)=D0+.5+3*RND(1) +9390 F1(5)=1E30:GOTO9001 +9400 F1(4)=1E30:F1(5)=1E30:GOTO9001 +9410 B4=B2(I):B5=B3(I) +9420 IF(B4=Q1)AND(B5=Q2)THEN9380 +9430 F1(5)=D0+.5+3*RND(1) +9440 F1(4)=F1(5)-.3*I5*LOG(RND(1)) +9450 IFD4(9)>0THEN9001 +9455 PRINT +9460 PRINT"LT. UHURA- 'CAPTAIN, THE STARBASE IN";B4;"-";B5 +9461 PRINT" REPORTS THAT IT IS UNDER ATTACK AND CAN HOLD OUT" +9462 PRINT" ONLY UNTIL STARDATE";FNR(F1(5));"'" +9465 IFR6=0THEN9001 +9466 PRINT +9467 INPUT"MR. SPOCK- 'CAPTAIN, SHALL WE CANCEL THE IDLE PERIOD";B$ +9468 IFLEFT$(B$,1)="Y"THENR6=0 +9469 GOTO9001 +9470 REM - STARBASE DESTROYED +9475 F1(5)=1E30:IF(R2=0)OR(R3=0)THEN9001 +9485 K=INT(G(B4,B5)/100):IFG(B4,B5)-K*100<10THEN9001 +9490 FORI=1TOR2:IF(C1(I)=B4)AND(C2(I)=B5)THEN9520 +9510 NEXT:GOTO9001 +9520 IFS2(B4,B5)=-1THENS2(B4,B5)=0 +9530 IFS2(B4,B5)>999THENS2(B4,B5)=S2(B4,B5)-10 +9540 IF(B4<>Q1)OR(B5<>Q2)THEN9630 +9550 FORI=1TOK3:K=K4(I):L=K5(I) +9560 IFQ$(K,L)="C"THEN9570 +9565 NEXT +9570 IFK6(I)<25+50*RND(1)THEN9001 +9580 Q$(B6,B7)=".":B6=0:B7=0 +9590 GOSUB17000 +9600 PRINT:PRINT"MR. SPOCK- 'CAPTAIN, I BELIEVE THE STARBASE HAS"; +9610 PRINT" BEEN DESTROYED.'" +9620 GOTO9680 +9630 IF(R3=1)OR(D4(9)>0)THEN9680 +9640 PRINT +9650 PRINT"LT. UHURA- 'CAPTAIN, STARFLEET COMMAND REPORTS THAT" +9660 PRINT" THE STARBASE IN QUADRANT";B4;"-";B5;"HAS BEEN" +9670 PRINT" DESTROYED BY A KLINGON COMMANDER.'" +9680 G(B4,B5)=G(B4,B5)-10 +9690 IFR3<=1THEN9730 +9700 FORI=1TOR3:IF(B2(I)=B4)AND(B3(I)=B5)THEN9720 +9710 NEXT +9720 B2(I)=B2(R3):B3(I)=B3(R3) +9730 R3=R3-1 +9740 GOTO9001 +10000 REM-FINISH +10001 A2=1:PRINT:PRINT"IT IS STARDATE";FNR(D0):PRINT +10010 ONF9GOTO10020,10130,10160,10185,10195,10205,10220,10235 +10015 ONF9-8GOTO10245,10270,10280 +10020 REM-THE GAME HAS BEEN WON +10025 PRINT"YOU HAVE DESTROYED THE KLINGON INVASION FLEET" +10027 PRINT +10030 PRINT" ***THE FEDERATION IS SAVED***":G1=1 +10035 IF(A1=0)OR(B1<>0)THEN10110 +10040 IFLEFT$(S5$,1)<>"E"THEN10110 +10045 IF3*S1+35*N1+C4>=100THEN10110 +10050 IFD0-J2<=6THEN10070 +10060 R8=.1*S8*(S8+1)+.1 +10065 IF(K1+K2)/(D0-J2)I1THEN10150 +10140 PRINT"YOU ARE FOUND GUILTY AND SENTENCED TO DEATH!" +10145 A1=0:GOSUB23000:RETURN +10150 PRINT"YOU ARE ACQUITTED":GOSUB23000:RETURN +10160 REM- L.S. FAILURE +10165 PRINT"YOUR LIFE SUPPORT RESERVES HAVE RUN OUT, AND" +10170 PRINT"YOU WILL SOON DIE OF ASPHYXIATION" +10172 PRINT +10175 PRINT"YOUR STARSHIP IS A DERELICT IN SPACE." +10180 GOTO10300 +10185 REM-ENERGY GONE +10190 PRINT"YOUR ENERGY SUPPLY IS EXHAUSTED.":GOTO10172 +10195 REM-BATTLE DEFEAT +10200 PRINT"THE ";S5$;" HAS BEEN DESTROYED IN BATTLE." +10201 GOTO10300 +10205 PRINT"F9=6 INVALID":RETURN +10220 REM-NOVA +10225 PRINT"YOUR STARSHIP HAS BEEN DESTROYED BY A NOVA." +10230 PRINT"NICE SHOT, YOU HOCKEY PUCK!":GOTO10300 +10235 REM-SUPERNOVA +10240 PRINT"THE ";S5$;" HAS BEEN INCINERATED BY A SUPERNOVA." +10241 GOTO10300 +10245 REM-ABANDON(NO BASES) +10250 PRINT"YOU HAVE BEEN CAPTURED BY THE KLINGONS. IF YOU STILL" +10255 PRINT "HAD A STARBASE TO BE RETURNED TO, YOU WOULD HAVE BEEN" +10260 PRINT"REPATRIATED AND GIVEN ANOTHER CHANCE. SINCE YOU HAVE" +10265 PRINT"NO STARBASES, YOU WILL BE MERCILESSLY TORTURED TO DEATH!" +10266 GOTO10300 +10270 REM - SELF-DESTRUCT +10271 PRINT:PRINT"THE ";S5$;" IS NOW AN EXPANDING CLOUD" +10272 PRINT"OF SUB-ATOMIC PARTICLES...":GOTO10300 +10280 REM-NOT REMATERIALIZED +10285 PRINT"STARBASE WAS UNABLE TO RE-MATERIALIZE YOUR STARSHIP." +10300 PRINT +10310 IFLEFT$(S5$,1)="F"THENS5$="" +10315 IFLEFT$(S5$,1)="E"THENS5$="FAERIE QUEENE" +10316 A1=0 +10320 IFR1=0THEN10355 +10325 G3=R4/I3:B8=(R1+2*R2)/(I1+2*I4) +10326 A3=G3/B8 +10327 IF A3<1+.5+RND(1)THEN10345 +10330 PRINT"AS A RESULT OF YOUR ACTIONS, A TREATY WITH THE KLINGON" +10331 PRINT"EMPIRE HAS BEEN SIGNED. THE TERMS OF THE TREATY ARE" +10332 IFA3<3*RND(1)THEN10340 +10335 PRINT"FAVORABLE TO THE FEDERATION.":PRINT +10336 PRINT"CONGRATULATIONS.":GOTO10350 +10340 PRINT"HIGHLY UNFAVORABLE TO THE FEDERATION.":GOTO10350 +10345 PRINT"THE FEDERATION WILL BE DESTROYED!" +10350 GOSUB23000:RETURN +10355 PRINT"SINCE YOU TOOK THE LAST KLINGON WITH YOU, YOU ARE" +10360 PRINT"A MARTYR AND A HERO. SOMEDAY MAYBE THEY'LL ERECT" +10370 PRINT"A STATUE IN YOUR MEMORY. REST IN PEACE AND TRY NOT" +10380 PRINT"TO THINK ABOUT PIGEONS!":G1=1:A1=0 +10390 GOSUB23000:RETURN +11000 REM - HELP +11001 IFC5$<>"DOCKED"THEN11020 +11010 PRINT"ENSIGN CHEKOV- 'BUT CAPTAIN, WE'RE ALREADY DOCKED!'" +11015 RETURN +11020 IFD4(9)=0THEN11030 +11025 PRINT"SUBSPACE RADIO DAMAGED...CANNOT TRANSMIT.":RETURN +11030 IFR3<>0THEN11050 +11040 PRINT"LT. UHURA- 'CAPTAIN, I'M NOT GETTING ANY RESPONSE"; +11045 PRINT" FROM STARBASE!'":RETURN +11050 N1=N1+1:IFB6=0THEN11070 +11060 GOTO11130 +11070 D1=1E30 +11080 FORL=1TOR3:X=10*SQR((B2(L)-Q1)^2+(B3(L)-Q2)^2) +11090 IFX>D1THEN11110 +11100 D1=X:K=L +11110 NEXTL +11120 Q1=B2(K):Q2=B3(K):GOSUB18000 +11130 Q$(S6,S7)="." +11135 PRINT +11140 PRINT"STARBASE IN QUADRANT";Q1;"-";Q2;"RESPONDS --"; +11145 PRINT" ";S5$;" DEMATERIALIZES." +11146 P2=(1-.98^D1)^.333333 +11150 FORL=1TO3 +11155 IFL=1THENPRINT"1ST "; +11160 IFL=2THENPRINT"2ND "; +11170 IFL=3THENPRINT"3RD "; +11180 PRINT"ATTEMPT TO RE-MATERIALIZE THE ";S5$;". . . . ."; +11190 IFRND(1)>P2THEN11220 +11200 PRINT"FAILS.":NEXTL +11210 F9=11:GOSUB10000:RETURN +11220 FORL=1TO5:I=B6+INT(3*RND(1))-1 +11230 IF(I<1)OR(I>10)THEN11260 +11235 J=B7+INT(3*RND(1))-1 +11240 IF(J<1)OR(J>10)THEN11260 +11250 IFQ$(I,J)="."THEN11270 +11260 NEXTL:PRINT"FAILS.":GOTO11210 +11270 PRINT"SUCCEEDS.":S6=I:S7=J:Q$(I,J)=LEFT$(S5$,1) +11280 GOSUB7000:PRINT"LT. UHURA- 'CAPTAIN, WE MADE IT!'":RETURN +12000 REM-HITEM +12001 P4=2:L5=K3:N=1 +12010 FORK=1TOL5 +12020 IFH3(K)=0THEN12240 +12030 D6=.9+.01*RND(1):H2=H3(K)*D6^K7(N) +12040 P3=K6(N) +12050 P=ABS(P3):IFP4*H24.99THEN12100 +12090 PRINT"VERY SMALL HIT ON ":GOTO12110 +12100 PRINTFNR(H2);"UNIT HIT ON "; +12110 M$=Q$(X8,Y8) +12120 IF M$="K"THENPRINT"KLINGON AT"; +12125 IFM$="C"THENPRINT"COMMANDER AT"; +12130 PRINTX8;"-";Y8 +12140 IFK6(N)<>0THEN12180 +12150 A5=X8:A6=Y8:T2$=Q$(X8,Y8):GOSUB6000 +12160 IFR1<>0THEN12250 +12170 F9=1:GOSUB10000:GOTO12250 +12180 IFK6(N)<0THEN12240 +12190 IFRND(1)<.9THEN12240 +12200 IFK6(N)>(.4+.4*RND(1))*P3THEN12240 +12205 PRINT +12210 PRINT"***MR. SPOCK - 'CAPTAIN, THE VESSEL AT SECTOR"; +12215 PRINTX8;"-";Y8 +12220 PRINT" HAS JUST LOST ITS FIREPOWER.'" +12225 PRINT +12230 K6(N)=-K6(N) +12240 N=N+1 +12250 NEXTK +12260 RETURN +13000 REM - IMPULSE +13001 J3=0 +13010 IFD4(7)<>0THEN13250 +13020 IFE1<=75THEN13070 +13030 INPUT"ENTER COURSE AND DISTANCE";D2,D1 +13040 IFD2<0THENRETURN +13050 P3=50+250*D1 +13060 IFP375THEN13120 +13110 PRINT"QUADRANT. THEY ARE, THEREFORE, USELESS NOW.'":RETURN +13120 PRINT"QUADRANT. WE CAN GO, THEREFORE, A MAXIMUM OF "; +13130 PRINTFNR(.004*(E1-50)-.05);"QUADRANTS.'":RETURN +13140 T1=D1/.4 +13150 IFT1"Y"THENRETURN +13200 GOSUB15000:J3=1 +13210 IFA2<>0THENRETURN +13220 E1=E1-P3 +13230 IFE1>0THENRETURN +13240 F9=4:GOSUB10000:RETURN +13250 PRINT"IMPULSE ENGINES DAMAGED.":RETURN +14000 REM - LRSCAN +14001 N$=" #" +14005 PRINT +14010 IFD4(2)<>0THEN14180 +14020 PRINT"L.R. SCAN FOR QUADRANT";Q1;"-";Q2:PRINT +14030 I=Q1-1:J=Q1+1:K=Q2-1:L=Q2+1 +14040 FORM=ITOJ:FORN=KTOL +14050 IF(M<=0)OR(M>8)THEN14110 +14060 IF(N<=0)OR(N>8)THEN14110 +14070 IFD4(11)=0THENS2(M,N)=1 +14080 IFG(M,N)>=1000THEN PRINT" ***"; +14090 IFG(M,N)<1000THENPRINTSPC(5-LEN(STR$(G(M,N))));G(M,N); +14100 GOTO14120 +14110 PRINTN$; +14120 NEXTN +14130 PRINT +14140 NEXTM +14150 IFD4(11)=0THENRETURN +14155 PRINT +14160 PRINT"***WARNING*** - COMPUTER DISABLED - SCAN NOT RECORDED." +14170 RETURN +14180 PRINT"LONG RANGE SENSORS DAMAGED.":RETURN +15000 REM - MOVE +15001 A5=(15-D2)*.5235988 +15010 D4=-SIN(A5):D6=COS(A5) +15020 B8=ABS(D4) +15030 IFABS(D6)>B8THENB8=ABS(D6) +15040 D4=D4/B8:D6=D6/B8:T5=0:T6=0 +15050 IFD0+T110)THEN15150 +15106 IF(Y1<1)OR(Y1>10)THEN15150 +15108 IFQ$(X1,Y1)="O"THEN15111 +15109 IFQ$(X1,Y1)<>"."THEN15125 +15110 NEXTL +15111 D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +15112 S6=X1:S7=Y1 +15115 F4=S6:F5=S7 +15116 IFQ$(X1,Y1)<>"O"THEN15320 +15120 T2=FNA(1):T3=FNA(1) +15122 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):PRINT +15123 PRINT"*** SPACE PORTAL ENTERED ***":GOTO15307 +15125 T6=1:K=50*D1/T1:D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +15127 IF(Q$(X1,Y1)="K")OR(Q$(X1,Y1)="C")THEN15145 +15129 PRINT:PRINTS5$;" BLOCKED BY "; +15130 IFQ$(X1,Y1)="*"THENPRINT"STAR AT"; +15131 IFQ$(X1,Y1)="B"THENPRINT"STARBASE AT"; +15132 PRINT" SECTOR";X1;"-";Y1;"...." +15133 PRINT"EMERGENCY STOP REQUIRED";FNR(K);"UNITS OF ENERGY." +15135 E1=E1-K +15137 S6=INT(X7-D4+.5):F4=S6:S7=INT(Y7-D6+.5):F5=S7 +15140 IFE1>0THEN15320 +15141 F9=4:GOSUB10000:RETURN +15145 S6=X1:S7=Y1:GOSUB22000:F4=S6:F5=S7:GOTO15320 +15150 IFK3=0THEN15165 +15155 FORL=1TOK3 +15156 F3=SQR((X1-K4(L))^2+(Y1-K5(L))^2) +15158 K8(L)=.5*(F3+K7(L)):NEXTL +15160 IFG(Q1,Q2)<>1000THENGOSUB1000 +15162 IFA2<>0THENRETURN +15165 X7=10*(Q1-1)+S6:Y7=10*(Q2-1)+S7 +15170 X1=INT(X7+10*D1*B8*D4+.5) +15175 Y1=INT(Y7+10*D1*B8*D6+.5):L6=0 +15180 L5=0 +15185 IFX1>0THEN15195 +15190 X1=-X1+1:L5=1 +15195 IFY1>0THEN15210 +15200 Y1=-Y1+1:L5=1 +15210 IFX1<=80THEN15220 +15215 X1=161-X1:L5=1 +15220 IFY1<=80THEN15230 +15225 Y1=161-Y1:L5=1 +15230 IFL5=0THEN15240 +15235 L6=1:GOTO15180 +15240 IFL6=0THEN15270 +15260 PRINT:PRINT"*** MESSAGE FROM STARFLEET COMMAND.....STARDATE"; +15261 PRINTFNR(D0):PRINT:PRINT"'PERMISSION TO CROSS GALACTIC "; +15262 PRINT"PERIMETER IS HEREBY DENIED.'" +15263 PRINT" 'SHUT DOWN ENGINES IMMMEDIATELY!'" +15264 PRINT +15265 PRINT"SCOTT HERE - 'ENGINES SHUT DOWN AT "; +15266 Z1=INT((X1+9)/10):Z2=INT((Y1+9)/10) +15267 PRINT"QUADRANT";Z1;"-";Z2;", "; +15268 PRINT"SECTOR";X1-10*(Z1-1);"-";Y1-10*(Z2-1);"'" +15270 IFT5<>0THENRETURN +15295 Q1=INT((X1+9)/10):Q2=INT((Y1+9)/10) +15296 S6=X1-10*(Q1-1):S7=Y1-10*(Q2-1) +15307 GOSUB18400 +15310 PRINT:PRINT"ENTERING THE ";G2$;" QUADRANT (";Q1;"-";Q2;")" +15315 Q$(S6,S7)=LEFT$(S5$,1):GOSUB18000:RETURN +15320 Q$(S6,S7)=LEFT$(S5$,1) +15321 IFL6=1THENRETURN +15325 IFK3=0THEN15390 +15330 FORL=1TOK3 +15340 F3=SQR((F4-K4(L))^2+(F5-K5(L))^2) +15350 K8(L)=.5*(K7(L)+F3) +15360 K7(L)=F3 +15370 NEXTL +15380 GOSUB28000 +15390 GOSUB17000:RETURN +16000 REM-MOVECOM +16001 A=1:B=1 +16010 FORK=1TOK3 +16020 C=K4(K):D=K5(K) +16030 IFQ$(C,D)="C"THEN16050 +16040 NEXTK +16050 N=0:F=K6(K)+100*K3 +16060 IFF>1000THENN=INT(RND(1)*K7(K)+1) +16065 IF((C5$="DOCKED")AND((B4<>Q1)OR(B5<>Q2)))THENN=-S8 +16070 IFN=0THENN=INT(((F+200*RND(1))/150)-5) +16071 IFN=0THENRETURN +16072 IF(N>0)AND(K7(K)<1.5)THENRETURN +16075 IFABS(N)>S8THENN=SGN(N)*ABS(S8) +16080 T=ABS(N):P=S6-C:Q=S7-D +16085 IF2*ABS(P)0THENP=SGN(P*N) +16100 IFQ<>0THENQ=SGN(Q*N) +16105 R=C:S=D:Q$(C,D)="." +16110 FORL2=1TOT:L=R+P:M=S+Q +16115 IF(L>0)AND(L<=10)THEN16120 +16117 ONSGN(N)+2GOTO16240,16165,16165 +16120 IF(M>0)AND(M<=10)THEN16130 +16125 ONSGN(N)+2GOTO16240,16135,16135 +16130 IFQ$(L,M)="."THEN16195 +16135 IF(Q=B)OR(P=0)THEN16165 +16140 M=S+B +16145 IF(M>0)AND(M<=10)THEN16155 +16150 ONSGN(N)+2GOTO16240,16160,16160 +16155 IFQ$(L,M)="."THEN16195 +16160 B=-B +16165 IF(P=A)OR(Q=0)THEN16200 +16170 L=R+A +16175 IF(L>0)AND(L<=10)THEN16185 +16180 ONSGN(N)+2GOTO16240,16190,16190 +16185 IFQ$(L,M)="."THEN16195 +16190 A=-A:GOTO16200 +16195 R=L:S=M +16200 NEXTL2 +16205 Q$(R,S)="C" +16210 IF(R=C)AND(S=D)THENRETURN +16215 K4(K)=R:K5(K)=S:K7(K)=SQR((S6-R)^2+(S7-S)^2) +16220 K8(K)=K7(K):IFN>0THENPRINT"***COMMANDER ADVANCES TO"; +16225 IFN<0THENPRINT"***COMMANDER RETREATS TO"; +16230 PRINT" SECTOR";R;"-";S:GOSUB28000:RETURN +16240 I=Q1+INT((L+9)/10)-1:J=Q2+INT((M+9)/10)-1 +16245 IF(I<1)OR(I>8)THEN16350 +16250 IF(J<1)OR(J>8)THEN16350 +16260 FORL3=1TOR2 +16265 IF(C1(L3)=I)AND(C2(L3)=J)THEN16350 +16270 NEXTL3:PRINT"***COMMANDER ESCAPES TO "; +16275 PRINT"QUADRANT";I;"-";J;" (AND REGAINS STRENGTH)" +16280 K4(K)=K4(K3):K5(K)=K5(K3):K7(K)=K7(K3):K8(K)=K8(K3) +16285 K6(K)=K6(K3):K3=K3-1:C3=0 +16290 IFC5$<>"DOCKED"THENGOSUB17000 +16300 GOSUB28000 +16310 G(Q1,Q2)=G(Q1,Q2)-100:G(I,J)=G(I,J)+100 +16320 FORL3=1TOR2 +16330 IF(C1(L3)=Q1)AND(C2(L3)=Q2)THEN16340 +16335 NEXTL3 +16340 C1(L3)=I:C2(L3)=J:RETURN +16350 A=-A:B=-B:GOTO16200 +17000 REM - NEWCOND +17001 C5$="GREEN" +17010 IFE1<1000THENC5$="YELLOW" +17020 IFG(Q1,Q2)>99THENC5$="RED" +17030 RETURN +18000 REM- NEW QUAD +18001 J4=1:B6=0:B7=0:K3=0:C3=0 +18010 U=G(Q1,Q2) +18020 IFU>999THEN18290 +18030 K3=INT(.01*U):FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +18040 Q$(S6,S7)=LEFT$(S5$,1):U=G(Q1,Q2):IFU<100THEN18150 +18050 U=U-100*K3:FORA=1TOK3 +18060 S=FNB(1):K4(A)=S:T=FNB(1):K5(A)=T +18070 IFQ$(S,T)<>"."THEN18060 +18080 Q$(S,T)="K":K7(A)=SQR((S6-S)^2+(S7-T)^2):K8(A)=K7(A) +18090 K6(A)=RND(1)*150+325:NEXTA +18100 IFR2=0THEN18140 +18110 FORA=1TOR2 +18115 IF(C1(A)=Q1)AND(C2(A)=Q2)THEN18130 +18120 NEXTA:GOTO18140 +18130 Q$(S,T)="C":K6(K3)=1000+400*RND(1):C3=1 +18140 GOSUB28000 +18150 IFU<10THEN18190 +18160 U=U-10 +18170 B6=FNB(1):B7=FNB(1):IFQ$(B6,B7)<>"."THEN18170 +18180 Q$(B6,B7)="B" +18190 GOSUB17000:IFU<1THENRETURN +18200 FORA=1TOU +18210 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN18210 +18220 Q$(S,T)="*":NEXTA +18230 IF(T2<>Q1)OR(T3<>Q2)THENRETURN +18240 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN18240 +18250 Q$(S,T)="O":PRINT +18260 PRINT"MR. SPOCK - 'CAPTAIN, THE SHORT-RANGE SENSORS DETECT A" +18270 PRINT"SPACE WARP SOMEWHERE IN THIS QUADRANT.'" +18280 RETURN +18290 FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +18300 Q$(S6,S7)=LEFT$(S5$,1):RETURN +18400 G4$="III":L=2:IFQ2>=5THEN18420 +18410 L=1 +18420 G2$=G1$(2*(Q1-1)+L):L=Q2 +18425 IFL<=4THEN18440 +18430 L=Q2-4 +18440 G3$="IV":IFL=4THEN18460 +18450 G3$=LEFT$(G4$,L) +18460 G2$=G2$+" "+G3$:RETURN +19000 REM - NOVA +19001 IFRND(1)>.1THEN19015 +19010 GOSUB27000:RETURN +19015 Q$(A5,A6)=".":PRINT"***STAR AT SECTOR";A5;"-";A6;"NOVAS." +19020 G(Q1,Q2)=G(Q1,Q2)-1:S1=S1+1 +19025 B9=1:T6=1:T7=1:K=0:X1=0:Y1=0 +19030 H4(B9,1)=A5:H4(B9,2)=A6 +19035 FORM=B9TOT6:FORQ=1TO3:FORJ=1TO3 +19040 IFJ*Q=4THEN19260 +19045 J5=H4(M,1)+Q-2:J6=H4(M,2)+J-2 +19050 IF(J5<1)OR(J5>10)THEN19260 +19055 IF(J6<1)OR(J6>10)THEN19260 +19060 IFQ$(J5,J6)="."THEN19260 +19065 IFQ$(J5,J6)="O"THEN19260 +19070 IFQ$(J5,J6)<>"*"THEN19105 +19075 IFRND(1)>=.1THEN19085 +19080 X2=J5:Y2=J6:GOSUB27000:RETURN +19085 T7=T7+1:H4(T7,1)=J5:H4(T7,2)=J6:G(Q1,Q2)=G(Q1,Q2)-1 +19090 S1=S1+1:PRINT"***STAR AT SECTOR";J5;"-";J6;"NOVAS." +19100 GOTO19255 +19105 IFQ$(J5,J6)<>"B"THEN19140 +19110 G(Q1,Q2)=G(Q1,Q2)-10:FORV=1TOR3 +19115 IF(B2(V)<>Q1)OR(B3(V)<>Q2)THEN19125 +19120 B2(V)=B2(R3):B3(V)=B3(R3) +19125 NEXTV:R3=R3-1:B6=0:B7=0:B1=B1+1:GOSUB17000 +19130 PRINT"***STARBASE AT SECTOR";J5;"-";J6;"DESTROYED." +19135 GOTO19255 +19140 IF(S6<>J5)OR(S7<>J6)THEN19190 +19145 PRINT"***STARSHIP BUFFETED BY NOVA.":IFS4<>0THEN19155 +19150 E1=E1-1000:GOTO19170 +19155 IFS3>=1000THEN19180 +19160 D6=1000-S3:E1=E1-D6:GOSUB17000:S3=0:S4=0 +19165 PRINT"***STARSHIP SHIELDS KNOCKED OUT.":D4(8)=.005*D5*RND(1))*D6 +19170 IFE1>0THEN19185 +19175 F9=7:GOSUB10000:RETURN +19180 S3=S3-1000 +19185 X1=X1+S6-H4(M,1):Y1=Y1+S7-H4(M,2):K=K+1:GOTO19260 +19190 IFQ$(J5,J6)<>"C"THEN19250 +19195 FORV=1TOK3 +19200 IF(K4(V)=J5)AND(K5(V)=J6)THEN19210 +19205 NEXTV +19210 K6(V)=K6(V)-800:IFK6(V)<=0THEN19250 +19215 N5=J5+J5-H4(M,1):N6=J6+J6-H4(M,2) +19220 PRINT"***COMMANDER AT SECTOR";J5;"-";J6;"DAMAGED"; +19225 IF(N5<1)OR(N5>10)OR(N6<1)OR(N6>10)THEN19245 +19230 PRINT" AND BUFFETED TO SECTOR";N5;"-";N6 +19235 Q$(N5,N6)="C":K4(V)=N5:K5(V)=N6 +19240 K7(V)=SQR((S6-N5)^2+(S7-N6)^2):K8(V)=K7(V) +19241 Q$(J5,J6)="." +19245 PRINT:GOTO19260 +19250 A5=J5:A6=J6:T2$=Q$(J5,J6):GOSUB6000:GOTO19260 +19255 PRINT:Q$(J5,J6)="." +19260 NEXTJ:NEXTQ:NEXTM +19265 IFT6=T7THEN19280 +19270 B9=T6+1:T6=T7:GOTO19035 +19280 IFK=0THENRETURN +19290 D1=K*.1 +19300 IFX1<>0THENX1=SGN(X1) +19310 IFY1<>0THENY1=SGN(Y1) +19320 I=3*(X1+1)+Y1+2 +19330 D2=C5(I) +19340 IFD2=0THEND1=0 +19350 IFD1=0THENRETURN +19360 PRINT:PRINT"FORCE OF NOVA DISPLACES STARSHIP." +19370 GOSUB15000:RETURN +20000 REM-PHASERS +20001 P=2:J3=1 +20020 IFC5$<>"DOCKED"THEN20030 +20025 PRINT"PHASERS CAN'T BE FIRED THRU BASE SHIELDS.":GOTO20080 +20030 IFD4(3)=0THEN20050 +20040 PRINT"PHASER BANKS DAMAGED.":GOTO20080 +20050 IFS4=0THEN20060 +20055 PRINT"SHIELDS MUST BE DOWN TO FIRE PHASERS.":GOTO20080 +20060 IFK3>0THEN20090 +20065 PRINT +20070 PRINT"MR. SPOCK - 'CAPTAIN, THE SHORT-RANGE SENSORS" +20075 PRINT" DETECT NO KLINGONS IN THIS QUADRANT.'" +20080 J3=0:RETURN +20090 PRINT"PHASERS LOCKED ON TARGET. ENERGY AVAILABLE="; +20095 PRINT.01*INT(100*E1) +20100 INPUT"UNITS TO FIRE";P1:IFP1=ETHEN20270 +20250 H3(I)=H5(I):E=E-R7 +20260 NEXTI:GOTO20280 +20270 H3(I)=H3(I)+E:E=0 +20280 GOSUB12000 +20290 IF(E<>0)AND(A2=0)THEN20310 +20300 J3=1:RETURN +20310 PRINTFNR(E);"EXPENDED ON EMPTY SPACE.":J3=1:RETURN +21000 REM - PHOTONS +21001 J3=1:IFD4(4)=0THEN21015 +21010 PRINT"PHOTON TUBES DAMAGED.":GOTO21035 +21015 IFT4<>0THEN21025 +21020 PRINT"NO TORPEDOS LEFT.":GOTO21035 +21025 INPUT"TORPEDO COURSE";C6 +21030 IFC6>=0THEN21040 +21035 J3=0:RETURN +21040 INPUT"BURST OF 3";B$:N=1 +21045 IFLEFT$(B$,1)="N"THEN21066 +21050 IFLEFT$(B$,1)<>"Y"THEN21040 +21051 IFT4>2THEN21060 +21055 PRINT"NO BURST. ONLY";T4;"TORPEDOS LEFT.":GOTO21035 +21060 INPUT"SPREAD ANGLE (3 - 30 DEG)";G2 +21061 IFG2<0THEN21035 +21062 IF(G2<3)OR(G2>30)THEN21060 +21063 G2=FND(G2) +21065 N=3 +21066 REM - CONTINUE +21070 FORZ6=1TON +21075 IFC5$<>"DOCKED"THENT4=T4-1 +21080 Z7=Z6:R=RND(1) +21085 R=(R+RND(1))*.5-.5 +21090 IF(R>=-.4)AND(R<=.4)THEN21125 +21095 R=(RND(1)+1.2)*R:IFN=3THEN21105 +21100 PRINT"***TORPEDO MISFIRES...":GOTO21110 +21105 PRINT"***TORPEDO NUMBER";Z6;"MISFIRES..." +21110 IF RND(1)>.2THEN21125 +21115 PRINT"***PHOTON TUBES DAMAGED BY MISFIRE." +21120 D4(4)=D5*(1+2*RND(1)):GOTO21440 +21125 IF(S4<>0)OR(C5$="DOCKED")THENR=R+.001*S3*R +21130 A3=C6+.25*R:IFN=1THEN21140 +21135 A8=(15-A3+(2-Z6)*G2)*.5235988:PRINT +21137 PRINT"TRACK FOR TORPEDO NUMBER";Z7;"--":GOTO21145 +21140 PRINT:PRINT"TORPEDO TRACK --":A8=(15-A3)*.5235988 +21145 X4=-SIN(A8):Y4=COS(A8):B8=ABS(X4) +21146 IFABS(Y4)>ABS(X4)THENB8=ABS(Y4) +21150 X4=X4/B8:Y4=Y4/B8:X5=S6:Y5=S7 +21155 FORL9=1TO15:X5=X5+X4:A5=INT(X5+.5) +21160 IF(A5<1)OR(A5>10)THEN21430 +21165 Y5=Y5+Y4:A6=INT(Y5+.5) +21170 IF(A6<1)OR(A6>10)THEN21430 +21175 IF(L9=5)OR(L9=9)THENPRINT +21180 PRINTFNR(X5);"-";FNR(Y5);", "; +21185 IFQ$(A5,A6)<>"."THEN21195 +21190 GOTO21425 +21195 PRINT:IFQ$(A5,A6)="K"THEN21220 +21200 IFQ$(A5,A6)<>"C"THEN21325 +21205 IFRND(1)>.1THEN21220 +21210 PRINT"***COMMANDER AT SECTOR";A5;"-";A6;"USES ANTI-PHOTON"; +21215 PRINT" DEVICE!":PRINT" TORPEDO NEUTRALIZED.":GOTO21435 +21220 FORV=1TOK3 +21225 IF(A5=K4(V))AND(A6=K5(V))THEN21235 +21230 NEXTV +21235 K=K6(V):W3=200+800*RND(1) +21240 IFABS(K)0THEN21255 +21250 T2$=Q$(A5,A6):GOSUB6000:GOTO21435 +21255 IFQ$(A5,A6)="K"THENPRINT"***KLINGON AT"; +21260 IFQ$(A5,A6)="C"THENPRINT"***COMMANDER AT"; +21265 PRINTA5;"-";A6; +21270 A7=A8+2.5*(RND(1)-.5) +21275 W3=ABS(-SIN(A7)):IFABS(COS(A7))>W3THENW3=ABS(COS(A7)) +21280 X7=-SIN(A7)/W3:Y7=COS(A7)/W3 +21285 P=INT(A5+X7+.5):Q=INT(A6+Y7+.5) +21290 IF(P<1)OR(P>10)OR(Q<1)OR(Q>10)THEN21320 +21295 IFQ$(P,Q)<>"."THEN21320 +21300 Q$(P,Q)=Q$(A5,A6):Q$(A5,A6)=".":PRINT"DAMAGED--" +21305 PRINT" DISPLACED BY BLAST TO SECTOR";P;"-";Q +21310 K4(V)=P:K5(V)=Q:K7(V)=SQR((S6-P)^2+(S7-Q)^2) +21311 K8(V)=K7(V) +21315 GOSUB28000:GOTO21435 +21320 PRINT"DAMAGED, BUT NOT DESTROYED.":GOTO21435 +21325 IFQ$(A5,A6)<>"B"THEN21365 +21330 PRINT"***STARBASE DESTROYED...CONGRATULATIONS...YOU TURKEY!" +21335 IFS2(Q1,Q2)<0THENS2(Q1,Q2)=0 +21340 FORW=1TOR3 +21345 IF(B2(W)<>Q1)OR(B3(W)<>Q2)THEN21355 +21350 B2(W)=B2(R3):B3(W)=B3(R3) +21355 NEXTW:Q$(A5,A6)=".":R3=R3-1:B6=0:B7=0 +21360 G(Q1,Q2)=G(Q1,Q2)-10:B1=B1+1:GOSUB17000:GOTO21435 +21365 IFQ$(A5,A6)<>"*"THEN21405 +21370 IFRND(1)>.15THEN21385 +21375 PRINT"***STAR AT SECTOR";A5;"-";A6;"UNAFFECTED BY PHOTON BLAST" +21380 GOTO21435 +21385 X2=A5:Y2=A6:GOSUB19000:A5=X2:A6=Y2 +21390 IFG(Q1,Q2)=1000THENRETURN +21395 IFA2<>0THENRETURN +21400 GOTO21435 +21405 PRINT:PRINT"AAAAAIIIIIIIEEEEEEEAAAAAAAUUUUUUGGGGGGGHHHHHHHHHH!!!" +21410 PRINT" HACK! HACK! COUGH! *CHOKE!*" +21415 PRINT:PRINT"MR. SPOCK- 'FASCINATING!'":Q$(A5,A6)="." +21420 T2=0:T3=0:GOTO21435 +21425 NEXTL9 +21430 PRINT:PRINT"TORPEDO MISSED!" +21435 NEXTZ6 +21440 IFR1<>0THENRETURN +21445 F9=1:GOSUB10000:RETURN +22000 REM - RAM +22001 PRINT:PRINT"*** RED ALERT!! RED ALERT!! ***":PRINT +22010 PRINT"*** COLLISION IMMINENT!!":PRINT +22020 PRINT"*** ";S5$;" RAMS ";:W7=1:IFQ$(S6,S7)="C"THENW7=2 +22030 IFW7=1THENPRINT"KLINGON AT "; +22040 IFW7=2THENPRINT"COMMANDER AT "; +22050 PRINT"SECTOR";S6;"-";S7:A5=S6:A6=S7:T2$=Q$(S6,S7) +22060 GOSUB6000:PRINT"***";S5$;" HEAVILY DAMAGED." +22070 K=INT(5+RND(1)*20):PRINT"***SICKBAY REPORTS";K;"CASUALTIES!" +22080 C4=C4+K:FORL=1TO12:I=RND(1) +22090 J=(3.5*W7*(RND(1)+I)+1)*D5 +22100 IFL=6THENJ=J/3 +22110 D4(L)=D4(L)+T1+J:NEXTL:D4(6)=D4(6)-3 +22120 IFD4(6)<0THEND4(6)=0 +22130 S4=0:IFR1<>0THENRETURN +22140 F9=1:GOSUB10000:RETURN +23000 REM - SCORE +23001 P=D0-J2:IF(P<>0)AND(R1=0)THEN23020 +23010 IFP<5THENP=5 +23020 N=(K2+K1)/P:K=INT(500*N+.5):L=0 +23030 IFG1<>0THENL=100*S8 +23035 I=0 +23040 IFLEFT$(S5$,1)="E"THENM=0 +23045 IFLEFT$(S5$,1)="F"THENM=1 +23050 IFLEFT$(S5$,1)=""THENM=2 +23060 IFA1=0THENI=200 +23070 J=10*K1+50*K2+K+L-I-100*B1-100*M-35*N1-3*S1-C4 +23080 PRINT:IFJ<>0THEN23100 +23090 PRINT"AS YET, YOU HAVE NO SCORE.":RETURN +23100 PRINT"YOUR SCORE --":PRINT:IFK1=0THEN23120 +23110 PRINTK1;TAB(5);"ORDINARY KLINGON(S) DESTROYED";TAB(36);10*K1 +23120 IFK2=0THEN23140 +23130 PRINTK2;TAB(5);"KLINGON COMMANDER(S) DESTROYED";TAB(36);50*K2 +23140 IFK=0THEN23160 +23150 PRINTFNR(N);TAB(5);"KLINGONS PER STARDATE, AVERAGE"; +23155 PRINTTAB(36);K +23160 IFS1=0THEN23180 +23170 PRINTS1;TAB(5);"STAR(S) DESTROYED";TAB(36);-3*S1 +23180 IFB1=0THEN23200 +23190 PRINTB1;TAB(5);"STARBASES DESTROYED";TAB(36);-100*B1 +23200 IFN1=0THEN23220 +23210 PRINTN1;TAB(5);"SOS CALL(S) TO A STARBASE";TAB(36);-35*N1 +23220 IFC4=0THEN23240 +23230 PRINTC4;TAB(5);"CASUALTIES INCURRED";TAB(36);-C4 +23240 IFM=0THEN23260 +23250 PRINTM;TAB(5);"SHIP(S) LOST OR DESTROYED";TAB(36)-100*M +23260 IFA1<>0THEN23280 +23270 PRINT"PENALTY FOR GETTING YOURSELF KILLED";TAB(36);-200 +23280 IFG1=0THEN23300 +23290 PRINTTAB(5);"BONUS FOR WINNING ";S$(S8);" GAME";TAB(36);L +23300 PRINTTAB(5);"-------------------------------------" +23310 PRINTTAB(28);"TOTAL";TAB(36);J;"**":RETURN +24000 REM-SETUP +24001 A2=0:G1=0:GOSUB4000:S5$="ENTERPRISE" +24010 I7=5000:E1=I7:I8=2500:S3=I8:S4=0:S9=S4:J1=4:L1=J1 +24020 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):I9=10:T4=I9 +24030 W1=5:W2=25:FORI=1TO12:D4(I)=0:NEXT +24040 J2=100*INT(31*RND(1)+20):D0=J2:K1=0:K2=0:N1=0:N2=0:R6=0:C4=0 +24050 A1=1:D3=.25:FORI=1TO8:FORJ=1TO8:S2(I,J)=0:NEXTJ:NEXTI +24060 F1(1)=D0-.5*I5*LOG(RND(1)):F1(5)=1E30 +24070 F1(2)=D0-1.5*(I5/R2)*LOG(RND(1)):I6=0 +24080 F1(3)=D0-.3*I5*LOG(RND(1)):F1(4)=D0-.3*I5*LOG(RND(1)) +24090 FORI=1TO8:FORJ=1TO8:K=INT(RND(1)*9+1):I6=I6+K +24100 G(I,J)=K:NEXTJ:NEXTI:S1=0 +24110 FOR I=1TOI2 +24120 X=INT(RND(1)*6+2):Y=INT(RND(1)*6+2) +24130 IFG(X,Y)>=10THEN24120 +24140 IFI<2THEN24180 +24150 K=I-1:FORJ=1TOK:D1=SQR((B2(J)-X)^2+(B3(J)-Y)^2) +24160 IFD1<2THEN24120 +24170 NEXTJ +24180 B2(I)=X:B3(I)=Y:S2(X,Y)=-1:G(X,Y)=G(X,Y)+10:NEXTI +24190 B1=0:K=I1-I4:L=INT(.25*S8*(9-L2)+1) +24200 M=INT((1-RND(1)^2)*L):IFM>KTHENM=K +24210 N=100*M +24220 X=FNA(1):Y=FNA(1):IFG(X,Y)+N>999THEN24220 +24230 G(X,Y)=G(X,Y)+N:K=K-M:IFK<>0THEN24200 +24240 FORI=1TOI4 +24250 X=FNA(1):Y=FNA(1):IF(G(X,Y)<99)AND(RND(1)<.75)THEN24250 +24260 IFG(X,Y)>899THEN24250 +24270 IFI=1THEN24300 +24280 M=I-1:FORJ=1TOM:IF(C1(J)=X)AND(C2(J)=Y)THEN24250 +24290 NEXTJ +24300 G(X,Y)=G(X,Y)+100:C1(I)=X:C2(I)=Y:NEXTI +24305 I=INT(D0):PRINT:S0=0 +24310 T2=FNA(1):T3=FNA(1):IFG(T2,T3)<100THEN24310 +24320 IFS8<>1THEN24440 +24330 PRINT"IT IS STARDATE";I;"...THE ORGANIAN PEACE TREATY BETWEEN" +24340 PRINT"THE UNITED FEDERATION OF PLANETS AND THE KLINGON EMPIRE" +24350 PRINT"HAS COLLAPSED AND THE FEDERATION IS BEING ATTACKED BY A" +24360 PRINT"DEADLY KLINGON INVASION FLEET. AS CAPTAIN OF THE STARSHIP" +24370 PRINT"U.S.S. ENTERPRISE, IT IS YOUR MISSION TO SEEK OUT AND" +24380 PRINT"DESTROY THIS INVASION FORCE OF";I1;"BATTLE CRUISERS." +24390 PRINT:PRINT"YOU HAVE AN INITIAL ALLOTMENT OF";INT(I5); +24400 PRINT"STARDATES":PRINT"TO COMPLETE YOUR MISSION." +24410 PRINT"AS THE MISSION PROCEEDS, YOU MAY BE GIVEN MORE TIME." +24420 PRINT:PRINT"YOU WILL HAVE";I2;"SUPPORTING STARBASE(S).":PRINT +24430 GOTO24515 +24440 PRINT"STARDATE..............";I +24450 PRINT"NUMBER OF KLINGONS....";I1 +24460 PRINT"NUMBER OF STARDATES...";INT(I5) +24470 PRINT"NUMBER OF STARBASES...";I2 +24480 PRINT"STARBASE LOCATIONS...."; +24490 FORI=1TOI2:PRINTB2(I);"-";B3(I); +24500 IFI<>I2THENPRINT", "; +24510 NEXTI:PRINT:PRINT +24515 GOSUB18400 +24520 PRINT"THE ";S5$;" IS CURRENTLY IN THE ";G2$;" QUADRANT." +24530 GOSUB18000:RETURN +25000 REM - SETWARP +25010 INPUT"WARP FACTOR";K +25020 PRINT +25025 IFK<1THEN25140 +25026 IFK>10THEN25150 +25030 J=W1:W1=K:W2=W1*W1 +25040 IF(W1<=J)OR(W1<=6)THEN25070 +25050 IFW1<=8THEN25080 +25060 IFW1>8THEN25100 +25070 PRINT"ENSIGN CHEKOV - 'WARP FACTOR";W1;"CAPTAIN'":RETURN +25080 PRINT"ENGINEER SCOTT - 'AYE, BUT OUR MAXIMUM SAFE SPEED"; +25090 PRINT" IS WARP 6.'":RETURN +25100 IFW1=10THEN25130 +25110 PRINT"ENGINEER SCOTT-'AYE, CAPTAIN, BUT OUR ENGINES MAY NOT "; +25120 PRINT"TAKE IT.'":RETURN +25130 PRINT"ENGINEER SCOTT-'AYE, CAPTAIN, WE'LL GIVE IT A TRY.'":RETURN +25140 PRINT"ENSIGN CHEKOV-'WE CAN'T GO BELOW WARP 1, CAPTAIN.'":RETURN +25150 PRINT"ENSIGN CHEKOV-'OUR TOP SPEED IS WARP 10, CAPTAIN.'" +25160 RETURN +26000 REM - SHIELDS +26001 J3=0:IFD4(8)<>0THEN26600 +26010 IFS4<>0THEN26530 +26500 INPUT"SHIELDS ARE DOWN. DO YOU WANT THEM UP";B$ +26510 IFLEFT$(B$,1)="Y"THEN26560 +26520 RETURN +26530 INPUT"SHIELDS ARE UP. DO YOU WANT THEM DOWN";B$ +26540 IFLEFT$(B$,1)="Y"THEN26590 +26550 RETURN +26560 S4=1:S9=1:IFC5$<>"DOCKED"THENE1=E1-50 +26570 PRINT"SHIELDS RAISED.":IFE1<=0THEN26610 +26580 J3=1:RETURN +26590 S4=0:S9=1:PRINT"SHIELDS LOWERED.":J3=1:RETURN +26600 PRINT"SHIELDS DAMAGED AND DOWN.":RETURN +26610 PRINT:PRINT"SHIELDS USE UP LAST OF THE ENERGY." +26620 F9=4:GOSUB10000:RETURN +27000 REM - SUPERNOVA +27001 IFX2<>0THEN27100 +27010 N=INT(RND(1)*I6+1):FORX=1TO8:FORY=1TO8 +27020 N=N-(G(X,Y)-INT(G(X,Y)/10)*10):IFN<=0THEN27040 +27030 NEXTY:NEXTX:RETURN +27040 IF(X<>Q1)OR(Y<>Q2)THEN27150 +27050 IFJ4<>0THEN27150 +27060 N=INT(RND(1)*(G(X,Y)-INT(G(X,Y)/10)*10))+1 +27070 FORX3=1TO10:FORY3=1TO10:IFQ$(X3,Y3)<>"*"THEN27090 +27080 N=N-1:IFN=0THEN27100 +27090 NEXTY3:NEXTX3 +27100 PRINT:PRINT"*** RED ALERT!! RED ALERT!! *** +27105 X3=X2:Y3=Y2 +27110 PRINT"*** INCIPIENT SUPERNOVA DETECTED AT SECTOR";X3;"-";Y3 +27120 X=Q1:Y=Q2:K=(X2-S6)^2+(Y2-S7)^2 +27130 IFK>1.5THEN27180 +27140 PRINT"*** EMERGENCY AUTO-OVERRIDE JAMMED ***":A2=1:GOTO27180 +27150 IFD4(9)<>0THEN27180 +27160 PRINT:PRINT"MESSAGE FROM STARFLEET COMMAND...STARDATE";INT(D0) +27170 PRINT"'SUPERNOVA IN QUADRANT";X;"-";Y; +27175 PRINT"....CAUTION ADVISED'" +27180 N=G(X,Y):R=INT(N/100):Q=0 +27190 IF(X<>Q1)OR(Y<>Q2)THEN27210 +27200 K3=0:C3=0 +27210 IFR=0THEN27270 +27220 R1=R1-R:IFR2=0THEN27270 +27230 FORL=1TOR2:IF(C1(L)<>X)OR(C2(L)<>Y)THEN27260 +27240 C1(L)=C1(R2):C2(L)=C2(R2):C1(R2)=0:C2(R2)=0 +27250 R2=R2-1:R=R-1:Q=1:IFR2=0THENF1(2)=1E30 +27260 NEXTL +27270 IFR3=0THEN27310 +27280 FORL=1TOR3:IF(B2(L)<>X)OR(B3(L)<>Y)THEN27300 +27290 B2(L)=B2(R3):B3(L)=B3(R3):B2(R3)=0:B3(R3)=0:R3=R3-1 +27300 NEXTL +27310 IFX2=0THEN27350 +27320 N=G(X,Y)-INT(G(X,Y)/100)*100 +27330 S1=S1+(N-INT(N/10)*10):B1=B1+INT(N/10) +27340 K1=K1+R:K2=K2+Q +27350 IF(S2(X,Y)<>0)AND(D4(9)<>0)THENS2(X,Y)=1000+G(X,Y) +27360 IF(D4(9)=0)OR((Q1=X)AND(Q2=Y))THENS2(X,Y)=1 +27370 G(X,Y)=1000 +27380 IF(R1<>0)OR((X=Q1)AND(Y=Q2))THEN27430 +27390 PRINT:PRINT"MR. SPOCK- 'CAPTAIN, A SUPERNOVA IN QUADRANT"; +27400 PRINTX;"-";Y;"HAS JUST DESTROYED THE LAST OF THE KLINGONS.'" +27420 F9=1:GOSUB10000:RETURN +27430 IFA2=0THENRETURN +27440 F9=8:GOSUB10000:RETURN +28000 REM - SORTKL +28001 IFK3<=1THENRETURN +28005 Z4=0 +28010 FORO=1TOK3-1:IFK7(O)<=K7(O+1)THEN28080 +28020 K=K7(O):K7(O)=K7(O+1):K7(O+1)=K +28030 K=K8(O):K8(O)=K8(O+1):K8(O+1)=K +28040 K=K4(O):K4(O)=K4(O+1):K4(O+1)=K +28050 K=K5(O):K5(O)=K5(O+1):K5(O+1)=K +28060 K=K6(O):K6(O)=K6(O+1):K6(O+1)=K +28070 Z4=1 +28080 NEXTO +28090 IFZ4<>0THEN28005 +28100 RETURN +29000 REM-SRSCAN +29001 IFD(1)<>0THEN29230 +29010 PRINT:PRINT" 1 2 3 4 5 6 7 8 9 10" +29020 FORI=1TO10:IFI<10THENPRINT" "; +29030 PRINTI;:FORJ=1TO10:PRINTQ$(I,J);" ";:NEXTJ +29040 ONIGOTO29050,29060,29080,29090,29140 +29045 ONI-5GOTO29150,29160,29170,29200,29210 +29050 PRINT" STARDATE ";FNR(D0):GOTO29220 +29060 IFC5$<>"DOCKED"THENGOSUB17000 +29070 PRINT" CONDITION ";C5$:GOTO29220 +29080 PRINT" POSITION ";Q1;"-";Q2;", ";S6;"-";S7:GOTO29220 +29090 PRINT" LIFE SUPPORT ";:IFD4(5)<>0THEN29110 +29100 PRINT"ACTIVE":GOTO29220 +29110 IFC5$<>"DOCKED"THEN29130 +29120 PRINT"DAMAGED, SUPPORTED BY STARBASE":GOTO29220 +29130 PRINT"DAMAGED, RESERVES=";FNS(L1):GOTO29220 +29140 PRINT" WARP FACTOR ";FNR(W1):GOTO29220 +29150 PRINT" ENERGY";SPC(8);.01*INT(100*E1):GOTO29220 +29160 PRINT" TORPEDOS ";T4:GOTO29220 +29170 PRINT" SHIELDS ";:B$="DOWN,":IFS4<>0THENB$="UP," +29180 IFD4(8)>0THENB$="DAMAGED," +29190 PRINTB$;INT(100*S3/I8+.5);"%":GOTO29220 +29200 PRINT" KLINGONS LEFT ";R1:GOTO29220 +29210 PRINT" TIME LEFT ";FNS(R5) +29220 NEXTI:RETURN +29230 PRINT"SHORT RANGE SENSORS DAMAGED.":RETURN +30000 REM - TIMEWARP +30001 PRINT:PRINT"*** TIME WARP ENTERED ***":PRINT"YOU ARE TRAVELING "; +30010 IFS0<>0THEN30050 +30020 T1=-.5*I5*LOG(RND(1)) +30030 PRINT"FORWARD IN TIME";FNR(T1);"STARDATES." +30040 F1(2)=F1(2)+T1:GOTO30200 +30050 M=D0:D0=D9(1) +30060 PRINT"BACKWARD IN TIME";FNR(M-D0);"STARDATES.":S0=0 +30070 R1=D9(2):R2=D9(3):R3=D9(4):R4=D9(5):R5=D9(6) +30080 S1=D9(7):B1=D9(8):K1=D9(9):K2=D9(10) +30090 FORI=1TO8:FORJ=1TO8:G(I,J)=D9(I-1+8*(J-1)+11):NEXTJ:NEXTI +30100 FORI=75TO84:C1(I-74)=D9(I):NEXT +30110 FORI=85TO94:C2(I-84)=D9(I):NEXT +30120 FORI=95TO99:B2(I-94)=D9(I):NEXT +30130 FORI=100TO104:B3(I-99)=D9(I):NEXT:B4=D9(105):B5=D9(106) +30140 F1(1)=D0-.5*I5*LOG(RND(1)) +30150 IFR2<>0THENF1(2)=D0-(I5/R2)*LOG(RND(1)) +30160 F1(3)=D0-.5*I5*LOG(RND(1)) +30170 FORI=1TO8:FORJ=1TO8:IF10THEN31120 +31020 INPUT"NUMBER OF UNITS TO SHIELDS";Z3 +31030 IFZ3<0THENRETURN +31040 IFE1+S3-Z3>0THEN31060 +31050 PRINT"SCOTT HERE- 'WE ONLY HAVE";FNR(E1+S3);"UNITS LEFT.'" +31051 RETURN +31060 E1=E1+S3-Z3:S3=Z3:PRINT"--ENERGY TRANSFER COMPLETE--" +31070 PRINT"(SHIP ENERGY=";FNR(E1);" SHIELD ENERGY=";FNR(S3);")" +31075 J3=1 +31080 T1=.1:P5=(K3+4*C3)/48:IFP5<.1THENP5=.1 +31090 IFP5>RND(1)THENGOSUB1000 +31100 IFA2<>0THENRETURN +31110 GOSUB9000:RETURN +31120 PRINT"TRANSFER PANEL DAMAGED.":RETURN +32000 REM - VISUAL +32001 INPUT"WHICH DIRECTION";Z +32005 PRINT +32010 J3=0:IFZ<0THENRETURN +32012 IFZ<=12THEN32020 +32014 PRINT"DIRECTIONS ARE FROM 0 TO 12 ONLY":GOTO32001 +32020 T1=.05:P=(K3+4*C3)/48:IFP<.05THENP=.05 +32030 IFP>RND(1)THENGOSUB1000 +32040 IFA2<>0THENRETURN +32050 GOSUB9000:J3=1:IFA2<>0THENRETURN +32080 D5=INT((Z/12)*8+1.5):IFD5>8THEND5=1 +32085 FORI=1TO5:FORJ=1TO5:V$(I,J)=" ":NEXTJ:NEXTI:N=0 +32087 V$(3,3)=LEFT$(S5$,1) +32090 OND5GOTO32100,32130,32150,32170,32190,32220,32260,32300 +32100 I=S6-2:J=S7-2:V$(1,1)=Q$:IF(J>0)AND(I>0)THENV$(1,1)=Q$(I,J) +32110 I=S6-1:J=S7-1:V$(2,2)=Q$:IF(I>0)AND(J>0)THENV$(2,2)=Q$(I,J) +32120 N=N+1:IFN=3THEN32350 +32125 I=S6-2:V$(1,2)=Q$:IF(I>0)AND(J>0)THENV$(1,2)=Q$(I,J) +32130 I=S6-2:V$(1,3)=Q$:IFI>0THENV$(1,3)=Q$(I,S7) +32135 I=S6-1:V$(2,3)=Q$:IFI>0THENV$(2,3)=Q$(I,S7) +32140 N=N+1:IFN=3THEN32350 +32145 I=S6-2:J=S7+1:V$(1,4)=Q$:IF(I>0)AND(J<11)THENV$(1,4)=Q$(I,J) +32150 I=S6-2:J=S7+2:V$(1,5)=Q$:IF(I>0)AND(J<11)THENV$(1,5)=Q$(I,J) +32155 I=S6-1:J=S7+1:V$(2,4)=Q$:IF(I>0)AND(J<11)THENV$(2,4)=Q$(I,J) +32160 N=N+1:IFN=3THEN32350 +32165 J=S7+2:V$(2,5)=Q$:IF(I>0)AND(J<11)THENV$(2,5)=Q$(I,J) +32170 J=S7+2:V$(3,5)=Q$:IFJ<11THENV$(3,5)=Q$(S6,J) +32175 J=S7+1:V$(3,4)=Q$:IFJ<11THENV$(3,4)=Q$(S6,J) +32180 N=N+1:IFN=3THEN32350 +32185 I=S6+1:J=S7+2:V$(4,5)=Q$:IF(I<11)AND(J<11)THENV$(4,5)=Q$(I,J) +32190 I=S6+2:J=S7+2:V$(5,5)=Q$:IF(I<11)AND(J<11)THENV$(5,5)=Q$(I,J) +32195 I=S6+1:J=S7+1:V$(4,4)=Q$:IF(I<11)AND(J<11)THENV$(4,4)=Q$(I,J) +32200 N=N+1:IFN=3THEN32350 +32210 I=S6+2:V$(5,4)=Q$:IF(I<11)AND(J<11)THENV$(5,4)=Q$(I,J) +32220 I=S6+2:V$(5,3)=Q$:IFI<11THENV$(5,3)=Q$(I,S7) +32230 I=S6+1:V$(4,3)=Q$:IFI<11THENV$(4,3)=Q$(I,S7) +32240 N=N+1:IFN=3THEN32350 +32250 I=S6+2:J=S7-1:V$(5,2)=Q$:IF(I<11)AND(J>0)THENV$(5,2)=Q$(I,J) +32260 I=S6+2:J=S7-2:V$(5,1)=Q$:IF(I<11)AND(J>0)THENV$(5,1)=Q$(I,J) +32270 I=S6+1:J=S7-1:V$(4,2)=Q$:IF(I<11)AND(J>0)THENV$(4,2)=Q$(I,J) +32280 N=N+1:IFN=3THEN32350 +32290 J=S7-2:V$(4,1)=Q$:IF(I<11)AND(J>0)THENV$(4,1)=Q$(I,J) +32300 J=S7-2:V$(3,1)=Q$:IFJ>0THENV$(3,1)=Q$(S6,J) +32310 J=S7-1:V$(3,2)=Q$:IFJ>0THENV$(3,2)=Q$(S6,J) +32320 N=N+1:IFN=3THEN32350 +32330 I=S6-1:J=S7-2:V$(2,1)=Q$:IF(I>0)AND(J>0)THENV$(2,1)=Q$(I,J) +32340 GOTO32100 +32350 FORI=1TO5 +32360 IF(V$(I,1)=" ")AND(V$(I,3)=" ")AND(V$(I,5)=" ")THEN32390 +32370 PRINT" "; +32380 FORJ=1TO5:PRINTV$(I,J);" ";:NEXTJ:PRINT +32390 NEXTI:RETURN +33000 REM - WAIT +33001 J3=0:INPUT"HOW MANY STARDATES";Z5 +33010 IF(Z5"Y"THENRETURN +33030 R6=1 +33040 IFZ5<=0THENR6=0 +33050 IFR6=0THENRETURN +33060 T1=Z5:Z6=Z5 +33070 IFK3=0THEN33100 +33080 T1=1+RND(1):IFZ50THENRETURN +33120 GOSUB9000:J3=1:IFA2<>0THENRETURN +33130 Z5=Z5-Z6:GOTO33040 +34000 REM:WARP +34001 J3=0:IFD4(6)<>0THEN34750 +34010 INPUT"ENTER COURSE AND DISTANCE";D2,D1 +34020 IFD2<0THENRETURN +34030 P=(D1+.05)*W1*W1*W1*(S4+1):IFPE1)THEN34080 +34060 PRINT" WE HAVEN'T THE ENERGY TO GO THAT FAR WITH"; +34070 PRINT" THE SHIELDS UP.":RETURN +34080 W=INT((E1/(D1+.05))^.333333):IFW<=0THEN34130 +34090 PRINT" WE HAVEN'T THE ENERGY. BUT WE COULD DO IT AT WARP";W +34100 IFS4<>0THEN34120 +34110 RETURN +34120 PRINT" IF YOU'LL LOWER THE SHIELDS.":RETURN +34130 PRINT" WE CAN'T DO IT, CAPTAIN. WE HAVEN'T GOT THE ENERGY." +34140 RETURN +34150 T1=10*D1/W2:IFT1<.8*R5THEN34500 +34160 PRINT:PRINT"MR. SPOCK - 'CAPTAIN, I COMPUTE THAT SUCH A TRIP" +34170 PRINT" WILL REQUIRE APPROXIMATELY";FNR(100*T1/R5); +34180 PRINT"PERCENT":PRINT" OF OUR REMAINING TIME. ARE YOU SURE "; +34190 INPUT "THIS IS WISE";B$:IFLEFT$(B$,1)="Y"THEN34500 +34200 J3=0:RETURN +34500 Q4=0:W=0:IFW1<=6THEN34660 +34510 P=D1*(6-W1)^2/66.66666:IFP>RND(1)THENQ4=1 +34520 IFQ4<>0THEND1=RND(1)*D1 +34530 W=0:IFW1<10THEN34550 +34540 IF.25*D1>RND(1)THENW=1 +34550 IF(Q4=0)AND(W=0)THEN34660 +34560 A=(15-D2)*.5235998:X1=-SIN(A):X2=COS(A) +34570 B8=ABS(X1):IFABS(X2)>ABS(X1)THENB8=ABS(X2) +34580 X1=X1/B8:Y1=Y1/B8:N=INT(10*D1*B8+.5):X=S6:Y=S7 +34590 IFN=0THEN34660 +34600 FORL=1TON +34610 X=X+X1:Q=INT(X+.5):IF(Q<1)OR(Q>10)THEN34660 +34620 Y=Y+Y1:R=INT(Y+.5):IF(R<1)OR(R>10)THEN34660 +34630 IFQ$(Q,R)="."THEN34650 +34640 Q4=0:W=0 +34650 NEXTL +34660 GOSUB15000:IFA2<>0THENRETURN +34670 E1=E1-D1*W1*W1*W1*(S4+1):IFE1>0THEN34690 +34680 F9=4:GOSUB10000:RETURN +34690 T1=10*D1/W2:IFW<>0THENGOSUB30000 +34700 IFQ4=0THEN34740 +34710 PRINT:PRINT"ENGINEERING TO BRIDGE--":PRINT" SCOTT HERE- "; +34715 PRINT"'WE'VE JUST BLOWN THE WARP ENGINES." +34720 PRINT" WE'LL HAVE TO SHUT 'ER DOWN HERE, CAPTAIN.'" +34725 D4(6)=D5*(3*RND(1)+1) +34740 J3=1:RETURN +34750 PRINT"WARP ENGINES DAMAGED.":RETURN +35000 REM - ABANDON +35001 ONSGN(D4(10))+2GOTO35010,35030,35020 +35010 PRINT"YE FAERIE QUEENE HAS NO SHUTTLE CRAFT.":RETURN +35020 PRINT"SHUTTLE CRAFT DAMAGED.":RETURN +35030 PRINT:PRINT"***ABANDON SHIP! ABANDON SHIP!" +35040 PRINT"***ALL HANDS ABANDON SHIP!":PRINT +35050 PRINT"YOU AND THE BRIDGE CREW ESCAPE IN THE GALILEO." +35060 PRINT"THE REMAINDER OF THE CREW BEAMS DOWN" +35070 PRINT"TO THE NEAREST HABITABLE PLANET.":IFR3<>0THEN35090 +35080 F9=9:GOSUB10000:RETURN +35090 PRINT:PRINT"YOU ARE CAPTURED BY KLINGONS AND RELEASED TO" +35100 PRINT"THE FEDERATION IN A PRISONER-OF-WAR EXCHANGE." +35110 PRINT"STARFLEET PUTS YOU IN COMMAND OF ANOTHER SHIP," +35120 PRINT"THE FAERIE QUEENE WHICH IS ANTIQUATED, BUT" +35130 PRINT"STILL USABLE.":N=INT(RND(1)*R3+1):Q1=B2(N):Q2=B3(N) +35140 S6=5:S7=5:GOSUB18000:Q$(S6,S7)="." +35145 FORL=1TO3:S6=INT(3*RND(1)-1+B6) +35150 IF(S6<1)OR(S7>10)THEN35180 +35160 S7=INT(3*RND(1)-1+B7):IF(S7<1)OR(S7>10)THEN35180 +35170 IFQ$(S6,S7)="."THEN35190 +35180 NEXTL:GOTO35140 +35190 S5$="FAERIE QUEENE":Q$(S6,S7)=LEFT$(S5$,1):C5$="DOCKED" +35200 FORL=1TO12:D4(L)=0:NEXT:D4(10)=-1:E1=3000:I7=E1 +35210 S3=1500:I8=S3:T4=6:I9=T4:L1=3:J1=L1:S4=0:W1=5:W2=25 +35220 RETURN +36000 REM - DESTRUCT +36001 IFD4(11)=0THEN36030 +36010 PRINT"COMPUTER DAMAGED - CANNOT EXECUTE DESTRUCT SEQUENCE" +36020 RETURN +36030 PRINT:PRINT" ---WORKING---" +36040 PRINT"IDENTIFICATION-POSITIVE" +36050 PRINT"SELF-DESTRUCT-SEQUENCE-ACTIVATED":J=3 +36060 FORI=10TO6STEP-1:PRINTSPC(J);I:GOSUB36210:J=J+3:NEXT +36070 PRINT"ENTER-YOUR-MISSION-PASSWORD-TO-CONTINUE" +36080 PRINT"SELF-DESTRUCT-SEQUENCE-OTHERWISE-DESTRUCT" +36090 PRINT"SEQUENCE-WILL-BE-ABORTED" +36100 INPUTB$:IFB$<>X$THEN36190 +36110 PRINT"PASSWORD-ACCEPTED":J=10 +36120 FORI=5TO1STEP-1:PRINTSPC(J);I:GOSUB36210:J=J+3:NEXT +36130 PRINT:PRINT"*****ENTROPY OF ";S5$;" MAXIMIZED*****" +36140 PRINT:IFK3=0THEN36180 +36150 W=20*E1:FORL=1TOK3:IFK6(L)*K7(L)>WTHEN36170 +36160 A5=K4(L):A6=K5(L):T2$=Q$(A5,A6):GOSUB6000 +36170 NEXTL +36180 F9=10:GOSUB10000:RETURN +36190 PRINT"PASSWORD-REJECTED" +36200 PRINT"CONTINUITY-EFFECTED":PRINT:RETURN +36210 K=12345:FORM=1TO90:K=K+1:NEXTM:RETURN +37000 REM - STATUS +37001 FORI=1TO10:GOTO29040:RETURN +37010 END + \ No newline at end of file diff --git a/disks/images/b/STRTRK#2.ASC b/disks/images/b/STRTRK#2.ASC new file mode 100644 index 0000000..4e8ace0 --- /dev/null +++ b/disks/images/b/STRTRK#2.ASC @@ -0,0 +1,546 @@ +1000 'EXPANDED APRIL 1977 BY W.A.BURTON +1001 'PIRATED JAN. 1978 BY ZOSO +1002 DIM G(8,8),S(8,8),K(3,3) +1003 PRINTCHR$(26) +1004 PRINT TAB(21)"--STARTREK--":PRINT +1005 PRINT +1006 INPUT "WHAT IS YOUR SECURITY CLEARANCE NUMBER (1 TO 1000)";T9 +1007 E8=T9 +1008 IF T9<1 OR T9>1000 THEN PRINT AR$;"INVALID!! REENTER!!":GOTO 1006 +1009 FOR A=1 TO T9/2 +1010 R9=RND(1):R9=RND(2) +1011 NEXT +1012 CLEAR:PRINTCHR$(26):INPUT" ENTER RANK (1=LOW,12=HIGH)";R9 +1013 RR=R9 +1014 X4=R9:R9=R9+1E-03:W1=W1+1E-03 +1015 PRINT CHR$(26) +1016 PRINT "COMMAND ORDER : STAND BY !" +1017 PRINT "YOU ARE PRESENTLY BEING ASSIGNED TO A MISSION..." +1018 PRINT " WITH A FAILURE FACTOR OF"; (RR*20) +1019 PRINT" GOOD-BYE, SIR..." +1020 CX=.017453:AR$=" ---> " +1021 XA=INT(X4*50):AC=(1/(X4+.1)) +1022 IFX4>=9THEN1379 +1023 E=3000-XA+100:P=10:S9=200 +1024 DEF FND(D)=SQR((K(I,1)-S1)^2+(K(I,2)-S2)^2) +1025 Q1=INT(RND(1)*8+1):Q2=INT(RND(1)*8+1) +1026 S1=INT(RND(1)*8+1):S2=INT(RND(1)*8+1) +1027 DATA WARP ENGINES,SHORT RANGE SENSORS,LONG RANGE SENSORS +1028 DATA PHASERS, PHOTON TORPEDOES,SHIELD CONTROL +1029 DATA DAMAGE CONTROL, COMPUTER,DAMAGE REPAIR,COMMUNICATIONS +1030 FOR A=1TO10:READ D$(A):NEXT A +1031 A$(0)=" . ":A$(1)=" E ":A$(2)=" * ":A$(3)=" K ":A$(4)=" B " +1032 F1=.86:F2=.01:F3=.95:F4=.99:K9=0:B9=K9 +1033 FORI=1TO8:FORJ=1TO8:R1=RND(1):R2=RND(1):R3=INT(8*RND(1)+1) +1034 K3=-(R1>F1-F2*R9)-(R1>F3-F2*R9)-(R1>F4-F2*R9):K9=K9+K3 +1035 B3=-(R2>F3):B9=B9+B3:G(I,J)=100*K3+10*B3+R3:NEXTJ,I +1036 IF NOT(B9>0ANDK9>0)THEN1032 +1037 PRINT"OBJECTIVE:DESTROY"K9"KLINGONS USING"B9"STARBASE"; +1038 U=K9:Y=B9 +1039 IFB9=1THENPRINT" ";:GOTO1041 +1040 PRINT"S "; +1041 T9=K9+RND(1)*K9/R9+10-R9:PR=T9/K9:PRINT"IN"T9"STARDAYS." +1042 GOSUB 1425 +1043 S3=0:B3=S3:K3=B3:FORA=1TO8:FORB=1TO8:S(A,B)=0:NEXTB,A +1044 FORA=1TO3:FORB=1TO3:K(A,B)=0:NEXTB,A:S(S1,S2)=1 +1045 X=.01*G(Q1,Q2):K3=INT(X):Y=(X-K3)*10:B3=INT(Y) +1046 S3=G(Q1,Q2)-100*K3-10*B3 +1047 IF K3=0THENFORA=1TO3:FORB=1TO3:K(A,B)=0:NEXTB,A:GOTO1051 +1048 PRINTAR$;"CONDITION RED !!!!!":FORA=1TOK3 +1049 R1=INT(RND(1)*8+1):R2=INT(RND(1)*8+1):IFS(R1,R2)<>0THEN1049 +1050 S(R1,R2)=3:K(A,1)=R1:K(A,2)=R2:K(A,3)=S9:NEXT A:IFB3=0THEN1054 +1051 IFB3=0THEN1054 +1052 R1=INT(RND(1)*8+1):R2=INT(RND(1)*8+1):IFS(R1,R2)<>0THEN1052 +1053 S(R1,R2)=4 +1054 IFS3=0THEN1058 +1055 FORA=1TOS3 +1056 R1=INT(RND(1)*8+1):R2=INT(RND(1)*8+1):IFS(R1,R2)<>0THEN1056 +1057 S(R1,R2)=2:NEXTA +1058 G(Q1,Q2)=INT(G(Q1,Q2))+.5 +1059 PRINT +1060 PRINT"QUADRANT (";MID$(STR$(Q1),2,1);",";MID$(STR$(Q2),2,1);")" +1061 PRINT"SECTOR (";MID$(STR$(S1),2,1);",";MID$(STR$(S2),2,1);")" +1062 IFKP<>0THEN1404 +1063 IF DT=1 THEN 1267 +1064 IFS<200*K3THENPRINTAR$;"SHIELD ENERGY TOO LOW":SL=1:A=6:GOTO1074 +1065 A=2: GOTO1074 +1066 PRINT +1067 PRINTD$(2):FORA=1TO8:FORB=1TO8:PRINTA$(S(A,B));:NEXTB:PRINT:NEXTA +1068 PRINT:PRINT"SHIELDS";S;SPC(4);"ENERGY";E;SPC(4);"PHOTONS";P; +1069 PRINTSPC(4);"STARDAYS";T9-T +1070 GOSUB1321:INPUT"COMMAND";A +1071 IF A>10 OR A<0 THEN INPUT" ----> COMMAND";A +1072 IFA>10ORA<0THENPRINT"WARNING - PROPER COMMANDS ONLY !! ":GOTO 1070 +1073 IFA=1THEN1077 +1074 IFD(A)>=0THEN1077 +1075 PRINTAR$;"CAPTAIN, WE DON'T HAVE ";D$(A);" ANYMORE." +1076 IF DT=1 THEN 1267 ELSE 1070 +1077 ONAGOTO1081,1066,1146,1152,1178,1213,1222,1267,1489,1389 +1078 PRINT:FORA=1TO9:PRINTA;" = ";D$(A):NEXTA +1079 A=10 +1080 PRINTA;"= ";D$(A):GOTO1070 +1081 INPUT"COURSE";C1:IF C1<0 OR C1>359.99 THEN1084 +1082 INPUT"WARP FACTOR";W1 +1083 SL=0:KP=0:GOTO 1085 +1084 PRINTAR$"REJECTED ! COURSE MUST BE IN RANGE OF O TO 359.99 DGRS." +1085 IFNOT(W1>0)THEN1070 +1086 IFD(1)>=0ORW1<=ACTHEN1089 +1087 PRINTAR$;"WARP ENGINES ARE DAMAGED, MAXIMUM SPEED = ";AC +1088 GOTO1081 +1089 TEC=TEC+1:C$="":IFK3>0THENGOSUB1228 +1090 IFE>5*W1THEN1097 +1091 IFS<1THEN1244 +1092 PRINT"CAPTAIN, YOU ONLY HAVE"E"UNITS OF ENERGY. " +1093 PRINT"REFUEL FROM YOUR SHIELD RESERVES, WHICH HAVE"S"UNITS?" +1094 A=6 +1095 IFD(A)<0THEN1244 +1096 GOTO1070 +1097 FORI=1TO10:IFD(I)>=0THEN1101 +1098 D(I)=D(I)+1:IFD(I)<0THEN1101 +1099 IFD(7)<0THEN1101 +1100 PRINT"DAMAGE CONTROL REPORT: "D$(I)" REPAIRED." +1101 NEXTI:IFRND(1)>.1THEN1112 +1102 IFRND(1)>.1THEN1112 +1103 GOTO1109 +1104 IFRND(1)>R9/10THENRETURN +1105 R1=INT(RND(1)*8+1):IFD(R1)<0THENRETURN +1106 D(R1)=D(R1)-10*RND(1)-1:IFD(7)<0THENRETURN +1107 IFD(7)<0THENRETURN +1108 PRINT:PRINT"DAMAGE CONTROL REPORT: "D$(R1)" OUT.":PRINT:RETURN +1109 R1=INT(RND(1)*8+1):IFD(R1)>=0THEN1112 +1110 IFD(7)<0THEN1112 +1111 PRINT:D(R1)=0:PRINT"DAMAGE CONTROL REPORT: "D$(R1)" REPAIRED.":PRINT +1112 W1=W1*8:A1=8*Q2+S2-9:B1=72-8*Q1-S1:IFW1<1THENW1=W1*1.25 +1113 E=E-2*W1:T=T+W1/25:IFT>T9THEN1251 +1114 A2=INT(A1+W1*COS(C1*CX)+.5) +1115 B2=INT(B1+W1*SIN(C1*CX)+.5) +1116 IFNOT(A2<0ORA2>63ORB2<0ORB2>63)THEN1119 +1117 PRINTAR$;"CAPTAIN, HEED STARFLEET REGULATIONS! ( STAY IN GALAXY ) !! +1118 T=T+W1/24:GOTO1070 +1119 DEF FNA1(X)=INT(.5+A1+X*COS(C1*CX)) +1120 DEF FNB1(X)=INT(.5+B1+X*SIN(C1*CX)) +1121 FORX=0TOINT(W1) +1122 IFNOT(Q1=8-INT(FNB1(X)/8)ANDQ2=INT(FNA1(X)/8+1))THENX=W1:GOTO1139 +1123 S3=8-FNB1(X)+8*INT(FNB1(X)/8):S4=FNA1(X)+1-8*INT(FNA1(X)/8) +1124 IFS(S3,S4)<2THEN1139 +1125 S(S1,S2)=0:S1=8-FNB1(X-1)+8*INT(FNB1(X-1)/8) +1126 S2=FNA1(X-1)+1-8*INT(FNA1(X 1)/8):S(S1,S2)=1 +1127 PRINTAR$;"NAVIGATIONAL ERROR :ENGINES SHUT DOWN AT ("; +1128 PRINTMID$(STR$(S1),2,1);","MID$(STR$(S2),2,1);")" +1129 T=T+(W1/24) +1130 PRINT" YOU LOST "T" UNITS STARTIME RESTARTING ENGINES." +1131 PRINT +1132 IF S(S3,S4)<>4 THEN 1070 +1133 PRINT"SHIELDS LOWERED FOR REFUELING" +1134 S=0:P=10:C$="D":E=3000-XA+100 +1135 GOSUB 1228 +1136 FORR1=1TO 10 +1137 IFD(R1)>=0THENNEXTR1:GOTO1070 +1138 D(R1)=D(R1)+(11*RND(1)/R9):NEXTR1:GOTO1070 +1139 NEXT X:S(S1,S2)=0:S1=8-B2+8*INT(B2/8):S2=A2+1-8*INT(A2/8) +1140 Q3=8-INT(B2/8):Q4=INT(A2/8)+1 +1141 IFNOT(Q1=Q3ANDQ2=Q4)THENQ1=Q3:Q2=Q4:GOTO1043 +1142 S(S1,S2)=1:FORA=S1-1TOS1+1:FORB=S2-1TOS2+1 +1143 IFA>8ORB>8ORA<1ORB<1THEN1145 +1144 IFS(A,B)=4THEN1133 +1145 NEXTB,A:GOTO1070 +1146 PRINT +1147 FOR A=(Q1-1) TO (Q1+1):FOR B=(Q2-1) TO (Q2+1) +1148 IFA<1ORB<1ORA>8ORB>8THENPRINT" ***";:NEXTB:PRINT" ":PRINT:NEXTA:GOTO1070 +1149 PRINT" "SPC(3-LOG(G(A,B)+1)/LOG(10)); +1150 PRINTMID$(STR$(G(A,B)),2,LOG(G(A,B))/LOG(10)+1); +1151 G(A,B)=INT(G(A,B))+.5:NEXTB:PRINT" ":PRINT:NEXTA:GOTO1070 +1152 PRINT +1153 IFK3<=0THEN1226 +1154 IFD(8)>=0THEN1156 +1155 PRINTAR$;" COMPUTER FAILURE HAMPERS ACCURACY" +1156 PRINT"PHASERS LOCKED ON TARGET. ENERGY AVAILABLE="E +1157 PRINT"NUMBER OF UNITS TO FIRE:"; +1158 INPUT X +1159 IF E-X<0THENPRINT"NOT ENOUGH POWER":GOTO1070 +1160 T=T+.05:IFT>T9THEN1251 +1161 E=E-X +1162 IF C$<>"D"THEN GOSUB 1228 +1163 IFD(8)>=0THEN1165 +1164 X=X*RND(1) +1165 FORI=1TO3 +1166 IFK(I,3)<=0THEN1176 +1167 H=(X/FND(0))+SGN(RND(1)-.5)*8*RND(1) +1168 K(I,3)=K(I,3)-H +1169 PRINTH"UNIT HIT ON VESSEL AT (";MID$(STR$(K(I,1)),2,1);","; +1170 PRINTMID$(STR$(K(I,2)),2,1);"), LEAVING"K(I,3)" +1171 IFK(I,3)>0THEN1176 +1172 PRINT"KLINGON AT (";MID$(STR$(K(I,1)),2,1);",";MID$(STR$(K(I,2)),2,1); +1173 PRINT") DESTROYED":K3=K3-1:K9=K9-1:IFK9=0THEN1264 +1174 G(Q1,Q2)=G(Q1,Q2)-100:S(K(I,1),K(I,2))=0:K(I,1)=0:K(I,2)=0 +1175 K(I,3)=0 +1176 NEXT I +1177 GOTO1070 +1178 PRINT +1179 IFP>0THEN1182 +1180 PRINTAR$;"ALL PHOTON TORPEDOES EXPENDED" +1181 GOTO1070 +1182 INPUT"DIRECTION";C1 +1183 T=T+.05:IFT>T9THEN1251 +1184 P=P-1:IF C$<>"D" THEN GOSUB 1228 +1185 A1=8*Q2+S2-9:B1=72-8*Q1-S1:IFC1=90*INT(C1/90)THEN1208 +1186 DEF FNA1(W1)=INT(.5+A1+W1*COS(C1*CX)) +1187 DEF FNB1(W1)=INT(.5+B1+W1*SIN(C1*CX)) +1188 FORW1=0TO10STEP.9 +1189 IFW1=0THENS3=S1:S4=S2:GOTO1194 +1190 IFNOT(Q1=8-INT(FNB1(W1)/8)ANDQ2=INT(FNA1(W1)/8+1))THEN1070 +1191 S3=8-FNB1(W1)+8*INT(FNB1(W1)/8):S4=FNA1(W1)+1-8*INT(FNA1(W1)/8) +1192 IFFNA1(W1)=A2ANDFNB1(W1)=B2THEN1206 +1193 A2=FNA1(W1):B2=FNB1(W1) +1194 PRINT"(";MID$(STR$(S3),2,1);",";MID$(STR$(S4),2,1);")";A$(S(S3,S4)) +1195 ON S(S3,S4)+1GOTO1206,1206,1204,1196,1203 +1196 IFRND(1)<(.1*X4) THENPRINT"SHIELDS DEFLECT TORPEDO":GOTO1070 +1197 PRINT"KLINGON DESTROYED":S(S3,S4)=0:G(Q1,Q2)=G(Q1,Q2)-100 +1198 K3=K3-1:K9=K9-1:IFK9=0THEN1264 +1199 FORA=1TO3 +1200 IFK(A,1)=S3ANDK(A,2)=S4THENK(A,1)=0:K(A,2)=0:K(A,3)=0 +1201 NEXTA +1202 GOTO1070 +1203 PRINTAR$;"STARBASE DESTROYED":B3=0:B9=B9-1:S(S3,S4)=0:GOTO1205 +1204 PRINTAR$;"YOU CAN'T DESTROY A STAR":GOTO1070 +1205 G(Q1,Q2)=G(Q1,Q2)-10:GOTO1070 +1206 NEXT W1 +1207 GOTO1070 +1208 FORW1=0TO8 +1209 S3=INT(S1-W1*SIN(C1*CX)) +1210 S4=INT(S2+W1*COS(C1*CX)) +1211 IFS3>8ORS4>8ORS3<1ORS4<1THEN1070 +1212 GOTO1194 +1213 PRINT +1214 PRINT"ENERGY AVAILABLE="E+S" NUMBER OF UNITS TO SHIELDS"; +1215 INPUT X +1216 IFX<0THEN1070 +1217 IFE+S-X<0THEN1214 +1218 E=E+S-X +1219 S=X +1220 IFSL=1THEN1065 +1221 GOTO1070 +1222 PRINT +1223 PRINT"DEVICE STATE OF REPAIR" +1224 FORR1=1TO10:PRINTD$(R1);TAB(21) D(R1):NEXTR1 +1225 IF DT=1 THEN 1267 ELSE 1070 +1226 PRINT"SHORT RANGE SENSORS REPORT NO KLINGONS IN THIS QUADRANT" +1227 IF DT=1 THEN 1267 ELSE 1070 +1228 IF C$="D" AND K3<>0 THEN PRINT"STARBASE PROTECTS ENTERPRISE" ELSE 1230 +1229 GOTO1070 +1230 PRINT +1231 FORI=1TO3 +1232 IFK(I,3)<=0THEN1242 +1233 H=K(I,3)/FND(0)+SGN(RND(1)-.5)*RND(1)*7 +1234 S=S-H:PRINTH"UNIT HIT FROM ("MID$(STR$(K(I,1)),2,1);","; +1235 PRINTMID$(STR$(K(I,2)),2,1);"), LEAVING"S +1236 IFS<0THEN1254 +1237 GOSUB1104 +1238 IFRND(1)>R9/10THEN1242 +1239 R1=INT(8*RND(1)+1):R2=INT(8*RND(1)+1) +1240 IFNOT(S(R1,R2)=0)THEN1239 +1241 S(R1,R2)=3:S(K(I,1),K(I,2))=0:K(I,1)=R1:K(I,2)=R2 +1242 NEXTI +1243 RETURN +1244 PRINT AR$;" ENTERPRISE DEAD IN SPACE" +1245 PRINT +1246 CY=1:PRINT:GOTO1258 +1247 IFK3<=0THEN1258 +1248 GOSUB1228 +1249 GOTO1247 +1250 PRINT +1251 PRINT:PRINT:PRINT:PRINT:PRINT:PRINTAR$; +1252 PRINT"IT IS STARDATE"T:PRINT +1253 GOTO1258 +1254 PRINT +1255 PRINT:PRINT:PRINT:PRINT:PRINT:PRINTAR$; +1256 PRINT"ENTERPRISE DISABLED !!":PRINT:PRINT +1257 CY=0 +1258 PRINT"THERE ARE"K9"KLINGONS REMAINING.":IFCY<>0THEN1355 +1259 PRINT"YOU HAVE FAILED !!":PRINT +1260 L=INT(RND(1)*5) +1261 ONL+1GOTO 1343,1346,1348,1350,1353 +1262 PRINT:INPUT"DO YOU WANT TO TRY AGAIN";X$ +1263 IF LEFT$(X$,1)="Y" THEN 1012 ELSE 1541 +1264 PRINT"THE FEDERATION IS SAVED !!" +1265 PRINT"YOU ARE HEREBY PROMOTED TO ADMIRAL!!!!":PRINT +1266 GOTO1262 +1267 DT=1 +1268 INPUT"COMPUTER ON--COMMAND";A +1269 IF A>=10 THEN PRINT AR$;" NO SUCH COMMAND !!":GOTO 1268 +1270 ONA+1GOTO1289,1294,1299,1283,1059,1339,1341,1510,1070 +1271 PRINT"FUNCTIONS AVAILABLE FROM COMPUTER" +1272 PRINT" 0 = GALACTIC MEMORY MAP" +1273 PRINT" 1 = GENERAL STATUS REPORT" +1274 PRINT" 2 = PHOTON TRAJECTORY" +1275 PRINT" 3 = NEW MISSION" +1276 PRINT" 4 = PRESENT POSITION" +1277 PRINT" 5 = SELF-DESTRUCT" +1278 PRINT" 6 = WARP-COMPASS" +1279 PRINT" 7 = MISSION PROGRESS REPORT" +1280 PRINT" 8 = EXIT COMPUTER" +1281 GOTO1267 +1282 PRINT:PRINT"--TEMPORARY MALFUNCTION--":GOTO 1070 +1283 IF XM<0 THEN 1287 +1284 PRINT AR$;"SAFETY CHECK -- DO YOU WISH TO ABORT MISSION":INPUT AN$ +1285 IF LEFT$(AN$,1)<>"Y" THEN 1288 ELSE 1012 +1286 PRINT +1287 PRINT"YOU HAVE NOT BEEN AUTHORIZED FOR NEW MISSION !!":PRINT +1288 GOTO 1267 +1289 PRINT"QUADRANT CODE MEMORY MAP" +1290 FORA=1TO:FORB=1TO8:IFG(A,B)=INT(G(A,B))THENPRINT" ???";:GOTO1293 +1291 PRINT" "SPC(3-LOG(G(A,B)+1)/LOG(10)); +1292 PRINTMID$(STR$(G(A,B)),2,LOG(G(A,B))/LOG(10)+1); +1293 NEXTB:PRINT" ":NEXTA:GOTO 1267 +1294 PRINT" STATUS REPORT" +1295 PRINT"NUMBER OF KLINGONS LEFT ="K9 +1296 PRINT"NUMBER OF STARDATES LEFT ="T9-T +1297 PRINT"NUMBER OF STARBASES LEFT ="B9 +1298 A=7:GOTO1074 +1299 IFK3=0THEN1226 +1300 IFD(2)<0THENA=2:GOTO1073 +1301 PRINT"COORD","LOWDIR","HIGHDIR","DIST" +1302 FORA=1TO47:PRINT"-";:NEXTA +1303 PRINT +1304 FORI=0TO3 +1305 IFNOT(K(I,3)>0)THEN1318 +1306 W1=SQR((S1-K(I,1))^2+(S2-K(I,2))^2) +1307 IF W1=0 THENPRINT"--->MALFUNCTION !":GOTO1070 +1308 ON ERROR GOTO 1282 +1309 C1=1.5708-ATN((K(I,2)-S2)/W1/SQR(1-((K(I,2)-S2)/W1)^2)) +1310 ON ERROR GOTO 1282 +1311 C1=C1*SGN(S1-K(I,1))/CX +1312 C2(I)=C1-(10*RND(1)) +1313 C3(I)=C1+(10*RND(1)) +1314 IF C3(I)<0 THEN C3(I)=C3(I)+360 +1315 IF C2(I)<0 THEN C2(I)=C2(I)+360 +1316 PRINT"(";MID$(STR$(K(I,1)),2,1);",";MID$(STR$(K(I,2)),2,1); +1317 PRINT")",C2(I),C3(I),W1 +1318 NEXTI +1319 IF DT=1 THEN 1267 ELSE 1070 +1320 RETURN +1321 MR=(T9-T)/K9:DT=0 +1322 XM=((MR-PR)/PR)*100 +1323 IFKA=1THENPRINTTK-T"STARDATES LEFT TO SAVE STARBASE.":GOTO1332 +1324 IFRND(1)>.01*R9ORB9=0THENRETURN +1325 KA=1:FORA=1TO8:FORB=1TO8 +1326 IFG(A,B)-100*INT(G(A,B)/100)>9THENK1=A:K2=B:IFRND(1)>.5THENA=8:B=8 +1327 NEXTB,A:TK=T+.09*SQR((Q1-K1)^2+(Q2-K2)^2)*(10-R9) +1328 TK=TK+1 +1329 PRINTAR$;"!!! STARBASE IN QUADRANT ("MID$(STR$(K1),2,1)","; +1330 PRINTMID$(STR$(K2),2,1)") IS UNDER ATTACK!!" +1331 PRINT"YOU HAVE"TK-T"STARDATES TO SAVE IT!":RETURN +1332 IFT1 THEN 1421 ELSE 1530 +1340 GOTO1070 +1341 GOSUB 1365 +1342 GOTO 1267 +1343 PRINT"YOU HAVE SCREWED UP ONCE TOO OFTEN !" +1344 PRINT"OFF TO THE VULCAN TORTURE CAMPS !!" +1345 IFT<= 0THEN1262ELSE1355 +1346 PRINT"YOU WILL BE EXECUTED AT SUNRISE" +1347 GOTO1355 +1348 PRINT"YOU WILL BE PUT TO DEATH FOR YOUR INCOMPETENCE" +1349 GOTO1355 +1350 PRINT"YOU WILL BE CONFINED TO YOUR QUARTERS UNTIL" +1351 PRINT"VULCAN'S MOONS BECOME TOURIST TRAPS !!" +1352 IFT<=0THEN1262ELSE1355 +1353 PRINT"IMBECILE !! WE HOPE YOU CONSIDER SUICIDE!" +1354 IFT<=0THEN1262ELSE1355 +1355 L=(U-K9)*10+((U-K9)*500/T)-100*(Y-B9) +1356 IFE<=0ORS<0THENL=L-200 +1357 IFK9=0THENL=L+(R9*100) +1358 PRINT:PRINT +1359 PRINT"YOUR MISSION RATING IS: ";L +1360 PRINT:PRINT:PRINT:PRINT:PRINT +1361 GOSUB 1543 +1362 PRINTCHR$(26) +1363 GOTO1544 +1364 GOTO1262 +1365 PRINT +1366 PRINT" O9O" +1367 PRINT" 135 . O45" +1368 PRINT" . . ." +1369 PRINT" . . ." +1370 PRINT"18O . . . . . . .OOO WARP-COMPASS" +1371 PRINT" . . ." +1372 PRINT" . . ." +1373 PRINT" 225 . 315" +1374 PRINT" 27O" +1375 PRINT +1376 RETURN +1377 XX=INT(RND(2)*10)+1 +1378 RETURN +1379 PRINT:IFX4>12THEN1388 +1380 PRINT"COMMAND CENTRAL ADVISES THAT YOUR RANKING-";X4;"-IS IN THE EXPERT" +1381 PRINT"CATEGORY. BE ADVISED THAT IF YOU ARE NOT PROPERLY QUALIFIED" +1382 PRINT"YOUR CHANCES OF AVOIDING FAILURE ARE NIL." +1383 PRINT +1384 PRINT"DO YOU WISH REASSIGNMENT TO A LESS HAZARDOUS MISSION (Y OR N)" +1385 INPUTAN$ +1386 IFLEFT$(AN$,1)="Y"THEN1012 +1387 PRINTCHR$(26):GOTO1023 +1388 PRINT"YOU HAVE REQUESTED A SUICIDE MISSION":GOTO1383 +1389 PRINT"--COMMUNICATIONS ACTIVE--" +1390 PRINT +1391 GOSUB1377 +1392 PD=XX +1393 GOSUB1377 +1394 PE=XX +1395 GOSUB1377 +1396 PF=XX +1397 GOSUB1377 +1398 PG=XX +1399 PH=PD*10+PE +1400 PJ=PF*10+PG +1401 IFPH=PJTHEN 1282 +1402 KP=1:IFPD=PEORPF=PGTHEN1403ELSE1405 +1403 PRINT"SUNSPOTS BLOCK TRANSMISSION AT : ":GOTO1060 +1404 PRINT"MOVE ELSEWHERE AND TRY AGAIN":PRINT:GOTO 1081 +1405 PRINT"AUTHORIZED FREQUENCIES":PRINT +1406 PRINT"FEDERATION COMMAND BASE = ";PH +1407 PRINT"KLINGON COMMAND CENTRAL = ";PJ +1408 PRINT +1409 INPUT"COMMUNICATION ON CHANNEL ";XF +1410 IFXF=PHTHEN1432 +1411 IFXF=PJTHEN1461 +1412 PRINT +1413 PRINTAR$;"ALERT !!" +1414 PRINT"ATTEMPTED COMMUNICATION ON UNAUTHORIZED FREQUENCY" +1415 PRINT +1416 PRINT"WHILE SECURITY CHECK IS CONDUCTED ON ENTERPRISE" +1417 GOSUB1377:A=XX +1418 GOSUB1377:I=(XX/2)+(X4/7) +1419 PRINT"YOUR ";D$(A);" WILL BE INOPERATIVE FOR ";I "UNITS OF STARTIME" +1420 D(A)=D(A)-I:GOTO1070 +1421 PRINT +1422 PRINT"SECURITY CONTROL ADVISES THAT NO AUTHORIZATION HAS BEEN" +1423 PRINT"GIVEN TO ACTIVATE SELF- DESTRUCT SYSTEM." +1424 PRINT"PROCEED WITH ASSIGNED MISSION":PRINT:GOTO 1268 +1425 PRINT +1426 PRINT"BE ADVISED, YOUR MISSION PROGRESS FACTOR IS";PR +1427 GOSUB 1377 +1428 TF=(XX*X4)/1.6:IF TF<10 THEN TF=TF+10 +1429 PRINT" THE TOLERANCE FACTOR FOR THIS MISSION IS [+/-]";TF;"PERCENT" +1430 PRINT +1431 RETURN +1432 ONSGN(XM)+2GOTO1433,1437,1439 +1433 IFABS(XM)>(TF*1.5)THEN1445 +1434 IFABS(XM)>TFTHEN1442 +1435 PRINT:PRINT"CAPTAIN, YOU ARE BEHIND SCHEDULE - LET'S GO !!" +1436 GOTO 1070 +1437 PRINT:PRINT"YOU ARE EXACTLY ON COMPUTED SCHEDULE; PROCEED WITH MISSION" +1438 GOTO1070 +1439 IFXM>TFTHEN1454:IFXM>(TF*1.5)THEN1457 +1440 PRINT:PRINT"YOU ARE AHEAD OF COMPUTED SCHEDULE, KEEP UP THE GOOD WORK !!" +1441 GOTO1070 +1442 PRINT:PRINT"YOU ARE BEHIND SCHEDULE AND OUT OF TOLERANCE FACTOR !!" +1443 PRINT"COMMAND CONTROL PROJECTS FAILURE...YOU MAY SURRENDER TO ENEMY" +1444 EQ=1:SD=1:GOTO 1389 +1445 YY=AC^X4 +1446 PRINTCHR$(26) +1447 PRINTAR$;"---------COMPUTER PROJECTION----------":PRINT +1448 PRINT"PROJECTED LIKELIHOOD OF SUCCESS FOR YOUR MISSION =";YY;"PERCENT" +1449 PRINT"WE HAVE AUTO ACTIVATED SELF-DESTRUCT SYSTEM ON YOUR VESSEL" +1450 PRINT"GOODBYE, CAPTAIN.............":PRINT +1451 PRINT"END OF MESSAGE FROM FEDERATION COMMAND":PRINT:PRINT +1452 GOSUB 1543 +1453 GOTO 1530 +1454 PRINT:PRINT"YOU ARE AHEAD OF SCHEDULE AND BEYOND TOLERANCE FACTOR" +1455 PRINT"CALL KLINGON LEADERS AND REQUEST THEIR SURRENDER":KQ=1 +1456 PRINT:GOTO1389 +1457 PRINTAR$;"MESSAGE FROM COMMAND BASE" +1458 PRINT:PRINT"ENEMY HAS SURRENDERED TO FEDERATION COMMAND !!" +1459 PRINT:PRINT:PRINT:PRINT +1460 GOTO1264 +1461 IF KQ=1 THEN 1486:IF EQ=1 THEN 1464 +1462 ON SGN(XM)+2 GOTO 1463,1469,1474 +1463 IF ABS(XM)<=TFTHEN1469 +1464 PRINT:PRINT"KLINGON COMMAND ON FREQUENCY" +1465 PRINT"NATURALLY, WE ARE PLEASED THAT YOU ARE CONCEDING, CAPTAIN" +1466 PRINT"WE ARE PRESENTLY BOARDING YOUR CRAFT" +1467 PRINT:PRINT"HERE IS A MESSAGE FROM YOUR LEADERS-":PRINT:GOSUB 1543 +1468 PRINTCHR$(26):GOTO 1260 +1469 GOSUB 1377 +1470 IFXX<=5THEN 1473 +1471 PRINT:PRINT"MESSAGE FROM KLINGON COMMAND...." +1472 PRINT"NO FURTHER COMMUNICATIONS AT THIS TIME":GOTO 1482 +1473 PRINT:PRINT"WE'LL TALK WITH OUR WEAPONS, EARTH-SWINE !!":GOTO 1482 +1474 GOSUB 1377 +1475 AQ=INT((XX+1)/2) +1476 ON AQ GOTO 1471,1473,1477,1477,1474 +1477 GF=TF*1.5 +1478 IFXM>GFTHEN 1486 +1479 IFXM>TFTHEN 1483 +1480 PRINT:PRINT"CAPTAIN, DESPITE YOUR SLIGHT ADVANTAGE, YOU ARE NO MATCH FOR" +1481 PRINT"THE GLORIOUS KLINGON FLEET" +1482 PRINTTAB(25)"END OF MESSAGE FROM KLINGON COMMAND":GOTO1070 +1483 GOSUB1377 +1484 IFXX<=5THENPRINT" KLINGON COMMAND TO ENTERPRISE..":GOTO1473 +1485 GOTO1487 +1486 PRINTCHR$(26) +1487 PRINT:PRINT"MESSAGE FROM KLINGON LEADERS..." +1488 PRINT:PRINT"WE CONCEDE THE WAR, SIR, CONGRATULATIONS !!":GOTO1360 +1489 AV=INT(X4/2)+1:DR=-1 +1490 IF TEC"D" THEN 1496 ELSE 1498 +1492 AU=AV-TEC:IFAU=1THENKF$=""ELSEKF$="S" +1493 PRINT:PRINT"DAMAGE REPAIR INACTIVE !!" +1494 PRINT"REQUIRES";AU;"MORE RECHARGE UNIT";KF$ +1495 PRINT:GOTO 1070 +1496 PRINT:PRINTAR$"YOU MUST BE DOCKED AT STARBASE FOR DAMAGE REPAIR !!" +1497 PRINT:GOTO 1070 +1498 PRINT +1499 PRINT:FORA=1TO10 +1500 IFD(A)<0THENPRINT TAB(10)A;TAB(20)D$(A);TAB(40)"DAMAGED" +1501 NEXT +1502 PRINT:PRINT"IF NO DAMAGE INDICATED ABOVE, ANSWER WITH 0 (ZERO)" +1503 INPUT "WHICH ONE TO REPAIR ";A +1504 IFA<1ORA>10THENPRINTAR$;:GOTO 1070 +1505 IF D(A)<0 THEN 1507 +1506 PRINT:PRINTD$(A);" NOT DAMAGED !!":GOTO 1503 +1507 PRINT:PRINTTAB(20)D$(A);"---REPAIRED":PRINT +1508 D(A)=0:TEC=0:GOTO1070 +1509 PRINT:PRINTAR$;"NOTHING DAMAGED AT PRESENT":GOTO1070 +1510 PRINT +1511 GOSUB1429 +1512 PRINT"INITIAL MISSION PROGRESS FACTOR WAS";PR +1513 PRINT"CURRENT MISSION PROGRESS FACTOR IS ";MR +1514 IF XM<0 THEN PW$=" WORSENED "ELSE PW$=" IMPROVED " +1515 PRINT +1516 PRINT"YOUR COMBAT SITUATION HAS";PW$;"BY A FACTOR OF";XM;"PERCENT" +1517 IF ABS(XM)>=TF THEN EG$=" NOT "ELSE EG$=" " +1518 IF EG$=" "THEN EH$=""ELSE EH$=AR$ +1519 PRINT EH$;"YOUR PROGRESS IS";EG$;"WITHIN TOLERANCE FOR THIS MISSION" +1520 PRINT +1521 IF EG$=" NOT "THEN 1522 ELSE 1267 +1522 IF XM<0 THEN 1523 ELSE 1527 +1523 PRINT:SD=1:KD=0 +1524 PRINT"CAPTAIN, COMMAND CENTRAL PROJECTS DEFEAT BY ENEMY. YOU ARE NOW" +1525 PRINT"AUTHORIZED TO SURRENDER OR TO ACTIVATE SELF-DESTRUCT SYSTEM" +1526 GOTO1267 +1527 PRINT:SD=0:KD=1 +1528 PRINT"CAPTAIN, FEDERATION COMMAND PROJECTS SUCCESS FOR YOUR MISSION." +1529 GOTO 1454 +1530 PRINTCHR$(26) +1531 GOSUB 1542 +1532 PRINT"SELF DESTRUCT SYSTEM ACTIVATED" +1533 PRINT:PRINT:PRINT:GOSUB 1542 +1534 PRINT"COUNTDOWN BEGUN !":PRINT:PRINT +1535 PRINTTAB(25)"FIVE":PRINT:GOSUB 1542 +1536 PRINTTAB(20)"FOUR":PRINT:GOSUB 1542 +1537 PRINTTAB(15)"THREE":PRINT:GOSUB 1542 +1538 PRINTTAB(10)"TWO":PRINT:GOSUB 1542 +1539 PRINTTAB(5)"ONE":PRINT:GOSUB 1542 +1540 PRINT"ZERO":GOSUB 1542 +1541 PRINTCHR$(26):GOTO1544 +1542 FOR I=1 TO 50:A=A+1:NEXT:RETURN +1543 FOR I=1 TO 1200:A=A+1:NEXT:RETURN +1544 RESET + \ No newline at end of file diff --git a/disks/images/b/SWARMS.ASC b/disks/images/b/SWARMS.ASC new file mode 100644 index 0000000..8691f0f --- /dev/null +++ b/disks/images/b/SWARMS.ASC @@ -0,0 +1,520 @@ +100 'SWARMS2 - YET ANOTHER GEM FROM 'ZOSO' +110 CLEAR : CLEAR 1000 +120 PRINT CHR$(26);"!!!!! ATTENTION: THE BEES ARE ATTACKING !!!!!!" +130 PRINT : PRINT +140 PRINT "BEGIN DEFENSE PLAN: " : PRINT +150 PRINT "TIME: 1" +160 INPUT "ENTER YOUR NAME FOR IDENTIFICATION CHECK"; N$ +170 PRINT CHR$(26) +180 INPUT "ENTER CODE WORD FOR NUCLEAR CLEARANCE"; C$ +190 GOSUB 5220 +200 REM CREATE TWO INITIAL SWARMS +210 DIM E(21),S(21),A$(21),U(21),G(21),M(21),D(21),C(21) +220 DIM K(21),V(21),R(21) +230 A1=INT(RND(1)*21+1) +240 A2=INT(RND(1)*21+1) +250 IF A1=A2 THEN 230 +260 S(A1) = INT(RND(1)*5+2) +270 S(A2) = INT(RND(1)*5+2) +280 E(A1) = INT(RND(1)*9+6) +290 E(A2) = INT(RND(1)*9+6) +300 REM SUBTRACT ONE HOUR FROM ALL ETA'S +310 FOR A=1 TO 21 +320 IF E(A)=0 THEN 340 +330 GOTO 350 +340 IF U(A) = 0 THEN 560 +350 IF S(A) = 1 THEN 560 +360 IF ABS(U(A)) = 1 THEN 470 +370 IF ABS(E(A)) = 1 THEN 410 +380 E(A)=E(A) - 1 +390 C(A)=C(A)+(17-E(A)) +400 GOTO 560 +410 IF E(A) = -1 THEN 450 +420 PRINT "THE BEES HAVE ARRIVED IN THE MAJOR CITY IN SECTION ";A +430 E(A)=-1 +440 U(A)=6 +450 U(A)=U(A)-1 +460 GOTO 560 +470 IF U(A) = -1 THEN 560 +480 PRINT "THE BEES HAVE DESTROYED THE MAJOR CITY IN SECTION ";A +490 U(A)=-1 +500 IF V(A)<>-1 THEN 530 +510 PRINT "BUT THE POPULATION HAS BEEN EVACUATED" +520 GOTO 550 +530 K(A)=1 +540 C(A)=(1E+06*(RND(1)*A+1))+C(A) +550 GOTO 560 +560 NEXT A +570 REM ADD ONE UNIT TO TIME +580 T=T+1 +590 REM CREATE NEW SWARM +600 IF T/30<>INT(T/30) THEN 690 +610 A=INT(RND(1)*21+1) +620 IF S(A)<>0 THEN 600 +630 IF R(A)<>0 THEN 600 +640 IF K(A)<>0 THEN 600 +650 S(A)=INT(RND(1)*5+2) +660 E(A)=INT(RND(1)*9+16) +670 C(A)=INT(RND(1)*10) +680 PRINT "A NEW SWARM IS REPORTED IN SECTION ";A +690 REM CHECK COMBATED SWARMS +700 FOR A=1 TO 21 +710 IF T<>G(A) THEN 870 +720 IF S(A)<> 1 THEN 810 +730 S(A)=0 +740 G(A)=0 +750 E(A)=0 +760 M(A)=0 +770 K(A)=0 +780 U(A)=0 +790 PRINT "** THE SWARM IN SECTION ";A;" IS TOTALLY DESTROYED." +800 GOTO 870 +810 S(A)=S(A)-M(A) +820 PRINT "** THE PHASE ON SECTION ";A;" WAS SUCCESSFUL." +830 IF S(A)>=1 THEN 850 +840 S(A)=1 +850 G(A)=0 +860 M(A)=0 +870 NEXT A +880 REM ADD ONE UNIT TO EACH UNCOMBATTED SWARM +890 FOR A=1 TO 21 +900 IF E(A)=1 THEN 1150 +910 IF S(A)=1 THEN 1120 +920 IF S(A)=0 THEN 1150 +930 IF S(A)+1<9 THEN 1090 +940 IF A=1 THEN 1020 +950 IF S(A-1)>0 THEN 1010 +960 IF R(A-1)<>0 THEN 1150 +970 PRINT "** THE SWARM IN SECTION ";A;" HAS SPREAD TO SECTION ";A-1 +980 S(A-1)=3 +990 E(A-1)=INT(RND(1)*10+5) +1000 GOTO 1150 +1010 IF A=21 THEN 1150 +1020 IF S(A+1)>0 THEN 1150 +1030 IF R(A+1)<>0 THEN 1150 +1040 PRINT "** THE SWARM IN SECTION ";A;" HAS SPREAD TO SECTION ";A+1 +1050 IF R(A+1)<>0 THEN 1150 +1060 S(A+1)=3 +1070 E(A+1)=INT(RND(1)*10+5) +1080 GOTO 1150 +1090 S(A)=S(A)+1 +1100 C(A)=C(A)+S(A) +1110 GOTO 1150 +1120 IF D(A)=1 THEN 1150 +1130 PRINT "** THE SWARM IN SECTION ";A;" IS READY TO BE DESTROYED." +1140 D(A)=1 +1150 NEXT A +1160 REM WINNER CHECK +1170 W=0 +1180 FOR A=1 TO 21 +1190 W=S(A)+W +1200 NEXT A +1210 IF W>=1 THEN 1280 +1220 PRINT "*******ALL SWARMS ARE NOW DESTROYED*******" +1230 PRINT "FINAL STATISTICS ON ATTACKS AND DESTRUCTION ARE NOW " +1240 PRINT "BEING COMPUTED, ... FINAL RESULTS FOLLOW ....." +1250 A=0 +1260 PRINT +1270 GOTO 4690 +1280 REM EVACUATION CHECK +1290 FOR A=1 TO 21 +1300 IF V(A)<>T THEN 1400 +1310 IF U(A)=-1 THEN 1370 +1320 IF K(A)>0 THEN 1370 +1330 PRINT "** POPULATION IN SECTION ";A;" IS EVACUATED" +1340 C(A)=C(A)+INT(RND(1)*17) +1350 V(A)=-1 +1360 GOTO 1400 +1370 PRINT "** POPULATION IN SECTION ";A;" WAS DESTROYED BEFORE " +1380 PRINT " IT COULD BE EVACUATED" +1390 V(A)=0 +1400 NEXT A +1410 REM RETURN EVACUATION CHECK +1420 FOR A=1 TO 21 +1430 IF R(A)<>T THEN 1490 +1440 IF R(A)<1 THEN 1490 +1450 K(A)=0 +1460 R(A)=0 +1470 V(A)=0 +1480 PRINT "** THE POPULATION HAS RETURNED TO THE CITY IN SECTION ";A +1490 NEXT A +1500 REM LOSER CHECK +1510 Q=0 +1520 FOR A=1 TO 21 +1530 Q=C(A)+Q +1540 NEXT A +1550 IF Q<7.5E+07 THEN 1650 +1560 PRINT "THE BEES HAVE DEVASTATED THE UNITED STATES AND " +1570 PRINT "THERE ARE NOW OVER 75 MILLION CASUALTIES, THE BEES" +1580 PRINT "ARE NOW CONSIDERED TO BE THE VICTORS OVER MODERN" +1590 PRINT "TECHNOLOGY." +1600 A=0 +1610 Q=0 +1620 W=0 +1630 PRINT +1640 GOTO 4690 +1650 REM COMMAND INPUT +1660 PRINT "TIME: ";T+1 +1670 INPUT "COMMAND"; COM +1680 IF COM>8 OR COM<1 OR COM<>INT(COM) THEN PRINT "WRONG !!!"; : GOTO 1670 +1690 ON COM GOTO 1700,2210,2620,3840,4060,4660,4920,5190 +1700 REM MAP PRINT OUT +1710 PRINT CHR$(26);"1) ATTACK SCAN MAP" +1720 PRINT +1730 FOR A=1 TO 21 +1740 IF S(A)>6 THEN 1860 +1750 IF S(A)>4 THEN 1840 +1760 IF S(A)>1 THEN 1820 +1770 IF S(A)>0 THEN 1800 +1780 A$(A)= "?" +1790 GOTO 1870 +1800 A$(A)="." +1810 GOTO 1870 +1820 A$(A)="+" +1830 GOTO 1870 +1840 A$(A)="*" +1850 GOTO 1870 +1860 A$(A)="#" +1870 NEXT A +1880 PRINT "----------------------------------------------------" +1890 PRINT TAB(48);"---" +1900 PRINT TAB(20);"CANADA- NO INFORMATION / /" +1910 Z1$="----------------------- / "+A$(18)+"/" +1920 PRINT TAB(15);Z1$ +1930 PRINT TAB(15);"! ! ! ! ! !\- -/ /" +1940 Z1$="! "+A$(1)+" ! "+A$(3)+" ! "+A$(6)+" ! " +1950 Z1$=Z1$+A$(9)+" ! "+A$(13)+" ! \--/---/" +1960 PRINT TAB(15);Z1$ +1970 Z1$= "! !---!---!----!----! "+A$(16)+" ! /" +1980 PRINT TAB(15);Z1$ +1990 Z1$= "!---! ! ! ! ! ! "+A$(19)+" !" +2000 PRINT TAB(15);Z1$ +2010 Z1$="! ! "+A$(4)+" ! "+A$(7)+" ! "+A$(10)+" ! " +2020 Z1$=Z1$+A$(14)+" !---!---!" +2030 PRINT TAB(15);Z1$ +2040 Z1$="! "+A$(2)+" !---!---!----!----! ! !" +2050 PRINT TAB(15);Z1$ +2060 Z1$=" \ ! ! ! ! ! "+A$(17)+" ! "+A$(20)+" !" +2070 PRINT TAB(15);Z1$ +2080 Z1$=" \ ! "+A$(5)+" ! "+A$(8)+" ! "+A$(11)+" ! " +2090 Z1$=Z1$+A$(15)+" ! ! /" +2100 PRINT TAB(15);Z1$ +2110 Z1$=" \!---!---!----!----!---! "+A$(21)+"!" +2120 PRINT TAB(15);Z1$ +2130 PRINT TAB(27);"\ !";TAB(42);"\ !" +2140 Z1$=" \ "+A$(12)+"!" +2150 PRINT TAB(15);Z1$;TAB(42);"! !" +2160 PRINT TAB(30);"\-!";TAB(42);"!-!" +2170 PRINT TAB(20);"MEXICO- NO INFORMATION" +2180 PRINT +2190 PRINT "----------------------------------------------------" +2200 GOTO 300 +2210 REM ETA REPORT +2220 PRINT CHR$(12);"2) ETA REPORT" +2230 PRINT +2240 INPUT "ENTER SECTION #"; A +2250 IF A<1 OR A>21 OR A<>INT(A) THEN PRINT "WRONG !!!"; : GOTO 2240 +2260 PRINT "*************************************" +2270 IF A<>0 THEN 2300 +2280 D7=-1 +2290 FOR A = 1 TO 21 +2300 IF S(A)=1 THEN 2520 +2310 IF R(A)=-1 THEN 2550 +2320 IF E(A)=0 THEN 2500 +2330 IF U(A)=-1 THEN 2380 +2340 IF E(A)=-1 THEN 2410 +2350 PRINT "THE BEES WILL ARRIVE AT THE MAJOR CITY IN" +2360 PRINT " SECTION ";A;" AT ";E(A)+T;" HOURS." +2370 GOTO 2570 +2380 PRINT "THE BEES HAVE ALREADY DESTROYED THE CITY IN" +2390 PRINT "SECTION ";A;" AND ARE NOW INHABITING IT." +2400 GOTO 2570 +2410 PRINT "THE BEES HAVE ARRIVED AT THE CITY IN" +2420 IF V(A)<>-1 THEN 2460 +2430 PRINT "SECTION ";A;" BUT THE POPULATION HAS BEEN" +2440 PRINT " EVACUATED" +2450 GOTO 2570 +2460 PRINT "SECTION ";A;" AND THE POPULATION OF THAT CITY" +2470 PRINT "CAN ONLY SURVIVE FOR ABOUT ";U(A);" MORE HOURS." +2480 PRINT " USE OF URBAN DEFENSES IS RECOMMENDED." +2490 GOTO 2570 +2500 PRINT " NO SWARMS REPORTED IN SECTION ";A +2510 GOTO 2570 +2520 PRINT "THE BEES IN SECTION ";A;" ARE READY TO BE " +2530 PRINT "DESTROYED." +2540 GOTO 2570 +2550 PRINT "SECTION ";A;" IS A RADIOACTIVE WASTELAND THAT" +2560 PRINT " IS COMPLETELY UNPOPULATED" +2570 PRINT "*************************************" +2580 IF D7<>-1 THEN 2600 +2590 NEXT A +2600 D7=0 +2610 GOTO 300 +2620 REM BATTLE PHASE OPTIONS +2630 PRINT CHR$(26) +2640 PRINT "3) BATTLE PHASE OPTIONS" +2650 INPUT "ENTER SECTION #"; A +2660 INPUT "ENTER PHASE"; P +2670 IF V(A)<1 THEN 2700 +2680 PRINT "SECTION ";A;" IS BEING EVACUATED" +2690 GOTO 300 +2700 IF G(A)>0 THEN 2720 +2710 GOTO 2740 +2720 PRINT "THE SWARM IN SECTION ";A;" IS ALREADY BEING COMBATTED" +2730 GOTO 300 +2740 IF S(A)=0 THEN 2760 +2750 GOTO 2780 +2760 PRINT "NO SWARM IS REPORTED IN SECTION ";A +2770 GOTO 300 +2780 IF S(A)<>1 THEN 2820 +2790 IF P=5 THEN 2860 +2800 PRINT "THE DESTRUCTION PHASE SHOULD BE USED IN SECTION ";A +2810 GOTO 300 +2820 IF E(A)<>-1 THEN 2860 +2830 IF P=6 THEN 2860 +2840 PRINT "URBAN DEFENSES SHOULD BE USED IN SECTION ";A +2850 GOTO 300 +2860 N=RND(1) +2870 ON P GOTO 2880,2970,3060,3120,3210,3290 +2880 REM PHASE 1 +2890 PRINT "BEE COCKTAIL: PHASE ONE, NOW BEING ATTEMPTED." +2900 IF N>.95 THEN 300 +2910 G(A)=T+INT(RND(1)*3+1) +2920 IF S(A)>5 THEN 2950 +2930 M(A)=S(A)-2 +2940 GOTO 300 +2950 M(A)=S(A)-5 +2960 GOTO 300 +2970 REM PHASE TWO +2980 PRINT "PROJECT QUEEN: PHASE TWO, NOW BEING ATTEMPTED." +2990 IF N>.92 THEN 300 +3000 G(A) = T+INT(RND(1)*3+4) +3010 IF S(A)>3 THEN 3040 +3020 M(A)=1 +3030 GOTO 300 +3040 M(A)=S(A)-1 +3050 GOTO 300 +3060 REM PHASE THREE +3070 PRINT "PROJECT BRUSH FIRE: PHASE THREE, NOW BEING ATTEMPTED." +3080 IF N>.96 THEN 300 +3090 G(A)=T+1 +3100 M(A)=2 +3110 GOTO 300 +3120 REM PHASE 4 +3130 PRINT "PROJECT STERILE MALE: PHASE FOUR, NOW BEING ATTEMPTED." +3140 IF N>.89 THEN 300 +3150 G(A)=T+INT(RND(1)*3+3) +3160 IF S(A)>6 THEN 3190 +3170 M(A)=S(A)-1 +3180 GOTO 300 +3190 M(A)=4 +3200 GOTO 300 +3210 REM PHASE 5 +3220 IF S(A)=1 THEN 3250 +3230 PRINT "SWARM TOO LARGE: DESTRUCTION NOT POSSIBLE" +3240 GOTO 300 +3250 PRINT "DESTRUCTION: PHASE FIVE, NOW BEING ATTEMPTED." +3260 IF N>.7 THEN 300 +3270 G(A)=T+INT(RND(1)*3+2) +3280 GOTO 300 +3290 REM PHASE 6 +3300 IF E(A)<>-1 THEN 2800 +3310 INPUT "ENTER URBAN DEFENSE CODE"; D$ +3320 C(A)=C(A)+INT(200*RND(1)) +3330 IF RND(1) >.8 THEN 300 +3340 IF D$="A" THEN 3430 +3350 IF D$="B" THEN 3490 +3360 IF D$="C" THEN 3550 +3370 IF D$="D" THEN 3610 +3380 IF D$="E" THEN 3670 +3390 IF D$="F" THEN 3710 +3400 IF D$="G" THEN 3750 +3410 PRINT "INVALID URBAN DEFENSE CODE !!!" : PRINT : GOTO 3310 +3420 GOTO 300 +3430 REM *A* +3440 IF S(A)>5 THEN 3470 +3450 S(A)=S(A)-1 +3460 GOTO 3780 +3470 S(A)=2 +3480 GOTO 3780 +3490 REM *B* +3500 IF S(A)>4 THEN 3530 +3510 S(A)=S(A)-3 +3520 GOTO 3780 +3530 S(A)=S(A)-2 +3540 GOTO 3780 +3550 REM *C* +3560 IF S(A)>7 THEN 3590 +3570 S(A)=S(A)-3 +3580 GOTO 3780 +3590 S(A)=1 +3600 GOTO 3780 +3610 REM *D* +3620 IF S(A)>3 THEN 3650 +3630 S(A)=1 +3640 GOTO 3780 +3650 S(A)=S(A)-3 +3660 GOTO 3780 +3670 REM *E* +3680 IF RND(1)>.5 THEN 3780 +3690 S(A)=2 +3700 GOTO 3780 +3710 REM *F* +3720 IF RND(1)>.4 THEN 3780 +3730 S(A)=1 +3740 GOTO 3780 +3750 REM *G* +3760 IF RND(1)>.8 THEN 3780 +3770 S(A)=S(A)-4 +3780 PRINT "THE URBAN DEFENSE IN SECTION ";A;" WAS SUCCESSFUL" +3790 IF S(A)>1 THEN 300 +3800 S(A)=1 +3810 D(A)=1 +3820 PRINT "** SWARM IN SECTION ";A;" IS READY TO BE DESTROYED" +3830 GOTO 300 +3840 REM EVACUATION PROCEDURE +3850 PRINT CHR$(26); +3860 PRINT "4) EVACUATION PROCEDURE" +3870 INPUT "ENTER SECTION #"; A +3880 IF A<1 OR A>21 OR A<>INT(A) THEN PRINT "WRONG !!! "; : GOTO 3870 +3890 IF S(A)=0 THEN 3950 +3900 IF V(A)>0 THEN 3970 +3910 IF V(A)=-1 THEN 3990 +3920 IF K(A)>0 THEN 4010 +3930 IF U(A)=-1 THEN 4010 +3940 GOTO 4030 +3950 PRINT "COMPUTER FAILSAFE...NO SWARMS REPORTED IN SECTION ";A +3960 GOTO 300 +3970 PRINT "SECTION ";A;" IS BEING EVACUATED ALREADY" +3980 GOTO 300 +3990 PRINT "CITY IN SECTION ";A;" IS ALREADY EVACUATED" +4000 GOTO 300 +4010 PRINT "POPULATION IN SECTION ";A;" HAS BEEN DESTROYED" +4020 GOTO 300 +4030 PRINT "EVACUATION PROCEDURE NOW IN PROGRESS" +4040 V(A)=5+T +4050 GOTO 300 +4060 REM ***** NUCLEAR DESTRUCTION SEQUENCE ***** +4070 PRINT CHR$(26) +4080 PRINT "5) NUCLEAR DESTRUCTION SEQUENCE" +4090 INPUT "PLEASE ENTER YOUR NAME"; N1$ +4100 IF N$<>N1$ THEN 4270 +4110 INPUT "PLEASE ENTER YOUR CODE WORD"; C1$ +4120 IF C$<>C1$ THEN 4270 +4130 PRINT "POSITIVE IDENTIFICATION CHECK";CHR$(7) +4140 PRINT "CODE WORD CHECK IS VALID" +4150 PRINT "ID SEQUENCE COMPLETED" +4160 INPUT "PLEASE ENTER SECTION #"; A +4170 IF A<1 OR A>21 OR A<>INT(A) THEN PRINT "WRONG !!! "; : GOTO 4160 +4180 IF E(A)<>-1 THEN 4220 +4190 IF S(A)=0 THEN 4250 +4200 PRINT +4210 GOTO 4310 +4220 PRINT "COMPUTER FAILSAFE: BEES NOT ARRIVED IN THE MAJOR" +4230 PRINT "CITY IN SECTION ";A +4240 GOTO 300 +4250 PRINT "COMPUTER FAILSAFE: NO SWARM REPORTED IN SECTION ";A +4260 GOTO 300 +4270 PRINT "ID SEQUENCE DEFAULT....IGNORED" +4280 GOTO 300 +4290 PRINT "NUCLEAR DESTRUCTION ABORTED." +4300 GOTO 300 +4310 PRINT "BOMB IN SECTION ";A;" IS NOW ACTIVE" +4320 IF K(A)=1 THEN 4370 +4330 IF V(A)=-1 THEN 4370 +4340 PRINT "SECTION ";A;" HAS NOT BEEN EVACUATED" +4350 INPUT "DO YOU WISH TO CONTINUE"; K$ +4360 IF LEFT$(K$,1)="Y" THEN 4370 ELSE 4290 +4370 INPUT "TYPE 'X' FOR BOMB DETONATION"; F$ +4380 IF F$<>"X" THEN 4290 +4390 PRINT CHR$(26) +4400 PRINT "!!!!!!!!!!!!!!!! BOMB DETONATED !!!!!!!!!!!!!!!!" +4410 PRINT "SWARM HAS BEEN DESTROYED!!!!!!!!!" +4420 PRINT "CITY HAS BEEN DESTROYED!!!!!!!!!!" +4430 C(A)=2413 +4440 S(A)=0 +4450 E(A)=0 +4460 U(A)=0 +4470 D(A)=0 +4480 G(A)=0 +4490 M(A)=0 +4500 IF K(A)=1 THEN 4590 +4510 IF V(A)<>-1 THEN 4580 +4520 PRINT "THE POPULATION WILL MOVE BACK TO THE CITY" +4530 PRINT "IN SECTION ";A;" WHEN THE RADIATION LEVEL" +4540 PRINT "HAS DECREASED." +4550 K(A)=2 +4560 R(A)=T+7 +4570 GOTO 300 +4580 C(A)=INT(2E+06*(RND(1)*A+1))+C(A) +4590 PRINT "** NO SURVIVORS ARE REPORTED IN SECTION ";A +4600 PRINT "** THE BEES WILL NOT ENTER A SECTION WITH" +4610 PRINT "** NO HUMAN INHABITANTS, SO SECTION ";A +4620 PRINT "** IS COMPLETELY LACKING LIFE OF ANY KIND." +4630 K(A)=2 +4640 R(A)=-1 +4650 GOTO 300 +4660 REM CASUALTY REPORT +4670 PRINT CHR$(26);"6) CASUALTY REPORT" +4680 INPUT "ENTER SECTION #"; A +4690 PRINT "************************************" +4700 IF A<>0 THEN 4750 +4710 D7=-1 +4720 FOR A=1 TO 21 +4730 IF C(A)=0 THEN 4770 +4740 IF C(A)>=1E+06 THEN 4790 +4750 PRINT "SECTION ";A;": ";C(A);" CASUALTIES REPORTED" +4760 GOTO 4800 +4770 PRINT "SECTION ";A;": NO BEE RELATED CASUALTIES" +4780 GOTO 4800 +4790 PRINT "SECTION ";A;": ";C(A)/1E+06;" MILLION CASUALTIES" +4800 PRINT "************************************" +4810 F=C(A)+F +4820 IF D7<>-1 THEN 4890 +4830 NEXT A +4840 D7=0 +4850 IF F<1E+06 THEN 4880 +4860 PRINT "TOTAL CASUALTIES REPORTED: ";F/1E+06;" MILLION CASUALTIES" +4870 GOTO 4890 +4880 PRINT "TOTAL CASUALTIES REPORTED: ";F +4890 IF W=0 THEN 5200 +4900 F=0 +4910 GOTO 300 +4920 REM PRINT COMMANDS IN SHORT +4930 PRINT CHR$(26) +4940 PRINT "************************COMMANDS*********************" +4950 PRINT +4960 PRINT " 1) ATTACK SCAN MAP" +4970 PRINT " 2) ETA REPORT" +4980 PRINT " 3) BATTLE PHASE OPTIONS" +4990 PRINT " 1. BEE COCKTAIL" +5000 PRINT " 2. PROJECT QUEEN" +5010 PRINT " 3. PROJECT BRUSH FIRE" +5020 PRINT " 4. PROJECT STERILE MALE" +5030 PRINT " 5. DESTRUCTION" +5040 PRINT " 6. URBAN DEFENSES" +5050 PRINT " A) FLIGHT PATTERNS" +5060 PRINT " B) SONIC BOOM" +5070 PRINT " C) SUPER-SONIC BEAMS" +5080 PRINT " D) POLLUTION" +5090 PRINT " E) METHYL PARATHION" +5100 PRINT " F) FIRE WALL" +5110 PRINT " G) STROBE LIGHT" +5120 PRINT " 4) EVACUATION PROCEDURES" +5130 PRINT " 5) NUCLEAR DESTRUCTION" +5140 PRINT " 6) CASUALTY REPORT" +5150 PRINT " 7) COMMANDS (SHORT)" +5160 PRINT " 8) CANCEL GAME" +5170 GOTO 300 +5180 REM GAME CANCELLED +5190 REM +5200 REM +5210 RESET : END +5220 X9=LEN(N$) : X8=LEN(C$) +5230 X7=RND(-X9) : X7=X9+X8 +5240 FOR X9=1 TO X7+1 : X8=RND(1) : NEXT +5250 RETURN +RESET : END +5220 X9=LEN(N$) : X8=LEN(C$) +5230 X7=RND(-X9) : X7=X9+X8 +5240 \ No newline at end of file diff --git a/disks/images/b/TREKMOD.ASC b/disks/images/b/TREKMOD.ASC new file mode 100644 index 0000000..c896ca7 --- /dev/null +++ b/disks/images/b/TREKMOD.ASC @@ -0,0 +1,1279 @@ +10 'BASED ON BIGTREK GAME / SHORTENED BY EDISON DOGGE. +20 WIDTH90:LQ=1000'REM NO SCORE - NO VISUALS +30 INPUT"CLEARANCE NUMBER (1 TO 25000)...";I +40 IFI<1ORI>25000ORI<>INT(I)THEN30 +50 I1=IMOD97:IFI1=0THENI=I+199:GOTO50 +60 I=RND(-I1):FORI1=1TOI:X=RND(1):NEXT +70 DIM G1$(16),V$(5,5),C$(20),G(8,8),D$(12),Q$(10,10),D4(12),D9(106) +80 DIM S2(8,8):Q$="?" +90 DATA S.R. SENSORS,L.R. SENSORS,PHASERS,PHOTON TUBES,LIFE SUPPORT +100 DATA WARP ENGINES,IMPULSE ENGINES,SHIELDS,SUBSPACE RADIO +110 DATA SHUTTLE CRAFT,COMPUTER,TRANSFER PANEL,ABANDON,CHART,COMPUTER +120 DATA DAMAGES,DESTRUCT,DOCK,IDLE,IMPULSE,LRSCAN,NAVIGATE,PHASERS,QUIT +130 DATA SHIELDS,SOS,SRSCAN,STATUS,TORPEDO,TRANSFER,VISUAL,WARP,SHORT +140 DATA MEDIUM,LONG,BEGINNER,NOVICE,SENIOR,EXPERT,COURSE,WCOST,ICOST +150 DATA PEFFECT,OUT,ANTARES,SIRIUS,RIGEL,MERAK,PROCYON,CAPELLA +160 DATA VEGA,DENEB,CANOPUS,ALDEBARAN,ALTAIR,REGULUS,BELLATRIX,ARCTURUS +170 DATA POLLUX,SPICA,10.5,12,1.5,9,0,3,7.5,6,4.5 +180 DEF FNA(X)=INT(8*RND(X))+1:DEF FNB(X)=INT(10*RND(X))+1 +190 DEF FND(X)=X/60 +200 DEFFNR(X)=INT(X*10+.5)/10:DEFFNS(X)=INT(X*100+.5)/100 +210 FORI=1TO12:READD$(I):NEXT:FORI=1TO20:READC$(I):NEXT +220 FORI=1TO3:READT$(I):NEXT:FORI=1TO4:READS$(I):NEXT:FORI=1TO5 +230 READC2$(I):NEXT:FORI=1TO16:READG1$(I):NEXT:FORI=1TO9:READC5(I):NEXT +240 GOSUB9760:S7$(1)="":S7$(2)=" ":S7$(3)=" ":S7$(4)="" +250 IFA2<>0THEN760 +260 J4=0:T1=0:INPUT"COMMAND";A$:IFLEN(A$)>1THEN280 +270 PRINT"2 LETTERS, PLEASE.":GOTO260 +280 FORI=1TO20 +290 IFA$=LEFT$(C$(I),LEN(A$))THEN350 +300 NEXT +310 PRINT"ILLEGAL !! - USE THIS LIST" +320 PRINT:FORI=1TO20STEP4 +330 PRINTC$(I);TAB(12);C$(I+1);TAB(22);C$(I+2);TAB(32);C$(I+3) +340 NEXT:PRINT:GOTO250 +350 ONIGOTO370,380,390,400,410,420,430,470,490,500 +360 ONI-10GOTO530,760,550,580,590,600,610,620,660,670 +370 GOSUB 12310:GOTO250 +380 GOSUB 2020:GOTO250 +390 GOSUB2540:GOTO250 +400 GOSUB3540:GOTO250 +410 GOSUB12550:GOTO250 +420 GOSUB3430:GOTO250 +430 GOSUB11700:IFJ3=0THEN250 +440 IFA2<>0THEN760 +450 IFG(Q1,Q2)=1000THEN720 +460 GOSUB790:GOTO250 +470 GOSUB5390:IFJ3=0THEN250 +480 GOTO680 +490 GOSUB5650:GOTO250 +500 GOSUB11830 +510 IFJ3=0THEN250 +520 GOTO680 +530 GOSUB8270:IFJ3=0THEN250 +540 GOSUB790:GOTO250 +550 GOSUB10370:IFJ3=0THEN250 +560 IFA2<>0THEN760 +570 GOSUB790:S9=0:GOTO250 +580 GOSUB4720:GOTO250 +590 GOSUB11090:GOSUB5650:GOTO250 +600 PRINT:GOSUB12770:GOTO250 +610 GOSUB8660:IFJ3=0THEN250ELSE680 +620 GOSUB11560:IFJ3=0THEN250 +630 IFA2<>0THEN760 +640 IFG(Q1,Q2)<>LQTHEN250 +650 GOTO720 +660 PRINT:PRINT"VISUAL INOPERATIVE !":RETURN +670 GOSUB10210:GOTO250 +680 IFA2<>0THEN760 +690 IFT1<>0THENGOSUB3640 +700 IFA2<>0THEN760 +710 IFG(Q1,Q2)0THEN760 +730 IFA2<>0THEN760 +740 GOTO710 +750 GOSUB790:GOTO250 +760 PRINT:PRINT:INPUT"ANOTHER GAME ";A$ +770 IFLEFT$(A$,1)="Y"THEN240 +780 PRINTCHR$(26):END +790 IF(C3<>0)AND(J4=0)THENGOSUB6620 +800 IFK3=0THENRETURN +810 IFA2<>0THENRETURN +820 P2=1/I8 +830 J5=0 +840 PRINT +850 IFC5$="DOCKED"THEN1530 +860 H2=0:H3=0:C6=1 +870 IFS9=1THENC6=.5+.5*RND(1) +880 A3=0 +890 FORL=1TOK3 +900 IFK6(L)<0THEN1320 +910 A3=1 +920 D6=.8+.05*RND(1) +930 H4=K6(L)*D6^K8(L) +940 IF(S4=0)AND(S9=0)THEN1000 +950 P3=.1:IFP2*S3>P3THENP3=P2*S3 +960 H5=P3*C6*H4+1 +970 IFH5>S3THENH5=S3 +980 S3=S3-H5:H4=H4-H5 +990 IF(P3>.1)AND(H4<5E-03*E1)THEN1320 +1000 J5=1 +1010 PRINTFNR(H4);"UNIT HIT ON THE ";S5$;" FROM "; +1020 J6=K4(L):J7=K5(L) +1030 IFQ$(J6,J7)="K"THENPRINT"KLINGON AT"; +1040 IFQ$(J6,J7)="C"THENPRINT"COMMANDER AT"; +1050 PRINTJ6;"-";J7 +1060 IFH4>H2THENH2=H4 +1070 H3=H3+H4 +1080 IFH4<(275-25*S8)*(1+.5*RND(1))THEN1310 +1090 N4=1+INT(H4/(500+100*RND(1))) +1100 PRINT"*** CRITICAL HIT--"; +1110 K9=1 +1120 FORW4=1TON4 +1130 J9=INT(12*RND(1))+1 +1140 C5(W4)=J9 +1150 E3=(H4*D5)/(N4*(75+25*RND(1))) +1160 IFJ9=6THENE3=E3/3 +1170 D4(J9)=D4(J9)+E3 +1180 IFW4=1THEN1250 +1190 FORV=1TOW4 +1200 IFJ9=C5(V-1)THEN1260 +1210 NEXTV +1220 K9=K9+1 +1230 IFK9=3THENPRINT +1240 PRINT " AND "; +1250 PRINTD$(J9); +1260 NEXTW4 +1270 PRINT " DAMAGED." +1280 IFD4(8)=0THEN1310 +1290 IFS4<>0THENPRINT"*** SHIELDS KNOCKED DOWN." +1300 S4=0 +1310 E1=E1-H4 +1320 NEXTL +1330 IFA3=0THENRETURN +1340 IFE1<=0THEN1510 +1350 P4=100*P2*S3+.5 +1360 IFJ5<>0THEN1390 +1370 PRINT"ENEMY ATTACK--SHIELDS REDUCED TO "; +1380 GOTO1430 +1390 PRINT"ENERGY LEFT:";FNS(E1);" SHIELDS "; +1400 IFS4<>0THENPRINT"UP,"; +1410 IF(S4=0)AND(D4(8)=0)THENPRINT"DOWN, "; +1420 IFD4(8)>0THENPRINT"DAMяGED, "; +1430 PRINTINT(P4);"%" +1440 IF(H2<200)AND(H3<500)THEN1540 +1450 J8=INT(H3*RND(1)*.015) +1460 IFJ8<2THEN1540 +1470 PRINT +1480 PRINT"---> 'SICKBAY TO BRIDGE. WE SUFFERED ";J8;"CASUALTIES IN THAT ATTACK" +1490 C4=C4+J8 +1500 GOTO1540 +1510 F9=5 +1520 GOSUB4710:RETURN +1530 PRINT"*** KLINGONS ATTACK-- STARBASE SHIELDS PROTECT THE ";S5$ +1540 FORW4=1TOK3 +1550 K8(W4)=K7(W4) +1560 NEXTW4 +1570 GOSUB10980:RETURN +1580 PRINT:IFJ4=0THEN1610 +1590 PRINT"*** RED ALERT! RED ALERT!" +1600 PRINT"*** THE ";S5$;" HAS STOPPED IN QUADRANT CONTAINING SUPERNOVA" +1610 PRINT "*** AUTO-OVERRIDE ATTEMPTS TO HURL ";S5$;" TO OTHER QUADRANT" +1620 S2(Q1,Q2)=1 +1630 GOSUB7260 +1640 IFD4(6)=0THEN1830 +1650 PRINT +1660 PRINT"WARP ENGINES DAMAGED." +1670 PRINT:PRINT"TRYING TO ENGAGE IMPULSE ENGINES..." +1680 IFD4(7)=0THEN1730 +1690 PRINT"IMPULSE ENGINES DAMAGED." +1700 F9=8 +1710 GOSUB4710 +1720 RETURN +1730 P2=.75*E1 +1740 D6=4E-03*(P2-50) +1750 D7=1.4142+1.2*RND(1) +1760 D1=D6 +1770 IFD6>D7THEND1=D7 +1780 T1=D1/.4 +1790 D2=12*RND(1) +1800 J4=0 +1810 GOSUB5590 +1820 GOTO1940 +1830 W1=6+2*RND(1) +1840 W2=W1*W1 +1850 P2=.75*E1 +1860 D6=P2/(W1*W1*W1*(S4+1)) +1870 D7=1.4142+2*RND(1) +1880 D1=D6 +1890 IFD6>D7THEND1=D7 +1900 T1=10*D1/W2 +1910 D2=12*RND(1) +1920 J4=0 +1930 GOSUB12040 +1940 IFJ4<>0THEN1980 +1950 F9=8 +1960 GOSUB4710 +1970 RETURN +1980 IFR1<>0THENRETURN +1990 F9=1 +2000 GOSUB4710 +2010 RETURN +2020 PRINT:PRINT" 1 2 3 4 5 6 7 8" +2030 PRINT" --- --- --- --- --- --- --- ---" +2040 FORI=1TO8 +2050 PRINTI;" "; +2060 FORJ=1TO8 +2070 ONSGN(S2(I,J))+2GOTO2080,2100,2120 +2080 PRINT" .1."; +2090 GOTO 2170 +2100 PRINT" ..."; +2110 GOTO2170 +2120 IFS2(I,J)>LQTHEN2160 +2130 IFG(I,J)5THENI2=5 +2420 R3=I2 +2430 I5=7*L2 +2440 R5=I5 +2450 R7=(S8-2*RND(1)+1)*S8*.1+.1 +2460 IFR7<.2THENR7=R7+.1 +2470 I1=INT(2*R7*I5) +2480 R1=I1 +2490 I4=INT(S8+.0625*I1*RND(1)) +2500 R2=I4 +2510 I3=(I1+4*I4)*I5 +2520 R4=I3 +2530 RETURN +2540 IFD4(11)=0THEN2570 +2550 PRINT" COMPUTER DISABLED" +2560 RETURN +2570 PRINT"----COMPUTER ACTIVE----" +2580 INPUT"PROGRAM NAME";B$ +2590 FORI=1TO6 +2600 IFB$=LEFT$(C2$(I),LEN(B$))THEN2660 +2610 NEXT +2620 PRINT"VALID PROGRAMS ARE:" +2630 PRINT" COURSE WCOST OUT" +2640 PRINT" PEFFECT ICOST" +2650 GOTO2580 +2660 ON IGOTO2670,2910,2980,3040,2580,3110 +2670 INPUT "ENTER QUADRANT AND SECTOR - ";A3,A4 +2680 IF(A3<>INT(A3))OR(A4<>INT(A4))THEN3120 +2690 IFA3<0THEN2580 +2700 IFA3=0THENA3=10*Q1+Q2 +2710 A3=A3+.5 +2720 K=INT(A3/10) +2730 IF(K<1)OR(K>8)THEN3120 +2740 C6(1)=K:K=INT(A3-C6(1)*10) +2750 IF(K<1)OR(K>8)THEN3120 +2760 C6(2)=K:A4=A4+.5 +2770 K=INT(A4/100) +2780 IF(K<1)OR(K>10)THEN3120 +2790 C6(1)=C6(1)+(K-1)/10:K=INT(A4-K*100) +2800 IF(K<1)OR(K>10)THEN3120 +2810 C6(2)=C6(2)+(K-1)/10 +2820 X=Q1+((S6-1)/10)-C6(1):Y=Q2+((S7-1)/10)-C6(2) +2830 D1=0:D2=0:IF(X=0)AND(Y=0)THEN2890 +2840 D1=SQR(X*X+Y*Y) +2850 IFX<0THENZ7=SGN(Y)*(3.1416-ATN(ABS(Y/X))) +2860 IFX=0THENZ7=SGN(Y)*1.5708 +2870 IFX>0THENZ7=ATN(Y/X) +2880 D2=12-Z7*1.9098593#:IFD2>12THEND2=D2-12 +2890 PRINT"COURSE IS";FNS(D2);" FOR A DISTANCE OF"; +2900 PRINTFNS(D1);"QUADRANTS.":GOTO2580 +2910 INPUT"ENTER DISTANCE AND WARP FACTOR";D1,A4 +2920 IF(D1<0)THEN2580 +2930 C7=D1*A4*A4*A4 +2940 T1=(10*D1)/((A4*A4)+1E-05) +2950 PRINT"IT WOULD TAKE";FNS(T1);"STARDATES AND USE" +2960 PRINTFNR(C7);"UNITS OF ENERGY (";FNR(C7+C7);"IF SHIELDS ARE UP)" +2970 GOTO2580 +2980 INPUT"ENTER DISTANCE...";D1 +2990 IFD1<0THEN2580 +3000 C7=250*D1+50:T1=D1/.4 +3010 PRINT"IT WOULD TAKE";FNR(T1);"STARDATES AND USE" +3020 PRINTC7;"UNITS OF ENERGY" +3030 GOTO2580 +3040 INPUT"ENTER PHASER RANGE IN QUADRANTS";A3 +3050 IFA3<0THEN2580 +3060 A3=A3*10:C7=(.9^A3)*100 +3070 PRINT"PHASERS ARE ";LEFT$(STR$(C7),5);"% EFFECTIVE AT THAT RANGE" +3080 GOTO2580 +3090 GOSUB9750 +3100 GOTO2580 +3110 RETURN +3120 PRINT"FORMAT IS MN,XXYY...WHERE MN IS THE QUADRANT" +3130 PRINT"AND XXYY IS THE SECTOR...E.G. 64,0307 REFERS" +3140 PRINT"TO QUADRANT 6-4, SECTOR 3-7." +3150 GOTO 2580 +3160 IFT2$<>"C"THEN3250 +3170 C3=0:PRINT"*** COMMANDER AT"; +3180 FORF=1TOR2:IF(C1(F)=Q1)AND(C2(F)=Q2)THEN3200 +3190 NEXTF +3200 C1(F)=C1(R2):C2(F)=C2(R2):C1(R2)=0:C2(R2)=0 +3210 R2=R2-1:F1(2)=1E+30 +3220 IFR2<>0THENF1(2)=D0-(I4/R2)*LOG(RND(1)) +3230 K2=K2+1 +3240 GOTO3270 +3250 PRINT"*** KLINGON AT"; +3260 K1=K1+1 +3270 PRINTA5;"-";A6;"DESTROYED." +3280 Q$(A5,A6)=".":R1=R1-1 +3290 IFR1=0THENRETURN +3300 R5=R4/(R1+4*R2) +3310 G(Q1,Q2)=G(Q1,Q2)-100 +3320 FORF=1TOK3 +3330 IF(K4(F)=A5)AND(K5(F)=A6)THEN3350 +3340 NEXTF +3350 K3=K3-1 +3360 IFF>K3THEN3410 +3370 FORG=FTOK3 +3380 K4(G)=K4(G+1):K5(G)=K5(G+1):K6(G)=K6(G+1) +3390 K7(G)=K7(G+1):K8(G)=K7(G) +3400 NEXTG +3410 K4(K3+1)=0:K5(K3+1)=0:K7(K3+1)=0:K8(K3+1)=0:K6(K3+1)=0 +3420 RETURN +3430 IFC5$="DOCKED"THEN3520 +3440 IFB6=0THEN3460 +3450 IF(ABS(S6-B6)<=1)AND(ABS(S7-B7)<=1)THEN3480 +3460 PRINTS5$;" NOT ADJACENT TO A BASE." +3470 RETURN +3480 C5$="DOCKED" +3490 PRINT"---> DOCKING COMPLETED" +3500 E1=I7:S3=I8:T4[9:L1=J1 +3510 RETURN +3520 PRINT"CAPTAIN, WE'RE ALREADY DOCKED!" +3530 RETURN +3540 J=0:PRINT:FORI=1TO12 +3550 IFD4(I)<=0THEN3600 +3560 IFJ<>0THEN3590 +3570 PRINT" DEVICE";SPC(12);"-REPAIR TIMES-" +3580 PRINTSPC(21);"IN FLIGHT DOCKED":J=1 +3590 PRINT" ";D$(I);TAB(23);FNS(D4(I));TAB(33);FNS(D3*D4(I)) +3600 NEXTI +3610 PRINT"TAB(23);"VISUAL SENSORS PERMANENTLY DAMAGED" +3620 IFJ=0THENPRINT" - ALL DEVICES (EXCEPT VISUAL) FUNCTIONAL -" +3630 RETURN +3640 M=0:D7=D0+T1:FORL=1TO5 +3650 IFF1(L)>D7THEN3670 +3660 M=L:D7=F1(L) +3670 NEXTL +3680 X6=D7-D0:D0=D7 +3690 R4=R4-(R1+4*R2)*X6 +3700 R5=R4/(R1+4*R2) +3710 IFR5>0THEN3750 +3720 F9=2 +3730 GOSUB4710 +3740 RETURN +3750 IF(D4(5)=0)OR(C5$="DOCKED")THEN3810 +3760 IF(L1>=X6)OR(D4(5)<=L1)THEN3790 +3770 F9=3:GOSUB4710 +3780 RETURN +3790 L1=L1-X6 +3800 IFD4(5)<=X6THENL1=J1 +3810 R=X6 +3820 IFC5$="DOCKED"THENR=X6/D3 +3830 FORL=1TO12 +3840 IFD4(L)<=0THEN3890 +3850 D4(L)=D4(L)-R +3860 IFD4(L)<0THEND4(L)=0 +3870 IFD4(L)<>0THEN3890 +3880 PRINT:PRINT"DAMAGE CONTROL- ";D$(L);" NOW OPERATIONAL." +3890 NEXTL +3900 IFM=0THENRETURN +3910 T1=T1-X6 +3920 ONMGOTO3930,3970,4190,4280,4450 +3930 X2=0:Y2=0:GOSUB10520 +3940 F1(1)=D0-.5*I5*LOG(RND(1)) +3950 IFG(Q1,Q2)=LQTHENRETURN +3960 GOTO3640 +3970 IFR2=0THEN4180 +3980 IFC5$="DOCKED"THEN4160 +3990 I=INT(RND(1)*R2)+1 +4000 Y6=(C1(I)-Q1)^2+(C2(I)-Q2)^2 +4010 IFY6=0THEN4160 +4020 Y6=SQR(Y6):T1=.17778*Y6 +4030 PRINT:PRINT"*** ";S5$;" CAUGHT IN LONG-RANGE TRACTOR BEAM--" +4040 Q1=C1(I):Q2=C2(I) +4050 S6=FNB(1):S7=FNB(1) +4060 PRINT"PULLED TO QUADRANT";Q1;"-";Q2;", SECTOR";S6;"-";S7 +4070 IFR6<>0THENPRINT"(IDLE PERIOD CANCELLED)" +4080 R6=0 +4090 IFS4<>0THEN4150 +4100 IF(D4(8)=0)AND(S3>0)THEN4130 +4110 PRINT"(SHIELDS NOT CURRENTLY USABLE.)" +4120 GOTO4150 +4130 GOSUB10390 +4140 S9=0 +4150 GOSUB7260 +4160 F1(2)=D0+T1-1.5*(I5/R2)*LOG(RND(1)) +4170 GOTO3640 +4180 F1(2)=1E+30:GOTO3640 +4190 D9(1)=D0:D9(2)=R1:D9(3)=R2:D9(4)=R3:D9(5)=R4:D9(6)=R5 +4200 D9(7)=S1:D9(8)=B1:D9(9)=K1:D9(10)=K2 +4210 FORI=1TO8:FORJ=1TO8:D9(I-1+8*(J-1)+11)=G(I,J):NEXTJ:NEXTI +4220 FORI=75TO84:D9(I)=C1(I-74):NEXT +4230 FORI=85TO94:D9(I)=C2(I-84):NEXT +4240 FORI=95TO99:D9(I)=B2(I-94):NEXT +4250 FORI=100TO104:D9(I)=B3(I-99):NEXT +4260 D9(105)=B4:D9(106)=B5 +4270 S0=1:F1(3)=D0-.3*I5*LOG(RND(1)):GOTO3640 +4280 IF(R2=0)OR(R3=0)THEN4330 +4290 FORI=1TOR3:FORJ=1TOR2:IF(B2(I)=C1(J))AND(B3(I)=C2(J))THEN4340 +4300 NEXTJ:NEXTI +4310 F1(4)=D0+.5+3*RND(1) +4320 F1(5)=1E+30:GOTO3640 +4330 F1(4)=1E+30:F1(5)=1E+30:GOTO3640 +4340 B4=B2(I):B5=B3(I) +4350 IF(B4=Q1)AND(B5=Q2)THEN4310 +4360 F1(5)=D0+.5+3*RND(1) +4370 F1(4)=F1(5)-.3*I5*LOG(RND(1)) +4380 IFD4(9)>0THEN3640 +4390 PRINT:PRINT" CAPTAIN, THE STARBASE IN";B4;"-";B5;"IS UNDER ATTACK-" +4400 PRINT" AND CAN ONLY RESIST UNTIL STARDATE";FNR(F1(5));"!!!" +4410 IFR6=0THEN3640 +4420 INPUT" SHALL WE CANCEL IDLE PERIOD";B$ +4430 IFLEFT$(B$,1)="Y"THENR6=0 +4440 GOTO3640 +4450 F1(5)=1E+30:IF(R2=0)OR(R3=0)THEN3640 +4460 K=INT(G(B4,B5)/100):IFG(B4,B5)-K*100<10THEN3640 +4470 FORI=1TOR2:IF(C1(I)=B4)AND(C2(I)=B5)THEN4490 +4480 NEXT:GOTO3640 +4490 IFS2(B4,B5)=-1THENS2(B4,B5)=0 +4500 IFS2(B4,B5)>999THENS2(B4,B5)=S2(B4,B5)-10 +4510 IF(B4<>Q1)OR(B5<>Q2)THEN4600 +4520 FORI=1TOK3:K=K4(I):L=K5(I) +4530 IFQ$(K,L)="C"THEN4550 +4540 NEXT +4550 IFK6(I)<25+50*RND(1)THEN3640 +4560 Q$(B6,B7)=".":B6=0:B7=0 +4570 GOSUB7230 +4580 PRINT:PRINT"CAPTAIN, I BELIEVE THE STARBASE HAS BEEN DESTROYED" +4590 GOTO4640 +4600 IF(R3=1)OR(D4(9)>0)THEN4640 +4610 PRINT +4620 PRINT"--> STARFLEET COMMAND REPORTS THAT STARBASE IN QUADRANT";B4;"-";B5 +4630 PRINT"HAS BEEN DESTROYED BY ENEMY COMMANDER !!" +4640 G(B4,B5)=G(B4,B5)-10 +4650 IFR3<=1THEN4690 +4660 FORI=1TOR3:IF(B2(I)=B4)AND(B3(I)=B5)THEN4680 +4670 NEXT +4680 B2(I)=B2(R3):B3(I)=B3(R3) +4690 R3=R3-1 +4700 GOTO3640 +4710 PRINT:PRINT:PRINT:PRINT"CONFLICT RESOLVED -GAME OVER":GOTO760 +4720 IFC5$<>"DOCKED"THEN4750 +4730 PRINT"--> CAPTAIN, WE'RE ALREADY DOCKED!" +4740 RETURN +4750 IFD4(9)=0THEN4770 +4760 PRINT"SUBSPACE RADIO DAMAGED...CANNOT TRANSMIT.":RETURN +4770 IFR3<>0THEN4790 +4780 PRINT"CAPTAIN, NO RESPONSE FROM STARBASE !":RETURN +4790 N1=N1+1:IFB6=0THEN4810 +4800 GOTO4870 +4810 D1=1E+30 +4820 FORL=1TOR3:X=10*SQR((B2(L)-Q1)^2+(B3(L)-Q2)^2) +4830 IFX>D1THEN4850 +4840 D1=X:K=L +4850 NEXTL +4860 Q1=B2(K):Q2=B3(K):GOSUB7260 +4870 Q$(S6,S7)="." +4880 PRINT +4890 PRINT"STARBASE IN QUADRANT";Q1;"-";Q2;"RESPONDS --"; +4900 PRINT" ";S5$;" DEMATERIALIZES." +4910 P2=(1-.98^D1)^.333333 +4920 FORL=1TO3 +4930 IFL=1THENPRINT"1ST "; +4940 IFL=2THENPRINT"2ND "; +4950 IFL=3THENPRINT"3RD "; +4960 PRINT"ATTEMPT TO RE-MATERIALIZE THE ";S5$;". . . . ."; +4970 IFRND(1)>P2THEN5000 +4980 PRINT"FAILS.":NEXTL +4990 F9=11:GOSUB4710:RETURN +5000 FORL=1TO5:I=B6+INT(3*RND(1))-1 +5010 IF(I<1)OR(I>10)THEN5050 +5020 J=B7+INT(3*RND(1))-1 +5030 IF(J<1)OR(J>10)THEN5050 +5040 IFQ$(I,J)="."THEN5060 +5050 NEXTL:PRINT"FAILS.":GOTO4990 +5060 PRINT"SUCCEEDS.":S6=I:S7=J:Q$(I,J)=LEFT$(S5$,1) +5070 GOSUB3430:PRINT"CAPTAIN, WE MADE IT!":RETURN +5080 P4=2:L5=K3:N=1 +5090 FORK=1TOL5 +5100 IFH3(K)=0THEN5360 +5110 D6=.9+.01*RND(1):H2=H3(K)*D6^K7(N) +5120 P3=K6(N) +5130 P=ABS(P3):IFP4*H24.99THEN5180 +5170 PRINT"MINOR HIT ON ":GOTO5190 +5180 PRINTFNR(H2);"UNIT HIT ON "; +5190 M$=Q$(X8,Y8) +5200 IF M$="K"THENPRINT"KLINGON AT"; +5210 IFM$="C"THENPRINT"COMMANDER AT"; +5220 PRINTX8;"-";Y8 +5230 IFK6(N)<>0THEN5270 +5240 A5=X8:A6=Y8:T2$=Q$(X8,Y8):GOSUB3160 +5250 IFR1<>0THEN5370 +5260 F9=1:GOSUB4710:GOTO5370 +5270 IFK6(N)<0THEN5360 +5280 IFRND(1)<.9THEN5360 +5290 IFK6(N)>(.4+.4*RND(1))*P3THEN5360 +5300 PRINT +5310 PRINT"*** CAPTAIN, THE VESSEL AT SECTOR"; +5320 PRINTX8;"-";Y8 +5330 PRINT" HAS JUST LOST ITS FIREPOWER !!!" +5340 PRINT +5350 K6(N)=-K6(N) +5360 N=N+1 +5370 NEXTK +5380 RETURN +5390 J3=0 +5400 IFD4(7)<>0THEN5640 +5410 IFE1<=75THEN5470 +5420 INPUT"ENTER COURSE....";D2 +5430 IFD2<.01ORD2>12THENGOSUB12780ELSE5450 +5440 RETURN +5450 P3=50+250*D1 +5460 IFP375THEN5520 +5510 PRINT"QUADRANT. THEY ARE USELESS NOW.'":RETURN +5520 PRINT"QUADRANT. WE CAN GO A MAXIMUM OF "; +5530 PRINTFNR(4E-03*(E1-50)-.05);"QUADRANTS.'":RETURN +5540 T1=D1/.4 +5550 IFT1"Y"THENRETURN +5590 GOSUB5850:J3=1 +5600 IFA2<>0THENRETURN +5610 E1=E1-P3 +5620 IFE1>0THENRETURN +5630 F9=4:GOSUB4710:RETURN +5640 PRINT"IMPULSE ENGINES DAMAGED.":RETURN +5650 N$=" #" +5660 PRINT +5670 IFD4(2)<>0THEN5840 +5680 PRINT"L.R. SCAN FOR QUADRANT";Q1;"-";Q2:PRINT +5690 I=Q1-1:J=Q1+1:K=Q2-1:L=Q2+1 +5700 FORM=ITOJ:FORN=KTOL +5710 IF(M<=0)OR(M>8)THEN5770 +5720 IF(N<=0)OR(N>8)THEN5770 +5730 IFD4(11)=0THENS2(M,N)=1 +5740 IFG(M,N)>=LQTHEN PRINT" ***";" "; +5750 IFG(M,N)B8THENB8=ABS(D6) +5870 D4=D4/B8:D6=D6/B8:T5=0:T6=0 +5880 IFD0+T110)THEN6190 +5960 IF(Y1<1)OR(Y1>10)THEN6190 +5970 IFQ$(X1,Y1)="O"THEN6000 +5980 IFQ$(X1,Y1)<>"."THEN6070 +5990 NEXTL +6000 D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +6010 S6=X1:S7=Y1 +6020 F4=S6:F5=S7 +6030 IFQ$(X1,Y1)<>"O"THEN6520 +6040 T2=FNA(1):T3=FNA(1) +6050 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):PRINT +6060 PRINT"*** SPACE PORTAL ENTERED ***":GOTO6490 +6070 T6=1:K=50*D1/T1+1E-03:D1=.1*SQR((S6-X1)^2+(S7-Y1)^2) +6080 IF(Q$(X1,Y1)="K")OR(Q$(X1,Y1)="C")THEN6180 +6090 PRINT:PRINTS5$;" BLOCKED BY "; +6100 IFQ$(X1,Y1)="*"THENPRINT"STAR AT"; +6110 IFQ$(X1,Y1)="B"THENPRINT"STARBASE AT"; +6120 PRINT" SECTOR";X1;"-";Y1;"...." +6130 PRINT"EMERGENCY STOP REQUIRED";FNR(K);"UNITS OF ENERGY." +6140 E1=E1-K +6150 S6=INT(X7-D4+.5):F4=S6:S7=INT(Y7-D6+.5):F5=S7 +6160 IFE1>0THEN6520 +6170 F9=4:GOSUB4710:RETURN +6180 S6=X1:S7=Y1:GOSUB9600:F4=S6:F5=S7:GOTO6520 +6190 IFK3=0THEN6250 +6200 FORL=1TOK3 +6210 F3=SQR((X1-K4(L))^2+(Y1-K5(L))^2) +6220 K8(L)=.5*(F3+K7(L)):NEXTL +6230 IFG(Q1,Q2)<>LQTHENGOSUB790 +6240 IFA2<>0THENRETURN +6250 X7=10*(Q1-1)+S6:Y7=10*(Q2-1)+S7 +6260 X1=INT(X7+10*D1*B8*D4+.5) +6270 Y1=INT(Y7+10*D1*B8*D6+.5):L6=0 +6280 L5=0 +6290 IFX1>0THEN6310 +6300 X1=-X1+1:L5=1 +6310 IFY1>0THEN6330 +6320 Y1=-Y1+1:L5=1 +6330 IFX1<=80THEN6350 +6340 X1=161-X1:L5=1 +6350 IFY1<=80THEN6370 +6360 Y1=161-Y1:L5=1 +6370 IFL5=0THEN6390 +6380 L6=1:GOTO6280 +6390 IFL6=0THEN6460 +6400 PRINT:PRINT"*** MESSAGE FROM STARFLEET COMMAND.....STARDATE";FNR(DO) +6410 PRINT"PERMISSION TO EXIT GALAXY - DENIED -" +6420 PRINT"'ENGINES SHUT DOWN AT "; +6430 Z1=INT((X1+9)/10):Z2=INT((Y1+9)/10) +6440 PRINT"QUADRANT";Z1;"-";Z2;", "; +6450 PRINT"SECTOR";X1-10*(Z1-1);"-";Y1-10*(Z2-1);"'" +6460 IFT5<>0THENRETURN +6470 Q1=INT((X1+9)/10):Q2=INT((Y1+9)/10) +6480 S6=X1-10*(Q1-1):S7=Y1-10*(Q2-1) +6490 GOSUB7550:PRINT:GOTO6510 +6500 PRINTCHR$(26):PRINT"ENTERING THE ";G2$;" QUADRANT (";Q1;"-";Q2;")" +6510 Q$(S6,S7)=LEFT$(S5$,1):GOSUB7260:GOSUB11090:GOSUB5650:RETURN +6520 Q$(S6,S7)=LEFT$(S5$,1) +6530 IFL6=1THENRETURN +6540 IFK3=0THEN6610 +6550 FORL=1TOK3 +6560 F3=SQR((F4-K4(L))^2+(F5-K5(L))^2) +6570 K8(L)=.5*(K7(L)+F3) +6580 K7(L)=F3 +6590 NEXTL +6600 GOSUB10980 +6610 GOSUB7230:RETURN +6620 A=1:B=1 +6630 FORK=1TOK3 +6640 C=K4(K):D=K5(K) +6650 IFQ$(C,D)="C"THEN6670 +6660 NEXTK +6670 N=0:F=K6(K)+100*K3 +6680 IFF>LQTHENN=INT(RND(1)*K7(K)+1) +6690 IF((C5$="DOCKED")AND((B4<>Q1)OR(B5<>Q2)))THENN=-S8 +6700 IFN=0THENN=INT(((F+200*RND(1))/150)-5) +6710 IFN=0THENRETURN +6720 IF(N>0)AND(K7(K)<1.5)THENRETURN +6730 IFABS(N)>S8THENN=SGN(N)*ABS(S8) +6740 T=ABS(N):P=S6-C:Q=S7-D +6750 IF2*ABS(P)0THENP=SGN(P*N) +6780 IFQ<>0THENQ=SGN(Q*N) +6790 R=C:S=D:Q$(C,D)="." +6800 FORL2=1TOT:L=R+P:M=S+Q +6810 IF(L>0)AND(L<=10)THEN6830 +6820 ONSGN(N)+2GOTO7060,6920,6920 +6830 IF(M>0)AND(M<=10)THEN6850 +6840 ONSGN(N)+2GOTO7060,6860,6860 +6850 IFQ$(L,M)="."THEN6980 +6860 IF(Q=B)OR(P=0)THEN6920 +6870 M=S+B +6880 IF(M>0)AND(M<=10)THEN6900 +6890 ONSGN(N)+2GOTO7060,6910,6910 +6900 IFQ$(L,M)="."THEN6980 +6910 B=-B +6920 IF(P=A)OR(Q=0)THEN6990 +6930 L=R+A +6940 IF(L>0)AND(L<=10)THEN6960 +6950 ONSGN(N)+2GOTO7060,6970,6970 +6960 IFQ$(L,M)="."THEN6980 +6970 A=-A:GOTO6990 +6980 R=L:S=M +6990 NEXTL2 +7000 Q$(R,S)="C" +7010 IF(R=C)AND(S=D)THENRETURN +7020 K4(K)=R:K5(K)=S:K7(K)=SQR((S6-R)^2+(S7-S)^2) +7030 K8(K)=K7(K):IFN>0THENPRINT"*** COMMANDER ADVANCES TO"; +7040 IFN<0THENPRINT"*** COMMANDER RETREATS TO"; +7050 PRINT" SECTOR";R;"-";S:GOSUB10980:RETURN +7060 I=Q1+INT((L+9)/10)-1:J=Q2+INT((M+9)/10)-1 +7070 IF(I<1)OR(I>8)THEN7220 +7080 IF(J<1)OR(J>8)THEN7220 +7090 FORL3=1TOR2 +7100 IF(C1(L3)=I)AND(C2(L3)=J)THEN7220 +7110 NEXTL3:PRINT"*** COMMANDER ESCAPES TO "; +7120 PRINT"QUADRANT";I;"-";J;" (AND REGAINS STRENGTH)" +7130 K4(K)=K4(K3):K5(K)=K5(K3):K7(K)=K7(K3):K8(K)=K8(K3) +7140 K6(K)=K6(K3):K3=K3-1:C3=0 +7150 IFC5$<>"DOCKED"THENGOSUB7230 +7160 GOSUB10980 +7170 G(Q1,Q2)=G(Q1,Q2)-100:G(I,J)=G(I,J)+100 +7180 FORL3=1TOR2 +7190 IF(C1(L3)=Q1)AND(C2(L3)=Q2)THEN7210 +7200 NEXTL3 +7210 C1(L3)=I:C2(L3)=J:RETURN +7220 A=-A:B=-B:GOTO6990 +7230 C5$="GREEN":IFE199THENC5$="RED" +7250 RETURN +7260 J4=1:B6=0:B7=0:K3=0:C3=0:U=G(Q1,Q2):IFU>999THEN7530 +7270 K3=INT(.01*U):FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +7280 Q$(S6,S7)=LEFT$(S5$,1):U=G(Q1,Q2):IFU<100THEN7400 +7290 U=U-100*K3:FORA=1TOK3 +7300 S=FNB(1):K4(A)=S:T=FNB(1):K5(A)=T +7310 IFQ$(S,T)<>"."THEN7300 +7320 Q$(S,T)="K":K7(A)=SQR((S6-S)^2+(S7-T)^2):K8(A)=K7(A) +7330 K6(A)=RND(1)*150+325:NEXTA +7340 IFR2=0THEN7390 +7350 FORA=1TOR2 +7360 IF(C1(A)=Q1)AND(C2(A)=Q2)THEN7380 +7370 NEXTA:GOTO7390 +7380 Q$(S,T)="C":K6(K3)=LQ+400*RND(1):C3=1 +7390 GOSUB10980 +7400 IFU<10THEN7440 +7410 U=U-10 +7420 B6=FNB(1):B7=FNB(1):IFQ$(B6,B7)<>"."THEN7420 +7430 Q$(B6,B7)="B" +7440 GOSUB7230:IFU<1THENRETURN +7450 FORA=1TOU +7460 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN7460 +7470 Q$(S,T)="*":NEXTA +7480 IF(T2<>Q1)OR(T3<>Q2)THENRETURN +7490 S=FNB(1):T=FNB(1):IFQ$(S,T)<>"."THEN7490 +7500 Q$(S,T)="O":PRINT +7510 PRINT"*** SHORT-RANGE SENSORS DETECT A SPACE-WARP IN THIS QUADRANT" +7520 RETURN +7530 FORA=1TO10:FORB=1TO10:Q$(A,B)=".":NEXTB:NEXTA +7540 Q$(S6,S7)=LEFT$(S5$,1):RETURN +7550 G4$="III":L=2:IFQ2>=5THEN7570 +7560 L=1 +7570 G2$=G1$(2*(Q1-1)+L):L=Q2 +7580 IFL<=4THEN7600 +7590 L=Q2-4 +7600 G3$="IV":IFL=4THEN7620 +7610 G3$=LEFT$(G4$,L) +7620 G2$=G2$+" "+G3$:RETURN +7630 IFRND(1)>.1THEN7650 +7640 GOSUB10520:RETURN +7650 Q$(A5,A6)=".":PRINT"*** STAR AT SECTOR";A5;"-";A6;"NOVAS." +7660 G(Q1,Q2)=G(Q1,Q2)-1:S1=S1+1 +7670 B9=1:T6=1:T7=1:K=0:X1=0:Y1=0 +7680 H4(B9,1)=A5:H4(B9,2)=A6 +7690 FORM=B9TOT6:FORQ=1TO3:FORJ=1TO3 +7700 IFJ*Q=4THEN8140 +7710 J5=H4(M,1)+Q-2:J6=H4(M,2)+J-2 +7720 IF(J5<1)OR(J5>10)THEN8140 +7730 IF(J6<1)OR(J6>10)THEN8140 +7740 IFQ$(J5,J6)="."THEN8140 +7750 IFQ$(J5,J6)="O"THEN8140 +7760 IFQ$(J5,J6)<>"*"THEN7820 +7770 IFRND(1)>=.1THEN7790 +7780 X2=J5:Y2=J6:GOSUB10520:RETURN +7790 T7=T7+1:H4(T7,1)=J5:H4(T7,2)=J6:G(Q1,Q2)=G(Q1,Q2)-1 +7800 S1=S1+1:PRINT"*** STAR AT SECTOR";J5;"-";J6;"NOVAS." +7810 GOTO8130 +7820 IFQ$(J5,J6)<>"B"THEN7890 +7830 G(Q1,Q2)=G(Q1,Q2)-10:FORV=1TOR3 +7840 IF(B2(V)<>Q1)OR(B3(V)<>Q2)THEN7860 +7850 B2(V)=B2(R3):B3(V)=B3(R3) +7860 NEXTV:R3=R3-1:B6=0:B7=0:B1=B1+1:GOSUB7230 +7870 PRINT"*** STARBASE AT SECTOR";J5;"-";J6;"DESTROYED." +7880 GOTO8130 +7890 IF(S6<>J5)OR(S7<>J6)THEN7990 +7900 PRINT"*** STARSHIP BUFFETED BY NOVA.":IFS4<>0THEN7920 +7910 E1=E1-LQ:GOTO7950 +7920 IFS3>=LQTHEN7970 +7930 D6=LQ-S3:E1=E1-D6:GOSUB7230:S3=0:S4=0 +7940 PRINT"*** STARSHIP SHIELDS KNOCKED OUT.":D4(8)=5E-03*D5*RND(1))*D6 +7950 IFE1>0THEN7980 +7960 F9=7:GOSUB4710:RETURN +7970 S3=S3-LQ +7980 X1=X1+S6-H4(M,1):Y1=Y1+S7-H4(M,2):K=K+1:GOTO8140 +7990 IFQ$(J5,J6)<>"C"THEN8120 +8000 FORV=1TOK3 +8010 IF(K4(V)=J5)AND(K5(V)=J6)THEN8030 +8020 NEXTV +8030 K6(V)=K6(V)-800:IFK6(V)<=0THEN8120 +8040 N5=J5+J5-H4(M,1):N6=J6+J6-H4(M,2) +8050 PRINT"*** COMMANDER AT SECTOR";J5;"-";J6;"DAMAGED"; +8060 IF(N5<1)OR(N5>10)OR(N6<1)OR(N6>10)THEN8110 +8070 PRINT" AND BUFFETED TO SECTOR";N5;"-";N6 +8080 Q$(N5,N6)="C":K4(V)=N5:K5(V)=N6 +8090 K7(V)=SQR((S6-N5)^2+(S7-N6)^2):K8(V)=K7(V) +8100 Q$(J5,J6)="." +8110 PRINT:GOTO8140 +8120 A5=J5:A6=J6:T2$=Q$(J5,J6):GOSUB3160:GOTO8140 +8130 PRINT:Q$(J5,J6)="." +8140 NEXTJ:NEXTQ:NEXTM +8150 IFT6=T7THEN8170 +8160 B9=T6+1:T6=T7:GOTO7690 +8170 IFK=0THENRETURN +8180 D1=K*.1 +8190 IFX1<>0THENX1=SGN(X1) +8200 IFY1<>0THENY1=SGN(Y1) +8210 I=3*(X1+1)+Y1+2 +8220 D2=C5(I) +8230 IFD2=0THEND1=0 +8240 IFD1=0THENRETURN +8250 PRINT:PRINT"FORCE OF NOVA DISPLACES STARSHIP." +8260 GOSUB5850:RETURN +8270 P=2:J3=1 +8280 IFC5$<>"DOCKED"THEN8300 +8290 PRINT"PHASERS CAN'T BE FIRED THRU BASE SHIELDS.":GOTO8370 +8300 IFD4(3)=0THEN8320 +8310 PRINT"PHASER BANKS DAMAGED.":GOTO8370 +8320 IFS4=0THEN8340 +8330 PRINT"SHIELDS MUST BE DOWN TO FIRE PHASERS.":GOTO8370 +8340 IFK3>0THEN8380 +8350 PRINT +8360 PRINT"THE SHORT-RANGE SENSORS DETECT NO ENEMY IN THIS QUADRANT." +8370 J3=0:RETURN +8380 PRINT"PHASERS LOCKED ON TARGET. ENERGY AVAILABLE="; +8390 PRINT.01*INT(100*E1) +8400 INPUT"UNITS TO FIRE";P1:IFP1=ETHEN8610 +8590 H3(I)=H5(I):E=E-R7 +8600 NEXTI:GOTO8620 +8610 H3(I)=H3(I)+E:E=0 +8620 GOSUB5080 +8630 IF(E<>0)AND(A2=0)THEN8650 +8640 J3=1:RETURN +8650 PRINTFNR(E);"EXPENDED ON EMPTY SPACE.":J3=1:RETURN +8660 J3=1:IFD4(4)=0THEN8680 +8670 PRINT"PHOTON TUBES DAMAGED.":GOTO8720 +8680 IFT4<>0THEN8700 +8690 PRINT"NO TORPEDOS LEFT.":GOTO8720 +8700 INPUT"TORPEDO COURSE";C6 +8710 IFC6<.01ORC6>12THENGOSUB12780ELSE8730 +8720 J3=0:RETURN +8730 INPUT"BURST OF 3";B$:N=1 +8740 IFLEFT$(B$,1)="N"THEN8830 +8750 IFLEFT$(B$,1)<>"Y"THEN8730 +8760 IFT4>2THEN8780 +8770 PRINT"NO BURST. ONLY";T4;"TORPEDOS LEFT.":GOTO8720 +8780 INPUT"SPREAD ANGLE (3 - 30 DEG)";G2 +8790 IFG2<0THEN8720 +8800 IF(G2<3)OR(G2>30)THEN8780 +8810 G2=FND(G2) +8820 N=3 +8830 FORZ6=1TON +8840 IFC5$<>"DOCKED"THENT4=T4-1 +8850 Z7=Z6:R=RND(1) +8860 R=(R+RND(1))*.5-.5 +8870 IF(R>=-.4)AND(R<=.4)THEN8940 +8880 R=(RND(1)+1.2)*R:IFN=3THEN8900 +8890 PRINT"*** TORPEDO MISFIRES...":GOTO8910 +8900 PRINT"*** TORPEDO NUMBER";Z6;"MISFIRES..." +8910 IF RND(1)>.2THEN8940 +8920 PRINT"*** PHOTON TUBES DAMAGED BY MISFIRE." +8930 D4(4)=D5*(1+2*RND(1)):GOTO9580 +8940 IF(S4<>0)OR(C5$="DOCKED")THENR=R+1E-03*S3*R +8950 A3=C6+.25*R:IFN=1THEN8980 +8960 A8=(15-A3+(2-Z6)*G2)*.523599:PRINT +8970 PRINT"TRACK FOR TORPEDO NUMBER";Z7;"--":GOTO8990 +8980 PRINT:PRINT"TORPEDO TRACK --":A8=(15-A3)*.523599 +8990 X4=-SIN(A8):Y4=COS(A8):B8=ABS(X4) +9000 IFABS(Y4)>ABS(X4)THENB8=ABS(Y4) +9010 X4=X4/B8:Y4=Y4/B8:X5=S6:Y5=S7 +9020 FORL9=1TO15:X5=X5+X4:A5=INT(X5+.5) +9030 IF(A5<1)OR(A5>10)THEN9560 +9040 Y5=Y5+Y4:A6=INT(Y5+.5) +9050 IF(A6<1)OR(A6>10)THEN9560 +9060 IF(L9=5)OR(L9=9)THENPRINT +9070 PRINTFNR(X5);"-";FNR(Y5);", "; +9080 IFQ$(A5,A6)<>"."THEN9100 +9090 GOTO9550 +9100 PRINT:IFQ$(A5,A6)="K"THEN9150 +9110 IFQ$(A5,A6)<>"C"THEN9370 +9120 IFRND(1)>.1THEN9150 +9130 PRINT"*** COMMANDER AT SECTOR";A5;"-";A6;"USES ANTI-PHOTON DEVICE !" +9140 PRINT"-- TORPEDO NEUTRALIZED.":GOTO9570 +9150 FORV=1TOK3 +9160 IF(A5=K4(V))AND(A6=K5(V))THEN9180 +9170 NEXTV +9180 K=K6(V):W3=200+800*RND(1) +9190 IFABS(K)0THEN9220 +9210 T2$=Q$(A5,A6):GOSUB3160:GOTO9570 +9220 IFQ$(A5,A6)="K"THENPRINT"*** KLINGON AT"; +9230 IFQ$(A5,A6)="C"THENPRINT"*** COMMANDER AT"; +9240 PRINTA5;"-";A6; +9250 A7=A8+2.5*(RND(1)-.5) +9260 W3=ABS(-SIN(A7)):IFABS(COS(A7))>W3THENW3=ABS(COS(A7)) +9270 X7=-SIN(A7)/W3:Y7=COS(A7)/W3 +9280 P=INT(A5+X7+.5):Q=INT(A6+Y7+.5) +9290 IF(P<1)OR(P>10)OR(Q<1)OR(Q>10)THEN9360 +9300 IFQ$(P,Q)<>"."THEN9360 +9310 Q$(P,Q)=Q$(A5,A6):Q$(A5,A6)=".":PRINT"DAMAGED--" +9320 PRINT" DISPLACED BY BLAST TO SECTOR";P;"-";Q +9330 K4(V)=P:K5(V)=Q:K7(V)=SQR((S6-P)^2+(S7-Q)^2) +9340 K8(V)=K7(V) +9350 GOSUB10980:GOTO9570 +9360 PRINT"DAMAGED, BUT NOT DESTROYED.":GOTO9570 +9370 IFQ$(A5,A6)<>"B"THEN9450 +9380 PRINT"*** STARBASE DESTROYED...!!!" +9390 IFS2(Q1,Q2)<0THENS2(Q1,Q2)=0 +9400 FORW=1TOR3 +9410 IF(B2(W)<>Q1)OR(B3(W)<>Q2)THEN9430 +9420 B2(W)=B2(R3):B3(W)=B3(R3) +9430 NEXTW:Q$(A5,A6)=".":R3=R3-1:B6=0:B7=0 +9440 G(Q1,Q2)=G(Q1,Q2)-10:B1=B1+1:GOSUB7230:GOTO9570 +9450 IFQ$(A5,A6)<>"*"THEN9530 +9460 IFRND(1)>.15THEN9490 +9470 PRINT"*** STAR AT SECTOR";A5;"-";A6;"UNAFFECTED BY PHOTON BLAST" +9480 GOTO9570 +9490 X2=A5:Y2=A6:GOSUB7630:A5=X2:A6=Y2 +9500 IFG(Q1,Q2)=LQTHENRETURN +9510 IFA2<>0THENRETURN +9520 GOTO9570 +9530 PRINT:PRINT" >>> ORGANIAN TRUCE-MONITOR DESTROYED <<<":Q$(A5,A6)=".":PRINT +9540 T2=0:T3=0:GOTO9570 +9550 NEXTL9 +9560 PRINT:PRINT"TORPEDO MISSED!" +9570 NEXTZ6 +9580 IFR1<>0THENRETURN +9590 F9=1:GOSUB4710:RETURN +9600 PRINT:PRINT"*** RED ALERT!! RED ALERT!! ***":PRINT +9610 PRINT"*** COLLISION IMMINENT!!":PRINT +9620 PRINT"*** ";S5$;" RAMS ";:W7=1:IFQ$(S6,S7)="C"THENW7=2 +9630 IFW7=1THENPRINT"KLINGON AT "; +9640 IFW7=2THENPRINT"COMMANDER AT "; +9650 PRINT"SECTOR";S6;"-";S7:A5=S6:A6=S7:T2$=Q$(S6,S7) +9660 GOSUB3160:PRINT"*** ";S5$;" HEAVILY DAMAGED." +9670 K=INT(5+RND(1)*20):PRINT"***SICKBAY REPORTS";K;"CASUALTIES!" +9680 C4=C4+K:FORL=1TO12:I=RND(1) +9690 J=(3.5*W7*(RND(1)+I)+1)*D5 +9700 IFL=6THENJ=J/3 +9710 D4(L)=D4(L)+T1+J:NEXTL:D4(6)=D4(6)-3 +9720 IFD4(6)<0THEND4(6)=0 +9730 S4=0:IFR1<>0THENRETURN +9740 F9=1:GOSUB4710:RETURN +9750 RETURN +9760 A2=0:G1=0:GOSUB2200:S5$="ENTERPRISE" +9770 I7=5000:E1=I7:I8=2500:S3=I8:S4=0:S9=S4:J1=4:L1=J1 +9780 Q1=FNA(1):Q2=FNA(1):S6=FNB(1):S7=FNB(1):I9=10:T4=I9 +9790 W1=5:W2=25:FORI=1TO12:D4(I)=0:NEXT +9800 J2=100*INT(31*RND(1)+20):D0=J2:K1=0:K2=0:N1=0:N2=0:R6=0:C4=0 +9810 A1=1:D3=.25:FORI=1TO8:FORJ=1TO8:S2(I,J)=0:NEXTJ:NEXTI +9820 F1(1)=D0-.5*I5*LOG(RND(1)):F1(5)=1E+30 +9830 F1(2)=D0-1.5*(I5/R2)*LOG(RND(1)):I6=0 +9840 F1(3)=D0-.3*I5*LOG(RND(1)):F1(4)=D0-.3*I5*LOG(RND(1)) +9850 FORI=1TO8:FORJ=1TO8:K=INT(RND(1)*9+1):I6=I6+K +9860 G(I,J)=K:NEXTJ:NEXTI:S1=0 +9870 FOR I=1TOI2 +9880 X=INT(RND(1)*6+2):Y=INT(RND(1)*6+2) +9890 IFG(X,Y)>=10THEN9880 +9900 IFI<2THEN9940 +9910 K=I-1:FORJ=1TOK:D1=SQR((B2(J)-X)^2+(B3(J)-Y)^2) +9920 IFD1<2THEN9880 +9930 NEXTJ +9940 B2(I)=X:B3(I)=Y:S2(X,Y)=-1:G(X,Y)=G(X,Y)+10:NEXTI +9950 B1=0:K=I1-I4:L=INT(.25*S8*(9-L2)+1) +9960 M=INT((1-RND(1)^2)*L):IFM>KTHENM=K +9970 N=100*M +9980 X=FNA(1):Y=FNA(1):IFG(X,Y)+N>999THEN9980 +9990 G(X,Y)=G(X,Y)+N:K=K-M:IFK<>0THEN9960 +10000 FORI=1TOI4 +10010 X=FNA(1):Y=FNA(1):IF(G(X,Y)<99)AND(RND(1)<.75)THEN10010 +10020 IFG(X,Y)>899THEN10010 +10030 IFI=1THEN10060 +10040 M=I-1:FORJ=1TOM:IF(C1(J)=X)AND(C2(J)=Y)THEN10010 +10050 NEXTJ +10060 G(X,Y)=G(X,Y)+100:C1(I)=X:C2(I)=Y:NEXTI +10070 I=INT(D0):PRINT:S0=0 +10080 T2=FNA(1):T3=FNA(1):IFG(T2,T3)<100THEN10080 +10090 PRINT"STARDATE..............";I +10100 PRINT"NUMBER OF KLINGONS....";I1 +10110 PRINT"NUMBER OF STARDATES...";INT(I5) +10120 PRINT"NUMBER OF STARBASES...";I2 +10130 PRINT"STARBASE LOCATIONS...."; +10140 FORI=1TOI2:PRINTB2(I);"-";B3(I); +10150 IFI<>I2THENPRINT", "; +10160 NEXTI:PRINT:PRINT +10170 GOSUB7550 +10180 PRINT"THE ";S5$;" IS CURRENTLY IN THE ";G2$;" QUADRANT." +10190 GOSUB7260 +10200 PRINT:INPUT"READY TO CONTINUE";NL$:PRINTCHR$(26):GOSUB11090:GOSUB5650:RETURN +10210 INPUT"WARP FACTOR";K +10220 PRINT +10230 IFK<1THEN10340 +10240 IFK>10THEN10350 +10250 J=W1:W1=K:W2=W1*W1 +10260 IF(W1<=J)OR(W1<=6)THEN10290 +10270 IFW1<=8THEN10300 +10280 IFW1>8THEN10310 +10290 PRINT"'WARP FACTOR";W1;"CAPTAIN'":RETURN +10300 PRINT"*** OUR MAXIMUM SAFE SPEED IS WARP 6":RETURN"; +10310 IFW1=10THEN10330 +10320 PRINT"*** CAPTAIN, OUR ENGINES MAY NOT TAKE IT !":RETURN +10330 PRINT"-'AYE, CAPTAIN, WE'LL GIVE IT A TRY.'":RETURN +10340 PRINT"-'WE CAN'T GO BELOW WARP 1, CAPTAIN.'":RETURN +10350 PRINT"-'OUR TOP SPEED IS WARP 10, CAPTAIN.'" +10360 RETURN +10370 J3=0:IFD4(8)<>0THEN10490 +10380 IFS4<>0THEN10420 +10390 INPUT"SHIELDS ARE DOWN. DO YOU WANT THEM UP";B$ +10400 IFLEFT$(B$,1)="Y"THEN10450 +10410 RETURN +10420 INPUT"SHIELDS ARE UP. DO YOU WANT THEM DOWN";B$ +10430 IFLEFT$(B$,1)="Y"THEN10480 +10440 RETURN +10450 S4=1:S9=1:IFC5$<>"DOCKED"THENE1=E1-50 +10460 PRINT"SHIELDS RAISED.":IFE1<=0THEN10500 +10470 J3=1:RETURN +10480 S4=0:S9=1:PRINT"SHIELDS LOWERED.":J3=1:RETURN +10490 PRINT"SHIELDS DAMAGED AND DOWN. ":RETURN +10500 PRINT:PRINT"SHIELDS CONSUME ALL ENERGY." +10510 F9=4:GOSUB4710:RETURN +10520 IFX2<>0THEN10620 +10530 N=INT(RND(1)*I6+1):FORX=1TO8:FORY=1TO8 +10540 N=N-(G(X,Y)-INT(G(X,Y)/10)*10):IFN<=0THEN10560 +10550 NEXTY:NEXTX:RETURN +10560 IF(X<>Q1)OR(Y<>Q2)THEN10680 +10570 IFJ4<>0THEN10680 +10580 N=INT(RND(1)*(G(X,Y)-INT(G(X,Y)/10)*10))+1 +10590 FORX3=1TO10:FORY3=1TO10:IFQ$(X3,Y3)<>"*"THEN10610 +10600 N=N-1:IFN=0THEN10620 +10610 NEXTY3:NEXTX3 +10620 PRINT:PRINT"*** RED ALERT!! RED ALERT!! *** +10630 X3=X2:Y3=Y2 +10640 PRINT"*** INCIPIENT SUPERNOVA DETECTED AT SECTOR";X3;"-";Y3 +10650 X=Q1:Y=Q2:K=(X2-S6)^2+(Y2-S7)^2 +10660 IFK>1.5THEN10720 +10670 PRINT"*** EMERGENCY AUTO-OVERRIDE JAMMED ***":A2=1:GOTO10720 +10680 IFD4(9)<>0THEN10720 +10690 PRINT:PRINT"MESSAGE FROM STARFLEET COMMAND...STARDATE";INT(D0) +10700 PRINT"'SUPERNOVA IN QUADRANT";X;"-";Y; +10710 PRINT"....CAUTION ADVISED'" +10720 N=G(X,Y):R=INT(N/100):Q=0 +10730 IF(X<>Q1)OR(Y<>Q2)THEN10750 +10740 K3=0:C3=0 +10750 IFR=0THEN10810 +10760 R1=R1-R:IFR2=0THEN10810 +10770 FORL=1TOR2:IF(C1(L)<>X)OR(C2(L)<>Y)THEN10800 +10780 C1(L)=C1(R2):C2(L)=C2(R2):C1(R2)=0:C2(R2)=0 +10790 R2=R2-1:R=R-1:Q=1:IFR2=0THENF1(2)=1E+30 +10800 NEXTL +10810 IFR3=0THEN10850 +10820 FORL=1TOR3:IF(B2(L)<>X)OR(B3(L)<>Y)THEN10840 +10830 B2(L)=B2(R3):B3(L)=B3(R3):B2(R3)=0:B3(R3)=0:R3=R3-1 +10840 NEXTL +10850 IFX2=0THEN10890 +10860 N=G(X,Y)-INT(G(X,Y)/100)*100 +10870 S1=S1+(N-INT(N/10)*10):B1=B1+INT(N/10) +10880 K1=K1+R:K2=K2+Q +10890 IF(S2(X,Y)<>0)AND(D4(9)<>0)THENS2(X,Y)=LQ+G(X,Y) +10900 IF(D4(9)=0)OR((Q1=X)AND(Q2=Y))THENS2(X,Y)=1 +10910 G(X,Y)=1000 +10920 IF(R1<>0)OR((X=Q1)AND(Y=Q2))THEN10960 +10930 PRINTCHR$(26):PRINT"*** SUPERNOVA IN QUADRANT";X;"-";Y;"HAS DESTROYED THE" +10940 PRINT"REMAINDER OF THE ENEMY FLEET !!" +10950 F9=1:GOTO4710 +10960 IFA2=0THENRETURN +10970 F9=8:GOTO4710 +10980 IFK3<=1THENRETURN +10990 Z4=0:FORO=1TOK3-1:IFK7(O)<=K7(O+1)THEN11060 +11000 K=K7(O):K7(O)=K7(O+1):K7(O+1)=K +11010 K=K8(O):K8(O)=K8(O+1):K8(O+1)=K +11020 K=K4(O):K4(O)=K4(O+1):K4(O+1)=K +11030 K=K5(O):K5(O)=K5(O+1):K5(O+1)=K +11040 K=K6(O):K6(O)=K6(O+1):K6(O+1)=K +11050 Z4=1 +11060 NEXTO +11070 IFZ4<>0THEN10990 +11080 RETURN +11090 IFD(1)<>0THEN11330 +11100 PRINT:PRINT" 1 2 3 4 5 6 7 8 9 10" +11110 FORI=1TO10:IFI<10THENPRINT" "; +11120 PRINTI;:FORJ=1TO10:PRINTQ$(I,J);" ";:NEXTJ +11130 ONIGOTO11150,11160,11180,11190,11240 +11140 ONI-5GOTO11250,11260,11270,11300,11310 +11150 PRINT" STARDATE ";FNR(D0):GOTO11320 +11160 IFC5$<>"DOCKED"THENGOSUB7230 +11170 PRINT" CONDITION ";C5$:GOTO11320 +11180 PRINT" POSITION ";Q1;"-";Q2;", ";S6;"-";S7:GOTO11320 +11190 PRINT" LIFE SUPPORT ";:IFD4(5)<>0THEN11210 +11200 PRINT"ACTIVE":GOTO11320 +11210 IFC5$<>"DOCKED"THEN11230 +11220 PRINT"DAMAGED, SUPPORTED BY STARBASE":GOTO11320 +11230 PRINT"DAMAGED, RESERVES=";FNS(L1):GOTO11320 +11240 PRINT" WARP FACTOR ";FNR(W1):GOTO11320 +11250 PRINT" ENERGY";SPC(8);.01*INT(100*E1):GOTO11320 +11260 PRINT" TORPEDOS ";T4:GOTO11320 +11270 PRINT" SHIELDS ";:B$="DOWN,":IFS4<>0THENB$="UP," +11280 IFD4(8)>0THENB$="DAMAGED," +11290 PRINTB$;INT(100*S3/I8+.5);"%":GOTO11320 +11300 PRINT" KLINGONS LEFT ";R1:GOTO11320 +11310 PRINT" TIME LEFT ";FNS(R5) +11320 NEXTI:RETURN +11330 PRINT"SHORT RANGE SENSORS DAMAGED.":RETURN +11340 PRINT:PRINT"*** TIME WARP ENTERED ***":PRINT"YOU ARE TRAVELING "; +11350 IFS0<>0THEN11390 +11360 T1=-.5*I5*LOG(RND(1)) +11370 PRINT"FORWARD IN TIME";FNR(T1);"STARDATES." +11380 F1(2)=F1(2)+T1:GOTO11550 +11390 M=D0:D0=D9(1) +11400 PRINT"BACKWARD IN TIME";FNR(M-D0);"STARDATES.":S0=0 +11410 R1=D9(2):R2=D9(3):R3=D9(4):R4=D9(5):R5=D9(6) +11420 S1=D9(7):B1=D9(8):K1=D9(9):K2=D9(10) +11430 FORI=1TO8:FORJ=1TO8:G(I,J)=D9(I-1+8*(J-1)+11):NEXTJ:NEXTI +11440 FORI=75TO84:C1(I-74)=D9(I):NEXT +11450 FORI=85TO94:C2(I-84)=D9(I):NEXT +11460 FORI=95TO99:B2(I-94)=D9(I):NEXT +11470 FORI=100TO104:B3(I-99)=D9(I):NEXT:B4=D9(105):B5=D9(106) +11480 F1(1)=D0-.5*I5*LOG(RND(1)) +11490 IFR2<>0THENF1(2)=D0-(I5/R2)*LOG(RND(1)) +11500 F1(3)=D0-.5*I5*LOG(RND(1)) +11510 FORI=1TO8:FORJ=1TO8:IF10THEN11690 +11570 INPUT"NUMBER OF UNITS TO SHIELDS";Z3 +11580 IFZ3<0THENRETURN +11590 IFE1+S3-Z3>0THEN11620 +11600 PRINT"SCOTT HERE- 'WE ONLY HAVE";FNR(E1+S3);"UNITS LEFT.'" +11610 RETURN +11620 E1=E1+S3-Z3:S3=Z3:PRINT"--ENERGY TRANSFER COMPLETE--" +11630 PRINT"(SHIP ENERGY=";FNR(E1);" SHIELD ENERGY=";FNR(S3);")" +11640 J3=1 +11650 T1=.1:P5=(K3+4*C3)/48:IFP5<.1THENP5=.1 +11660 IFP5>RND(1)THENGOSUB790 +11670 IFA2<>0THENRETURN +11680 GOSUB3640:RETURN +11690 PRINT"TRANSFER PANEL DAMAGED.":RETURN +11700 J3=0:INPUT"HOW MANY STARDATES";Z5:IF(Z5"Y"THENRETURN +11720 R6=1 +11730 IFZ5<=0THENR6=0 +11740 IFR6=0THENRETURN +11750 T1=Z5:Z6=Z5 +11760 IFK3=0THEN11790 +11770 T1=1+RND(1):IFZ50THENRETURN +11810 GOSUB3640:J3=1:IFA2<>0THENRETURN +11820 Z5=Z5-Z6:GOTO11730 +11830 J3=0:IFD4(6)<>0THEN12300 +11840 INPUT"ENTER COURSE...";D2:IFD2<.01ORD2>12THENGOSUB12780 +11850 INPUT"DISTANCE...";D1 +11860 P=(D1+.05)*W1*W1*W1*(S4+1):IFPE1)THEN11910 +11890 PRINT" WE HAVEN'T THE ENERGY TO GO THAT FAR WITH"; +11900 PRINT" THE SHIELDS UP.":RETURN +11910 W=INT((E1/(D1+.05))^.333333):IFW<=0THEN11960 +11920 PRINT" WE HAVEN'T THE ENERGY. BUT WE COULD DO IT AT WARP";W +11930 IFS4<>0THEN11950 +11940 RETURN +11950 PRINT" IF YOU'LL LOWER THE SHIELDS.":RETURN +11960 PRINT" WE CAN'T DO IT, CAPTAIN. WE HAVEN'T GOT THE ENERGY." +11970 RETURN +11980 T1=10*D1/W2:IFT1<.8*R5THEN12040 +11990 PRINT:PRINT"MR. SPOCK - 'CAPTAIN, I COMPUTE THAT SUCH A TRIP" +12000 PRINT" WILL REQUIRE APPROXIMATELY";FNR(100*T1/R5); +12010 PRINT"PERCENT":PRINT" OF OUR REMAINING TIME. ARE YOU SURE "; +12020 INPUT "THIS IS WISE";B$:IFLEFT$(B$,1)="Y"THEN12040 +12030 J3=0:RETURN +12040 Q4=0:W=0:IFW1<=6THEN12200 +12050 P=D1*(6-W1)^2/66.6667:IFP>RND(1)THENQ4=1 +12060 IFQ4<>0THEND1=RND(1)*D1 +12070 W=0:IFW1<10THEN12090 +12080 IF.25*D1>RND(1)THENW=1 +12090 IF(Q4=0)AND(W=0)THEN12200 +12100 A=(15-D2)*.5236:X1=-SIN(A):X2=COS(A) +12110 B8=ABS(X1):IFABS(X2)>ABS(X1)THENB8=ABS(X2) +12120 X1=X1/B8:Y1=Y1/B8:N=INT(10*D1*B8+.5):X=S6:Y=S7 +12130 IFN=0THEN12200 +12140 FORL=1TON +12150 X=X+X1:Q=INT(X+.5):IF(Q<1)OR(Q>10)THEN12200 +12160 Y=Y+Y1:R=INT(Y+.5):IF(R<1)OR(R>10)THEN12200 +12170 IFQ$(Q,R)="."THEN12190 +12180 Q4=0:W=0 +12190 NEXTL +12200 GOSUB5850:IFA2<>0THENRETURN +12210 E1=E1-D1*W1*W1*W1*(S4+1):IFE1>0THEN12230 +12220 F9=4:GOSUB4710:RETURN +12230 T1=10*D1/W2:IFW<>0THENGOSUB11340 +12240 IFQ4=0THEN12290 +12250 PRINT:PRINT"ENGINEERING TO BRIDGE--":PRINT" SCOTT HERE- "; +12260 PRINT"'WE'VE JUST BLOWN THE WARP ENGINES." +12270 PRINT" WE'LL HAVE TO SHUT 'ER DOWN HERE, CAPTAIN.'" +12280 D4(6)=D5*(3*RND(1)+1) +12290 J3=1:RETURN +12300 PRINT"WARP ENGINES DAMAGED.":RETURN +12310 ONSGN(D4(10))+2GOTO12320,12340,12330 +12320 PRINT"YE FAERIE QUEENE HAS NO SHUTTLE CRAFT.":RETURN +12330 PRINT"SHUTTLE CRAFT DAMAGED.":RETURN +12340 PRINT:PRINT"***ABANDON SHIP! ABANDON SHIP!" +12350 PRINT"***ALL HANDS ABANDON SHIP!":PRINT +12360 PRINT"YOU AND THE BRIDGE CREW ESCAPE IN THE GALILEO." +12370 PRINT"THE REMAINDER OF THE CREW BEAMS DOWN" +12380 PRINT"TO THE NEAREST HABITABLE PLANET.":IFR3<>0THEN12400 +12390 F9=9:GOSUB4710:RETURN +12400 PRINT:PRINT"YOU ARE CAPTURED BY KLINGONS AND RELEASED TO" +12410 PRINT"THE FEDERATION IN A PRISONER-OF-WAR EXCHANGE." +12420 PRINT"STARFLEET PUTS YOU IN COMMAND OF ANOTHER SHIP," +12430 PRINT"THE FAERIE QUEENE WHICH IS ANTIQUATED, BUT" +12440 PRINT"STILL USABLE.":N=INT(RND(1)*R3+1):Q1=B2(N):Q2=B3(N) +12450 S6=5:S7=5:GOSUB7260:Q$(S6,S7)="." +12460 FORL=1TO3:S6=INT(3*RND(1)-1+B6) +12470 IF(S6<1)OR(S7>10)THEN12500 +12480 S7=INT(3*RND(1)-1+B7):IF(S7<1)OR(S7>10)THEN12500 +12490 IFQ$(S6,S7)="."THEN12510 +12500 NEXTL:GOTO12450 +12510 S5$="FAERIE QUEENE":Q$(S6,S7)=LEFT$(S5$,1):C5$="DOCKED" +12520 FORL=1TO12:D4(L)=0:NEXT:D4(10)=-1:E1=3000:I7=E1 +12530 S3=1500:I8=S3:T4=6:I9=T4:L1=3:J1=L1:S4=0:W1=5:W2=25 +12540 RETURN +12550 IFD4(11)=0THEN12580 +12560 PRINT"COMPUTER DAMAGED - CANNOT EXECUTE DESTRUCT SEQUENCE" +12570 RETURN +12580 PRINT:PRINT" ---WORKING---" +12590 PRINT"IDENTIFICATION-POSITIVE" +12600 PRINT"SELF-DESTRUCT-SEQUENCE-ACTIVATED":J=3 +12610 FORI=10TO6STEP-1:PRINTSPC(J);I:GOSUB12760:J=J+3:NEXT +12620 PRINT"ENTER-YOUR-MISSION-PASSWORD-TO-CONTINUE" +12630 PRINT"SELF-DESTRUCT-SEQUENCE-OTHERWISE-DESTRUCT" +12640 PRINT"SEQUENCE-WILL-BE-ABORTED" +12650 INPUTB$:IFB$<>X$THEN12740 +12660 PRINT"PASSWORD-ACCEPTED":J=10 +12670 FORI=5TO1STEP-1:PRINTSPC(J);I:GOSUB12760:J=J+3:NEXT +12680 PRINT:PRINT"*****ENTROPY OF ";S5$;" MAXIMIZED*****" +12690 PRINT:IFK3=0THEN12730 +12700 W=20*E1:FORL=1TOK3:IFK6(L)*K7(L)>WTHEN12720 +12710 A5=K4(L):A6=K5(L):T2$=Q$(A5,A6):GOSUB3160 +12720 NEXTL +12730 F9=10:GOSUB4710:RETURN +12740 PRINT"PASSWORD-REJECTED" +12750 PRINT"CONTINUITY-EFFECTED":PRINT:RETURN +12760 K=12345:FORM=1TO90:K=K+1:NEXTM:RETURN +12770 FORI=1TO10:GOTO11130:RETURN +12780 PRINT"---> COURSE(S) .01-12 ONLY !!!":RETURN + \ No newline at end of file diff --git a/disks/images/b/WEATHER.ASC b/disks/images/b/WEATHER.ASC new file mode 100644 index 0000000..1d478c4 --- /dev/null +++ b/disks/images/b/WEATHER.ASC @@ -0,0 +1,255 @@ +100 DIM S$(10) +110 PRINT"THIS PROGRAM WILL ATTEMPT TO PREDICT TOMORROWS WEATHER IF" +120 PRINT"GIVEN THE WEATHER STATISTICS FROM THE PAST TWO DAYS." +130 PRINT TAB(5);"SEASON" +140 INPUT S$(1) +150 GOSUB 1500 +160 GOTO 130 +170 PRINT"AFTER THE FOLLOWING QUESTION MARKS YOU WILL BE REQUIRED" +180 PRINT"TO INPUT TWO VALUES, ONE FOR YESTERDAY'S READING AND ONE" +190 PRINT"FOR TODAY'S READING. SEPERATE THESE READINGS BY A COMMA." +200 PRINT TAB(5);"TEMPERATURE" +210 INPUT T1,T2 +220 GOSUB 1570 +230 GOTO 200 +240 PRINT TAB(5);"BAROMETER" +250 INPUT B1,B2 +260 GOSUB 1640 +270 GOTO 240 +280 PRINT TAB(5);"BAROMETER TENDENCY(1=RISING,2=FALLING,3=STEADY):" +290 INPUT T3,T4 +300 GOSUB 1710 +310 GOTO 280 +320 PRINT TAB(5);"RELATIVE HUMIDITY" +330 INPUT H1,H2 +340 GOSUB 1780 +350 GOTO 320 +360 PRINT TAB(5);"CLOUDS(1=STRATUS,2=CUMULUS,3=CIRRUS)" +370 INPUT C1,C2 +380 GOSUB 1850 +390 GOTO 360 +400 PRINT TAB(5);"CLOUD COVER(PERCENTAGE)" +410 INPUT C4,C5 +420 GOSUB 1920 +430 GOTO 400 +440 PRINT TAB(5);"WIND DIRECTION (1=NORTH,2=SOUTH,3=EAST,4=WEST)" +450 INPUTD1,D2 +460 GOSUB 1990 +470 GOTO 440 +480 PRINT TAB(5);"WIND SPEED" +490 INPUT S2,S3 +500 GOSUB 2060 +510 GOTO 480 +520 PRINT +530 PRINT +540 PRINT +550 PRINT"------------------------------------------------------" +560 PRINT"PRESENT SEASON IS ";S$(1) +570 PRINT +580 PRINT "FORECAST FOR TOMORROW:" +590 PRINT +600 PRINT +610 PRINT"TEMPERATURES:" +620 LET T7=((T1+T2)/2)-30 +630 LET T6=T7+10 +640 PRINT "LOWS TONIGHT BETWEEN";T7;"AND";T6;"DEGREES" +650 LET T9=((T1+T2)/2)+5 +660 LET T8=T9-5 +670 PRINT "HIGHS TOMORROW NIGHT BETWEEN";T8;"AND";T9;"DEGREES" +680 LET T0=T7-5 +690 PRINT "LOWS TOMORROW NIGHT BETWEEN ";T0;"AND";T7;"DEGREES" +700 LET B4=(B1+B2)/2 +710 B0=INT(ABS(B1-B2)) +720 LET T9=(T3+T4)/2 +730 LET T9=INT(T9) +740 IF T9=2 THEN 780 +750 IF T9=3 THEN 800 +760 PRINT"BAROMETER";B4;" AND RISING." +770 GOTO 810 +780 PRINT"BAROMETER";B4;" AND FALLING." +790 GOTO 810 +800 PRINT"BAROMETER";B4;" AND STEADY." +810 LET H3=((H1+H2)/2)+5 +820 LET H4=H3-5 +830 PRINT "HUMIDITY BETWEEN ";H4;"AND ";H3;"PERCENT" +840 LET C3=(C1+C2)/2 +850 LET C3=INT(C3) +860 LET C9=((C4+C5)/2)+5 +870 LET C8=C9-5 +880 PRINT"CLOUD COVER BETWEEN";C8;"AND";C9;"PERCENT" +890 IF C3=2 THEN 940 +900 IF C3=3 THEN 970 +910 PRINT"CLOUD HEIGHT BETWEEN 500 TO 580 FEET." +920 PRINT"MAJOR CLOUD TYPE WILL BE STRATUS." +930 GOTO 990 +940 PRINT"CLOUD HEIGHT BETWEEN 1550 TO 1800 FEET." +950 PRINT"MAJOR CLOUD TYPE WILL BE CUMULUS." +960 GOTO 990 +970 PRINT"CLOUD HEIGHT BETWEEN 16500 TO 17000 FEET." +980 PRINT"MAJOR CLOUD TYPE WILL BE CIRRUS." +990 LET D5=(D1+D2)/2 +1000 LET D5=INT(D5) +1010 LET S5=((S2+S3)/2)+5 +1020 LET S6=S5-5 +1030 IF D5=2 THEN 1080 +1040 IF D5=3 THEN 1100 +1050 IF D5=4 THEN 1120 +1060 PRINT"WIND FROM THE NORTH FROM";S6;"TO";S5;"MPH" +1070 GOTO 1130 +1080 PRINT"WIND FROM THE SOUTH FROM";S6;"TO";S5;"MPH" +1090 GOTO 1130 +1100 PRINT "WIND FORM THE EAST FROM";S6;"TO";S5;"MPH" +1110 GOTO 1130 +1120 PRINT"WIND FROM THE WEST FROM";S6;"TO";S5;"MPH" +1130 PRINT"CHANCE OF PRECIPITATION:" +1140 LET P1=INT((((C5/2)+B2)+C2)/.5) +1150 IF P1>100 THEN 2170 +1160 PRINT "TONIGHT";P1;"%" +1170 LET P2=INT(((C9/2)+B4)+C3) +1180 IF P2>100 THEN 2190 +1190 PRINT"TOMORROW";P2;"%" +1200 IF P3>100 THEN 2210 +1210 PRINT"TOMORROW NIGHT";P3;"%" +1220 PRINT +1230 IF C2=2 THEN 1340 +1240 IF C2=3 THEN 1420 +1250 PRINT"FORECAST FOR TOMORROWS WEATHER:" +1260 PRINT +1270 PRINT"IT SHOULD BE FAIR TOMORROW." +1280 IF S$(1)="SPRING"THEN 1320 +1290 IF S$(1)="SUMMER"THEN 1320 +1300 PRINT"IT SHOULD BE COOLER TOMORROW WITH NO PRECIPITATION LIKELY." +1310 GOTO 1490 +1320 PRINT"IT SHOULD BE WARMER TOMORROW WITH NO PRECIPITATION LIKELY." +1330 GOTO 1490 +1340 PRINT"FORECAST FOR TOMORROWS WEATHER." +1350 PRINT +1360 IF S$(1)="SUMMER"THEN 1390 +1370 PRINT"IT SHOULD BE FAIR TOMORROW." +1380 GOTO 1280 +1390 PRINT"IF THEY ARE HEAVY CLOUDS--BE READY FOR RAIN." +1400 PRINT"IF THE CLOUDS ARE LIGHT--IT WILL BE FAIR." +1410 GOTO 1490 +1420 IF S$(1)="FALL" THEN 1490 +1430 PRINT +1440 IF S$(1)="SPRING"THEN 1480 +1450 IF S$(1)="SUMMER"THEN 1480 +1460 PRINT"TOMORROW,EXPECT SNOW TO FALL FOLLOWED BY HIGHER TEMPERATURES." +1470 GOTO 1490 +1480 PRINT"TOMORROW,EXPECT RAIN TO FALL FOLLOWED BY HIGHER TEMPERATURES." +1490 GOTO 2130 +1500 IF S$(1)="WINTER"THEN 170 +1510 IF S$(1)="FALL"THEN 170 +1520 IF S$(1)="SPRING"THEN 170 +1530 IF S$(1)="SUMMER" THEN 170 +1540 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(SEASONS:WINTER,SPRING"; +1550 PRINT"FALL,SUMMER)..." +1560 RETURN +1570 IF T1>135 THEN 1620 +1580 IF T1<-80 THEN 1620 +1590 IF T2>135 THEN 1620 +1600 IF T2<-80 THEN 1620 +1610 GOTO 240 +1620 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(NORMALS-80-135)..." +1630 RETURN +1640 IF B1>31.5 THEN 1690 +1650 IF B1<28.5 THEN 1690 +1660 IF B2>31.5 THEN 1690 +1670 IF B2<28.5 THEN 1690 +1680 GOTO 280 +1690 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(NORMALS:28.5-31.5)..." +1700 RETURN +1710 IF T3<1 THEN 1760 +1720 IF T3>3 THEN 1760 +1730 IF T4<1 THEN 1760 +1740 IF T4>3 THEN 1760 +1750 GOTO 320 +1760 PRINT TAB(5);"LETS TRY THAT ONE AGAIN..." +1770 RETURN +1780 IF H1<0 THEN 1830 +1790 IF H1>100 THEN 1830 +1800 IF H2<0 THEN 1830 +1810 IF H2>100 THEN 1830 +1820 GOTO 360 +1830 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(HUMIDITY:0-100)..." +1840 RETURN +1850 IF C1<1 THEN 1900 +1860 IF C1>3 THEN 1900 +1870 IF C2<1 THEN 1900 +1880 IF C2>3 THEN 1900 +1890 GOTO 400 +1900 PRINT TAB(5);"LETS TRY THAT ONE AGAIN..." +1910 RETURN +1920 IF C4<0 THEN 1970 +1930 IF C4>100 THEN 1970 +1940 IF C5<0 THEN 1970 +1950 IF C5>100 THEN 1970 +1960 GOTO 440 +1970 PRINT TAB(5);"LETS TRY THAT ONE AGAIN(COVER:0-100)..." +1980 RETURN +1990 IF D1<1 THEN 2040 +2000 IF D1>4 THEN 2040 +2010 IF D2<1 THEN 2040 +2020 IF D2>4 THEN 2040 +2030 GOTO 480 +2040 PRINT TAB(5);"LETS TRY THAT ONE AGAIN..." +2050 RETURN +2060 IF S2<0 THEN 2110 +2070 IF S2>75 THEN 2110 +2080 IF S3<0 THEN 2110 +2090 IF S3>75 THEN 2110 +2100 GOTO 520 +2110 PRINT TAB(5);"LETS TRY THAT ON E AGAIN(NORMAL:0-75)..." +2120 RETURN +2130 GOSUB 2230 +2140 PRINT"THE END" +2150 PRINT"---------------------------------------------------" +2160 STOP +2170 LET P1=100 +2180 GOTO 1160 +2190 LET P2=100 +2200 GOTO 1190 +2210 LET P3=100 +2220 GOTO 1210 +2230 IF D2=2 THEN 2390 +2240 IF D2=3 THEN 2480 +2250 IF D2=1 THEN 2580 +2260 IF B2=>30.2 THEN 2340 +2270 IF B2=>30.1 THEN 2300 +2280 PRINT"IT WILL BE CLEARING AND COLDER TOMORROW." +2290 GOTO 2620 +2300 IF T2=3 THEN 2330 +2310 PRINT"IT WILL BE FAIR TOMORROW, FOLLOWED BY WINDS AND PRECIPITATION." +2320 GOTO 2620 +2330 PRINT"IT WILL BE FAIR TOMORROW, WITH LITTLE TEMPERATURE CHANGE." +2340 IF T2=3 THEN 2370 +2350 PRINT"IT WILL BE FAIR TOMORROW WITH SLOWLY RISING TEMPERATURES." +2360 GOTO 2620 +2370 PRINT "IT WILL BE CONTINUED FAIR TOMORROW." +2380 GOTO 2620 +2390 IF B2<=29.8 THEN 2450 +2400 IF B2<=30! THEN 2430 +2410 PRINT"IT WILL BE WINDY WITH RAIN IN 12-24 HOURS." +2420 GOTO 2620 +2430 PRINT"IT WILL BE CLEARING AND FAIR FOR SEVERAL DAYS FOLLOWING." +2440 GOTO 2620 +2450 PRINT"THERE WILL BE A SEVERE STORM IN 24 HOURS FOLLOWED BY "; +2460 PRINT"CLEARING." +2470 GOTO 2620 +2480 IF B2<=29.8 THEN 2530 +2490 IF B2=> 30.1 THEN 2550 +2500 PRINT"IN WINTER, EXPECT SNOW WITH WINDS." +2510 PRINT"IN SUMMER, EXPECT A LONG DRY SPELL." +2520 GOTO 2620 +2530 PRINT"THERE WILL BE A NORTHEAST WIND WITH HEAVY PRECIPITATION." +2540 GOTO 2620 +2550 PRINT"IN WINTER, EXPECT SNOW IN 24 HOURS." +2560 PRINT"IN SUMMER, EXPECT A DRY SPELL." +2570 GOTO 2620 +2580 IF B2<=30! THEN 2610 +2590 PRINT"RAIN WILL CONTINUE WITH WINDS FOR 36 HOURS, THEN CLEARING." +2600 GOTO 2620 +2610 PRINT "RAIN WILL FALL IN 12 TO 18 HOURS." +2620 RETURN +UE WITH WINDS FOR 36 HOURS, THEN CLEARING." +2600 GOTO 2620 \ No newline at end of file diff --git a/disks/images/b/WORD-PZL.ASC b/disks/images/b/WORD-PZL.ASC new file mode 100644 index 0000000..9e21713 --- /dev/null +++ b/disks/images/b/WORD-PZL.ASC @@ -0,0 +1,221 @@ +100 CLEAR 1200 +110 B$="." +120 INPUT"INPUT X AND Y DIMENSIONS ";X,Y +130 IF X>30 OR Y>30 THEN 120 +140 IF X>Y THEN U0=X:GOTO 180 +150 U0=Y +160 INPUT"NUMBER OF WORDS ";N +170 C1=100*INT(N/10):IF C1<100 THEN C1=100 +180 DIM W$(50),A$(X,Y),N$(N),L(N,4) +190 W$(1)="DUMMEY ARGUMENT" +200 GOTO2150 +210 GOSUB 1960 +220 GOTO2020 +230 INPUT"PUNCH LIST ON TAPE";T$:IF LEFT$(T$,1)="Y" THEN GOTO 2220 +240 Q8=1 +250 GOSUB 1940 +260 PRINT:PRINT Q8 +270 FOR I1=1 TO N +280 GOTO 360 +290 PRINT:PRINT"FIRST CHAR. CHANGED ON PASS";C0;" OF THE";I1;"TH WORD" +300 A$(L(1,1),L(1,2))=LEFT$(N$(1),1) +310 GOTO430 +320 REM +330 L(I1,1)=A:L(I1,2)=B:L(I1,3)=D +340 L(I1,4)=C0 +350 GOTO 1580 +360 C0=0 +370 S$=N$(I1) +380 Z=LEN(S$)-1 +390 GOSUB 1540 +400 C0=C0+1 +410 IF I1=1 THEN GOTO 430 +420 IF A$(L(1,1),L(1,2))<>LEFT$(N$(1),1) THEN GOTO 290 +430 IF C0/C1<>INT(C0/C1) THEN 450 +440 PRINT S$;" TRY#";C0 +450 IF C0Y THEN 390 +510 FOR I=1 TO LEN(S$) +520 A1=A:B1=B+I-1 +530 GOSUB 1910 +540 GOSUB 1930 +550 IF L$=B$ OR L$=N1$ THEN 570 +560 GOTO 390 +570 NEXT I +580 FOR I=1 TO LEN(S$) +590 GOSUB 1910 +600 A$(A,B+I-1)=N1$ +610 NEXT I +620 GOTO 320 +630 IF B+Z>Y OR A-Z<1 THEN390 +640 FOR I=1 TO LEN(S$) +650 A1=A-(I-1):B1=B+I-1 +660 GOSUB 1910 +670 GOSUB 1930 +680 IF L$=B$ OR L$=N1$ THEN 700 +690 GOTO 390 +700 NEXT I +710 FOR I=1 TO LEN(S$) +720 GOSUB 1910 +730 A$(A-(I-1),B+I-1)=N1$ +740 NEXT I +750 GOTO 320 +760 IF A-Z<1 THEN 390 +770 FOR I=1 TO LEN(S$) +780 A1=A-(I-1):B1=B +790 GOSUB 1910 +800 GOSUB 1930 +810 IF L$=B$ OR L$=N1$ THEN 830 +820 GOTO 390 +830 NEXT I +840 FOR I=1 TO LEN(S$) +850 GOSUB 1910 +860 A$(A-(I-1),B)=N1$ +870 NEXT I +880 GOTO320 +890 IF A-Z<1 OR B-Z<1 THEN390 +900 FOR I=1 TO LEN(S$) +910 A1=A-(I-1):B1=B-(I-1) +920 GOSUB 1910 +930 GOSUB 1930 +940 IF L$=B$ OR L$=N1$ THEN960 +950 GOTO 390 +960 NEXT I +970 FOR I=1 TO LEN(S$) +980 GOSUB 1910 +990 A$(A-(I-1),B-(I-1))=N1$ +1000 NEXT I +1010 GOTO 320 +1020 IF B-Z<1 THEN 390 +1030 FOR I=1 TO LEN(S$) +1040 A1=A:B1=B-(I-1) +1050 GOSUB 1910 +1060 GOSUB 1930 +1070 IF L$=B$ OR L$=N1$ THEN 1090 +1080 GOTO 390 +1090 NEXT I +1100 FOR I=1 TO LEN(S$) +1110 GOSUB 1910 +1120 A$(A,B-(I-1))=N1$ +1130 NEXT I +1140 GOTO 320 +1150 IF A+Z>X OR B-Z<1 THEN390 +1160 FOR I=1 TO LEN(S$) +1170 A1=A+I-1:B1=B-(I-1) +1180 GOSUB 1910 +1190 GOSUB 1930 +1200 IF L$=N1$ OR L$=B$ THEN1220 +1210 GOTO390 +1220 NEXT I +1230 FOR I=1 TO LEN(S$) +1240 GOSUB 1910 +1250 A$(A+I-1,B-(I-1))=N1$ +1260 NEXT I +1270 GOTO320 +1280 IF A+Z>X THEN 390 +1290 FOR I=1 TO LEN(S$) +1300 A1=A+I-1:B1=B +1310 GOSUB 1910 +1320 GOSUB 1930 +1330 IF L$=N1$ OR L$=B$ THEN1350 +1340 GOTO 390 +1350 NEXT I +1360 FOR I=1 TO LEN(S$) +1370 GOSUB 1910 +1380 A$(A+I-1,B)=N1$ +1390 NEXT I +1400 GOTO 320 +1410 IF A+Z>X OR B+Z>Y THEN390 +1420 FOR I=1 TO LEN(S$) +1430 A1=A+I-1:B1=B+I-1 +1440 GOSUB 1910 +1450 GOSUB 1930 +1460 IF L$=B$ OR L$=N1$ THEN 1480 +1470 GOTO 390 +1480 NEXT I +1490 FOR I=1 TO LEN(S$) +1500 GOSUB 1910 +1510 A$(A+I-1,B+I-1)=N1$ +1520 NEXT I +1530 GOTO320 +1540 A=INT(X*RND(8)+1) +1550 B=INT(Y*RND(8)+1) +1560 D=INT(8*RND(5)+1) +1570 RETURN +1580 NEXT I1 +1590 GOTO 1610 +1600 FOR I=1TOX:FORJ=1TOY:PRINTA$(I,J);" ";:NEXTJ:PRINT:NEXTI +1610 FOR I=1 TO 5:PRINT:NEXT I +1620 PRINT"THE";N;"HIDDEN WORDS ARE":PRINT +1630 Z=2:FORI=1TON:PRINTTAB(Z);N$(I);:Z=Z+18:IFZ>60 THENZ=2:PRINT +1640 NEXT I:PRINT:PRINT:PRINT +1650 FOR I=1 TO X +1660 FOR J=1 TO Y +1670 IF A$(I,J)=B$ THEN 1770 +1680 PRINT A$(I,J);" "; +1690 NEXT J +1700 PRINT +1710 NEXT I +1720 PRINT +1730 GOSUB 1800 +1740 PRINT +1750 GOTO 240 +1760 END +1770 A$(I,J)=CHR$(INT(26*RND(1)+65)) +1780 GOTO 1680 +1790 PRINT +1800 REM +1810 AN=1 +1820 PRINT "THE HIDDEN WORDS ARE LOCATED AT" +1830 FOR K=1 TO N +1840 PRINT N$(K); +1850 IF AN=0 THEN PRINT: GOTO 1880 +1860 PRINT TAB(30);L(K,1);",";L(K,2);",";L(K,3); +1870 PRINT ",";L(K,4) +1880 NEXT K +1890 RETURN +1900 END +1910 N1$=MID$(S$,I,1) +1920 RETURN +1930 L$=A$(A1,B1):RETURN +1940 FORI=1TOX:FORJ=1TOY:A$(I,J)=B$:NEXT J,I +1950 RETURN +1960 FOR I=1 TO N +1970 PRINT"WORD #";I; +1980 INPUT N$(I) +1990 IF LEN(N$(I))>U0 THEN1970 +2000 NEXT I +2010 RETURN +2020 IF N<3 THEN GOTO240 +2030 FOR J=2 TO (N-1) +2040 L=0:M=0 +2050 FOR I=J TO N +2060 IF LEN(N$(I))>L THEN L=LEN(N$(I)):M=I +2070 NEXT I +2080 T$=N$(M) +2090 FOR I=(M-1)TO J STEP -1 +2100 N$(I+1)=N$(I) +2110 NEXT I +2120 N$(J)=T$ +2130 NEXT J +2140 GOTO 230 +2150 INPUT"INPUT FROM TAPE";T$:IF LEFT$(T$,1)="N" THEN GOTO210 +2160 PRINT CHR$(17):REM TAPE READER ON +2170 FOR I=1 TO N +2180 INPUT N$(I) +2190 NEXT I +2200 PRINT CHR$(19):REM TAPE READER OFF +2210 GOTO 2020 +2220 NULL6 +2230 PRINT CHR$(18);:REM TAPE PUNCH ON +2240 FOR I=1TO75:PRINT CHR$(0);:NEXT I:REM LEADER +2250 FOR I=1TON:PRINTN$(I):NEXT I +2260 FOR I=1TO75:PRINT CHR$(0);:NEXT I:PRINT CHR$(20) +2270 NULL0:GOTO240 +XT I:REM LEADER +2250 FOR I=1TON:PRINTN$(I):NEXT I +2260 FOR I=1TO75:PRINT CHR$ \ No newline at end of file diff --git a/disks/images/b/starwarp.bas b/disks/images/b/starwarp.bas new file mode 100644 index 0000000..3bf8187 --- /dev/null +++ b/disks/images/b/starwarp.bas @@ -0,0 +1 @@ +1 CLEAR 10 print "Press any key to continue..." 15 a=rnd(0):if inkey$="" goto 15 20 RANDOMize(a) 30 GOSUB 5010: REM CLS 35 PRINT "S T A R W A R P":PRINT 40 DIM N$(5),O$(21),Z$(21),L$(8),R$(4),K$(30),T$(5) 50 FOR I=1 TO 8:READ L$(I):NEXT 60 DATA GAMMA 7,ALPHA CENTAURI,SIRIUS 12,BETEGEUSE 7,SOL 3,ANTARES 9,ALDERBARAN,ANDROMEDA 70 FOR I=1 TO 5:READ N$(I):NEXT I 80 DATA ENTERPRISE,EXCALIBER,DEFIANT,EXETER,ENTERPRISE 90 FOR I=1 TO 3:READ K$(I):NEXT I 100 DATA KLINGON,ROMULAN,ALIEN 110 FOR I=1 TO 4:READ R$(I):NEXT I 120 DATA CTHULU,QUARK,CLIXNIP,XOTOP 130 FOR I=1 TO 5:READ T$(I):NEXT I 140 DATA KLEEK,RYJKA,DYSNIP,JOJLM,TWEEL 150 FOR I=1 TO 21:READ O$(I):NEXT I 160 DATA RANGE AND BEARING OF THE ENEMY 170 DATA FIRE FORWARD PHASER BANK 180 DATA FIRE REAR PHASER BANK 190 DATA FIRE FORWARD PHOTON TORPEDOES 200 DATA FIRE REAR PHOTON TORPEDOES 210 DATA LAUNCH ANTI-MATTER PROBE 220 DATA COME UP ON THE ENEMY VESSEL 230 DATA RETREAT FROM THE ENEMY 240 DATA APPROACH ENEMY AT WARP SPEED 250 DATA RETREAT AT TOP WARP SPEED 260 DATA "USE OPTIMUM SHIELD DEPLOYMENT, MR. SULU" 270 DATA "TURN US ABOUT 180 DEGREES, MR. SULU" 280 DATA "MR. SPOCK, WHAT ARE OUR CHANCES OF A HIT?" 290 DATA "MR. SPOCK, WHAT OPTIONS ARE AVAILABLE?" 300 DATA "MR. SPOCK, FULL DAMAGE REPORT" 310 DATA "LIEUTENANT, OPEN A VOICE CHANNEL TO STAR FLEET" 320 DATA "LET'S WAIT, WHAT WILL THE ENEMY DO NEXT?" 330 DATA ACTIVATE COMPUTER DESTRUCT SEQUENCE 340 DATA "LIEUTENANT, OPEN A VOICE CHANNEL TO THE ENEMY." 350 DATA "TURN 90 DEGREES TO PORT, MR. CHEKOV" 360 DATA "TURN 60 DEGREES TO STAR-PORT, MR. CHEKOV" 370 FOR I=1 TO 21:READ Z$(I):NEXT I 380 DATA RANGE,PHASEF,PHASER,TORPF,TORPR,PROBE,CLOSE,AWAY 390 DATA PURSE,ESCAPE,SHIELDS,ROTATE,CHANCES,COMMANDS 400 DATA DAMAGE,BLUFF,WAIT,SUICIDE,SURRENDER,LVEER,RVEER 410 X=INT(RND(0)*5)+1:A=X 420 PRINT"SPACE THE FINAL FRONTIER..." 430 PRINT"THIS IS THE VOYAGE OF THE STARSHIP ";N$(X);" IT'S FIVE" 440 PRINT"YEAR MISSION, TO EXPLORE STRANGE NEW WOLDS, TO SEEK" 450 PRINT"OUT NEW LIFE AND NEW CIVILIZATIONS, TO BOLDY GO WHERE" 460 PRINT"NO MAN HAS GONE BEFORE" 470 PRINT:PRINT:PRINT:FOR I=1 TO 1000:NEXT I 480 PRINT"YEOMAN:";TAB(10)"SIR, ENTER YOUR NAME FOR THE LOG";:INPUT C$ 490 PRINT 500 PRINT"SPOCK:";TAB(10)"YOU ARE IN COMMAND OF THE ";N$(X);", CAPTAIN ";C$ 510 PRINT TAB(10)"DO YOU WISH A LIST OF POSSIBLE COMMANDS";:INPUT A$ 520 IF A$="YES" THEN GOSUB 3070:GOSUB 3260 521 T9=INT(RND(0)*3)+1:S9=INT(RND(0)*4)+1:U9=INT(RND(0)*5)+1:V9=INT(RND(0)*8)+1 530 PRINT:E$=K$(T9):F$=R$(S9):U$=T$(U9):D$=L$(V9):Y=50*(RND(0)-.5) 540 REM 550 PRINT C$;":";TAB(10)"CAPTAIN'S LOG, STARDATE";INT(RND(0))/10+2000 560 PRINT TAB(10)"WE ARE PRESENTLY ON COURSE FOR ";D$ 565 X=INT(RND(0)*5)+1 570 ON X GOTO 580,600,620,630,640 580 PRINT TAB(10)"TO RESCUE MINERS UNDER ATTACK BY ";E$ 590 PRINT TAB(10)"BATTLE CRUISERS.":GOTO 650 600 PRINT TAB(10)"WITH A CARGO OF DILITHIUM CRYSTALS TO POWER" 610 PRINT TAB(10)"THE COLONISTS STATION":GOTO 650 620 PRINT TAB(10)"TO SEARCH FOR NEW MINERALS FOR THE FEDERATION":GOTO 650 630 PRINT TAB(10)"WITH THE CURE FOR MARTIAN FLU":GOTO 650 640 PRINT TAB(10)"FOR OBSERVATION OF A BLACK HOLE" 650 GOSUB 3490:PRINT"SULU:";TAB(10)"SIR, I'M PICKING UP A VESSEL ON AN ATTACK" 660 PRINT TAB(10)"VECTOR WITH THE ";N$(A);"." 670 GOSUB 3490:PRINT"SPOCK:"TAB(10)"SHIPS COMPUTER IDICATES THAT IT IS THE" 680 PRINT TAB(10)E$;" VESSEL, ";F$;", CAPTAIN" 690 PRINT TAB(10)"UNDER COMMAND OF CAPTAIN ";U$ 700 GOSUB 3490:PRINT C$;":";TAB(10)"SOUND RED ALERT LT. UHURA" 710 GOSUB 3490:PRINT"UHURA: AYE, AYE, SIR!" 715 X=INT(RND(0)*2):IF X=0 THEN 715 720 IF X=1 THEN X$="SULU" ELSE X$="CHEKOV" 730 H1=0:H2=0:G=0:X=0:S=0 740 P=0 750 FOR I=1 TO 4:Z(I)=100:S(I)=100:NEXT 760 R=1000-(INT(RND(0)*100)+1) 770 B=INT(RND(0)*360)+1-180 780 B1=INT(RND(0)*360)+1-180 790 GOTO 820 800 IF I<7 THEN 840 810 IF I>12 THEN 840 820 GOSUB 3200 830 GOSUB 3490 840 PRINT:PRINT X$;":";TAB(10)"WHAT ARE YOUR ORDERS, SIR";:INPUT M$ 850 PRINT:I=0 860 FOR J=1 TO 21:IF Z$(J)=M$ THEN I=J 870 NEXT 880 IF I<1 OR I>21 THEN PRINT X$":";TAB(10)"TROUBLE HEARING YOU, SIR":GOTO 840 890 PRINT C$;":";TAB(10)O$(I) 900 ON I GOTO 820,910,920,930,940,950,960,960,970,970,1500,960,1550,1600,1610,980,2090,1990,2040,3430,3450 910 IF H1<7 THEN 1060 ELSE PRINT"CHEKOV: FORWARD PHASERS ARE DEAD, SIR.":GOTO 2090 920 IF H1<6 THEN 1360 ELSE PRINT"CHEKOV: READ PHASERS ARE DEAD, SIR.":GOTO 2090 930 IF H1<9 THEN 1370 ELSE PRINT"CHEKOV: FORWARD PHOTON TORPEDOES ARE DEAD, SIR.":GOTO 2090 940 IF H1<8 THEN 1410 ELSE PRINT"CHEKOV: REAR PHOTON TORPEDOES ARE DEAD, SIR.":GOTO 2090 950 IF H1<11 THEN 1420 ELSE PRINT"CHEKOV: PROBE LAUNCHER IS DEAD, SIR":GOTO 2090 960 IF H1<14 THEN 1450 ELSE PRINT"SULU: IMPULSE ENGINES ARE DEAD, SIR":GOTO 2090 970 IF H1<11 THEN 1450 ELSE PRINT"SULU: WARP DRIVE IS OUT, SIR":GOTO 2090 980 IF H2<11 THEN 990 ELSE PRINT"SPOCK: THE ";E$;" HAS NO ENGINES, SIR":GOTO 2090 990 IF G=0 THEN 1790 1000 PRINT"SPOCK: I DO NOT THINK THAT THE ";E$;"S WILL BE" 1010 PRINT TAB(10)"FOOLED BY THAT MANUEVER AGAIN, SIR" 1020 GOTO 2090 1030 IF ABS(B)<90 THEN 1050 1040 PRINT"CHEKOV: WRONG PHASER BANK CAPTAIN":GOTO 2090 1050 PRINT"CHEKOV: PHASERS FIRING, SIR" 1060 R9=R:B9=B:GOSUB 3390 1070 IF RND(0)=S(K1) THEN 1140 1130 K=K1 1140 NEXT 1150 IF S(K)>50 THEN 1170 1160 K=INT(RND(0)*4)+1 1170 H2=H2+V 1180 PRINT"SPOCK: A HIT ON SHIELD #";K 1190 IF S(K)=0 THEN 1230 1200 S(K)=S(K)-30*V*(RND(0)+.1) 1210 IF S(K)>0 THEN 2090 ELSE PRINT TAB(10)"WHICH IS NOW GONE, SIR":S(K)=0:GOTO 2090 1220 V=1:PRINT"CHEKOV: DIRECT HIT, SIR":GOTO 1110 1230 PRINT:PRINT"CHEKOV: GOT HIM, SIR" 1240 IF RND(0)>.5 THEN 3020 1250 GOSUB 3490:PRINT"SPOCK: THE";E$;" VESSEL REMAINING INTACT, CAPTAIN" 1260 GOSUB 3490:PRINT C$;":";TAB(10)"OPEN A HAILING FREQUENCY, LIEUTENANT" 1270 GOSUB 3490:PRINT"UHURA: HAILING FREQUENCY OPEN, SIR" 1280 GOSUB 3490:PRINT C$;":";TAB(10)"THIS IS CAPTAIN ";C$;" OF THE STARSHIP" 1290 PRINT TAB(10)N$(A);". PREPARE TO BEAM OVER SURVIVORS." 1300 IF RND(0)>.5 THEN 1350 1310 GOSUB 2490:PRINT U$;":";TAB(10)"I AM AFRAID THAT WILL BE IMPOSSIBLE," 1320 PRINT TAB(10)"CAPTAIN, SINCE I JUST ACTIVATED OUR AUTO-DESTRUCT" 1330 FOR I=10 TO 1 STEP-1:GOSUB 3500:PRINT TAB(10),I:NEXT 1340 PRINT:GOTO 3020 1350 GOSUB 3490:PRINT U$;":";TAB(10)"VERY WELL, CAPTAIN, OUR SHIELDS HAVE BEEN LOWERED":GOTO 3220 1360 IF ABS(B)<90 THEN 1040 ELSE GOTO 1050 1370 IF ABS(B)>=90 THEN 1040 1380 R9=R:B9=B:GOSUB 3350 1390 IF RND(0)>F9 THEN 1080 1400 IF RND(0)<.25 THEN 1100 ELSE GOTO 1220 1410 IF ABS(B)<90 THEN 1040 ELSE GOTO 1380 1420 IF X<10 THEN 1430 ELSE PRINT"CHEKOV: WE HAVE NO MORE PROBES, SIR":GOTO 2100 1430 X=X+1:IF RND(0)<.07135 THEN 1440 ELSE GOSUB 3490:PRINT"SPOCK: PROBE LOST, CAPTAIN":GOTO 2090 1440 GOSUB 3490:PRINT"SPOCK: THE PROBE IS HOMING IN ON THE ";F$;", SIR":GOTO 3020 1450 ON I-6 GOTO 1460,1470,1480,1490,1500,1530 1460 GOSUB 2790:R=ABS(R-Y):GOTO 2090 1470 GOSUB 2820:R=ABS(R+Y):IF R>5000 THEN 2700 ELSE GOTO 2090 1480 GOSUB 2830:R=ABS(R-2*Y):GOTO 2090 1490 GOSUB 2840:R=ABS(R+2*Y):IF R>5000 THEN 2700 ELSE GOTO 2090 1500 S=1:FOR J=2 TO 4:IF Z(J)<=Z(S) THEN 1510 ELSE S=J 1510 NEXT 1520 GOSUB 3500:PRINT:PRINT"SULU:";TAB(10)"SHIELD #";S;"IS IN POSITION, SIR":GOTO 840 1530 B=B+180 1540 IF B<=180 THEN 2090 ELSE B=B-360:GOTO 2090 1550 GOSUB 3490:PRINT"SPOCK: AT RANGE";R;"I WOULD ESTIMATE THE PROBABILITY" 1560 R9=R:B9=B:GOSUB 3390:F8=F8*100 1570 PRINT TAB(10)"OF A PHASER HIT AT";F8;"AND THE PROBABILITY" 1580 R9=R:B9=B:GOSUB 3350:F9=F9*100 1590 PRINT TAB(10)"OF A PHOTON TORPEDO HIT AT";F9:GOTO 840 1600 GOSUB 3070:GOTO 840 1610 GOSUB 3500:PRINT:PRINT"SPOCK: DAMAGES ARE AS FOLLOWS:":PRINT 1620 PRINT TAB(12)"SHIELD #";TAB(22)N$(A);TAB(35)F$ 1630 FOR J=1 TO 4:PRINT TAB(15)J;TAB(27)Z(J);TAB(38)S(J):NEXT J 1640 PRINT:PRINT TAB(10)N$(A);" DAMAGE "; 1650 IF H1>5.5 THEN 1660 ELSE PRINT"NONE":GOTO 1730 1660 PRINT:PRINT TAB(20)"REAR PHASERS OUT" 1670 IF H1<7 THEN 1730 ELSE PRINT TAB(20)"FORWARD PHASERS OUT" 1680 IF H1<8 THEN 1730 ELSE PRINT TAB(20)"REAR PHOTON TORPEDO DEAD" 1690 IF H1<9 THEN 1730 ELSE PRINT TAB(20)"FORWARD PHOTON TORPEDO DEAD" 1700 IF H1<11 THEN 1730 ELSE PRINT TAB(20)"PROBE LAUNCHERS DESTROYED" 1710 PRINT TAB(20)"WARP DRIVE LOST" 1720 IF H1<14 THEN 1730 ELSE PRINT TAB(20)"IMPULSE POWER LOST" 1730 PRINT:PRINT TAB(20)F$;" DAMAGE "; 1740 IF H2>5.5 THEN 1750 ELSE PRINT"NONE":PRINT:GOTO 840 1750 PRINT:PRINT TAB(20)"ALL PHASERS DEAD" 1760 IF H2<9 THEN PRINT:GOTO 840 ELSE PRINT TAB(20)"ALL TORPEDOES DEAD" 1770 IF H2<11 THEN PRINT:GOTO 840 ELSE PRINT TAB(20)"WARP DRIVE LOST" 1780 IF H2<14 THEN PRINT:GOTO 840 ELSE PRINT TAB(20)"IMPULSE ENGINES OUT":PRINT:GOTO 840 1790 PRINT TAB(10)"USE CODE 2" 1800 GOSUB 3490:PRINT"UHURA: BUT, SIR, THE ";E$;"S BROKE CODE 2 YESTERDAY, SIR" 1810 GOSUB 3490:PRINT C$;":";TAB(10)"CODE 2, LIEUTENANT, IMMEDIATELY!" 1820 GOSUB 3490:PRINT"UHURA: AYE, AYE, SIR. GO AHEAD, SIR" 1830 GOSUB 3490:PRINT C$;":";TAB(10)"THIS IS CAPTAIN ";C$;" OF THE STARHIP ";N$(A) 1840 GOSUB 3500:PRINT TAB(10)"WE ARE UNDER ATTACK BY THE ";E$;" SHIP ";F$ 1850 GOSUB 3500:PRINT TAB(10)"AND, IN ORDER TO PREVENT THIS SHIP FROM FALLING" 1860 GOSUB 3500:PRINT TAB(10)"INTO ENEMY HANDS, WE ARE ACTIVATING THE CORBOMITE" 1870 GOSUB 3500:PRINT TAB(10)"DEVICE. SINCE THIS WILL RESULT IN COMPLETE" 1880 GOSUB 3500:PRINT TAB(10)"ANNIHILATION OF ALL MATTER WITHIN A RANGE OF 5000" 1890 GOSUB 3500:PRINT TAB(10)"MEGAMETERS, ALL VESSELS SHOULD BE WARNED TO STAY" 1900 GOSUB 3500:PRINT TAB(10)"CLEAR OF THIS AREA FOR THE NEXT";INT(RND(0)*4)+1 1910 PRINT TAB(10)"SOLAR YEARS" 1920 G=1:IF RND(0)>.2 THEN 1960 1930 GOSUB 3490:PRINT"SULU: THE ";E$;" IS MOVING AWAY AT WARP 10, SIR" 1940 GOSUB 3490:PRINT"SPOCK: THE TACTIC APPEARS TO HAVE BEEN EFFECTIVE, SIR" 1950 PRINT TAB(10)"THE ";E$;"S HAVE BEEN REPULSED":GOTO 3220 1960 GOSUB 3490:PRINT"SULU: NO IMMEDIATE CHANGE IN ";E$;"S COURSE OR SPEED, SIR" 1970 GOSUB 3490:PRINT"SPOCK: IT WOULD SEEM THAT THEY HAVE, AS YOU HUMANS" 1980 PRINT TAB(10)"PUT IT, CALLED OUR BLUFF,' CAPTAIN":GOTO 2090 1990 GOSUB 3490:PRINT"COMPUTER ";:FOR JJ=12 TO 1 STEP -1:PRINT TAB(9)JJ:GOSUB 3500:NEXT 2000 PRINT TAB(10)"THE ";N$(A);"HAS BEEN DESTROYED" 2010 Q=INT(RND(0)*200)+1:GOSUB 3500:PRINT TAB(10)"RADIUS OF EXPLOSION";Q;"MEGAMETERS" 2020 IF Q>R THEN PRINT TAB(10) E$;" VESSEL DESTROYED" ELSE PRINT TAB(10) E$;" VESSEL REMAINS INTACT" 2030 GOTO 3220 2040 IF E$="ROMULAN" THEN PRINT"UHURA: NO ANSWER FROM THE ";F$;", SIR":GOTO 2090 2050 GOSUB 3490:PRINT C$;":";TAB(10)"THIS IS CAPTAIN ";C$;" OF THE STARSHIP ";S$ 2060 PRINT TAB(10)"WILL YOU ACCEPT OUR UNCONDITIONAL SURRENDER?" 2070 GOSUB 3490:PRINT U$;":";TAB(10)"ON BEHALF OF THE ";E$;" EMPIRE, I ACCEPT YOUR" 2080 PRINT TAB(10)"SURRENDER, PREPARE FOR IMMEDIATE BOARDING":GOTO 3220 2090 REM ENEMY MOVE 2100 IF H2<9 THEN 2290 2110 IF H2<11 THEN 2190 2120 IF H2>13.9 THEN 2650 2130 IF H1>10.9 THEN 2700 2140 IF H1>8.9 THEN 2170 2150 IF R5000 THEN 2700 ELSE GOTO 820 2170 IF RND(0)<.5 THEN 2160 2180 GOSUB 2820:R=ABS(R-Y):IF R>5000 THEN 2700 ELSE GOTO 820 2190 IF H1<7 THEN 2260 2200 IF H1<9 THEN 2150 2210 IF H1>10.9 THEN 2700 2220 IF RND(0)<.5 THEN 2170 2230 IF RND(0)<.5 THEN 2250 2240 GOSUB 2830:R=ABS(R+2*Y):IF R>5000 THEN 2700 ELSE GOTO 820 2250 GOSUB 2840:R=ABS(R-2*Y):GOTO 820 2260 IF R>700 THEN 2250 2270 IF R>200 THEN 2240 2280 GOTO 2150 2290 IF H2<6 THEN 2390 2300 IF H1<7 THEN 2370 2310 IF R<300 THEN 2250 2320 IF R>700 THEN 2240 2330 IF H1>7.9 THEN 2350 2340 IF INT(ABS(B1/90))>INT(ABS(B/90)) THEN 2250 2350 IF ABS(B1-90)>=ABS(B-90)-20 THEN 2850 2360 IF RND(0)<.5 THEN 2250 ELSE GOTO 2240 2370 R9=R:B9=B:GOSUB 3390:R9=R:B9=B1:GOSUB 3350 2380 IF F8>F9 THEN 2250 ELSE GOTO 2310 2390 IF H1<7 THEN 2450 2400 IF R>150 THEN 2420 2410 IF RND(0)<.5 THEN 2180 ELSE GOTO 2250 2420 IF R>=400 THEN 2440 2430 IF ABS(B1)<30 THEN 2880 ELSE GOTO 2180 2440 IF R>700 THEN 2240 ELSE GOTO 2340 2450 IF R>700 THEN 2240 2460 R9=R:B9=B1:GOSUB 3350:R9=9:B9=B1:GOSUB 3390 2470 IF F9>F8 THEN 2340 2480 IF H1>6.9 THEN 2500 2490 IF ABS(B1/90)>ABS(B/90) THEN 2250 2500 IF ABS(B1-90)>=ABS(B-90)-20 THEN 2880 ELSE GOTO 2250 2510 IF H1<6 THEN 2640 2520 T=H1-V:IF ABS(T-6)<.1 THEN 2540 2530 IF ABS(H1-6.26)>.3 THEN 2540 ELSE PRINT"CHEKOV: REAR PHASERS DEAD, SIR":GOTO 2640 2540 IF ABS(T-7)<.1 THEN 2560 2550 IF ABS(H1-7.25)>.3 THEN 2560 ELSE PRINT"CHEKOV: FORWARD PHASERS DEAD, SIR":GOTO 2640 2560 IF ABS(T-8)<.1 THEN 2580 2570 IF ABS(H1-8.25)>.3 THEN 2580 ELSE PRINT"CHEKOV: REAR PHOTON TORPEDOES DEAD, SIR":GOTO 2640 2580 IF ABS(T-9)<.1 THEN 2600 2590 IF ABS(T-9.25)>.3 THEN 2600 ELSE PRINT"CHEKOV: FORWARD PHOTON TORPEDOES DEAD, SIR":GOTO 2640 2600 IF ABS(T-11)<.1 THEN 2620 2610 IF ABS(T-11.25)>.3 THEN 2620 ELSE PRINT"CHEKOV: PROBE LAUNCHER AND WARP DRIVE GONE, SIR":GOTO 2640 2620 IF ABS(T-14)<.1 THEN 2640 2630 IF ABS(T-14.25)>.3 THEN 2640 ELSE PRINT"CHEKOV: IMPULSE ENGINES DEAD, SIR" 2640 RETURN 2650 IF P>0 THEN 800 2660 P=1:GOSUB 3490:PRINT"SPOCK: THE ";E$;" SHIP IS COMPLETELY CRIPPLED, SIR" 2670 PRINT TAB(10)"WILL YOU ALLOW THEM TO SURRENDER";:INPUT A$:IF A$="YES" THEN 1260 2680 PRINT"SPOCK: DO YOU WANT TO DESTROY THE ";F$;", CAPTAIN";:INPUT A$:IF A$="YES" THEN 840 ELSE GOTO 2710 2690 REM LOSS OF CONTACT 2700 GOSUB 3490:PRINT"SULU: CONTACT WITH THE ";E$;" VESSEL HAS BEEN LOST, SIR" 2710 GOSUB 3490:PRINT C$;":";TAB(10)"RESUME COURSE FOR ";D$;", MR. SULU" 2720 GOSUB 3490:PRINT"SULU: AYE, AYE, SIR":GOTO 3220 2730 REM 2740 GOSUB 3490:PRINT"SPOCK: SENSORS INDICATE THAT TI ";F$;" IS OVERLOADING" 2750 PRINT TAB(10)"WHAT REMAINS OF ITS ANTI-MATTER RODS. UNDOUBTEDLY" 2760 PRINT TAB(10)"A SUICIDAL MOVE, CAPTAIN. PODS WILL DETONATE" 2770 PRINT TAB(10)"IN 10 SECONDS..." 2780 GOSUB 3490:FOR JJ=10 TO 1 STEP -1:PRINT TAB(10)JJ:GOSUB 3500:NEXT JJ:GOTO 3020 2790 R=R-(INT(RND(0)*200)+1) 2800 B=INT(RND(0)*360)+1-180::B1=INT(RND(0)*360)+1-180:IF R<0 THEN R=-R 2810 RETURN 2820 R=R+(INT(RND(0)*200)+1):GOTO 2800 2830 R=R-(INT(RND(0)*400)+1):GOTO 2800 2840 R=R+(INT(RND(0)*400)+1):GOTO 2800 2850 GOSUB 3490:PRINT"SPOCK: THE ";E$;" IS FIRING PHOTON TORPEDOES AT US, SIR" 2860 R9=R:B9=B:IF RND(0)>F9 THEN 3010 2870 IF RND(0)<.4 THEN 2980 ELSE GOTO 2910 2880 GOSUB 3490:PRINT"SPOCK: THE ";E$;" IS FIRING PHASERS AT US, SIR" 2890 R9=R:B9=B1:GOSUB 3390:IF RND(0)>F8 THEN 3010 2900 IF RND(0)<.2 THEN 2980 2910 Y=.5:K=INT(RND(0)*4)+1:IF S=0 THEN 2930 2920 K=S 2930 PRINT TAB(10)"A HIT ON SHIELD #";K 2940 IF Z(K)<=0 THEN 2970 ELSE Z(K)=Z(K)-30*Y*(RND(0)+.1) 2950 H1=H1+V:GOSUB 2510:IF Z(K)>0 THEN 800 2960 Z(K)=0:PRINT TAB(10)"THAT'S IT FOR SHIELD #";K;", SIR":GOTO 800 2970 GOSUB 3490:PRINT"COMPUTER: THE ";N$(A);" HAS BEEN DESTROYED":GOTO 3220 2980 Y=1:K=INT(RND(0)*4)+1:IF S=0 THEN 3000 2990 K=S 3000 PRINT TAB(10)"A DIRECT HIT ON SHIELD #";K;", SIR":GOTO 2940 3010 PRINT TAB(10)"EVASIVE MANEUVERS WERE EFFECTED, NO DAMAGE":GOTO 800 3020 PRINT:Q=INT(RND(0)*200)+1:IF Q200 THEN 3380 3360 F9=1-(R9-500)^2/40000!:GOSUB 3510 3370 F9=F9+SIN(B7)*(3-INT(ABS(B9/90)))/3 3380 RETURN 3390 F8=0:IF R9>400 THEN RETURN 3400 F8=1-(R9-200)^2/40000!:GOSUB 3510 3410 F8=F8*SIN(B7)*(5-INT(ABS(B9/90)))/5 3420 RETURN 3430 IF H1>=14 THEN 960 3440 B=B+90:GOTO 1540 3450 IF H1>=14 THEN 960 3460 B=B-90:IF B>=0 THEN B=360-B 3470 GOTO 1540 3480 END 3490 PRINT:FOR II=1 TO 1000:NEXT II:RETURN 3500 FOR II=1 TO 500:NEXT II:RETURN 3510 B7=3.1415926#*ABS(90-ABS(B9))/180:RETURN 5000 REM CLEAR SCREEN 5010 PRINT CHR$(27);"[2J": RETURN \ No newline at end of file diff --git a/disks/images/c/BDS.LIB b/disks/images/c/BDS.LIB new file mode 100644 index 0000000..9288bdc --- /dev/null +++ b/disks/images/c/BDS.LIB @@ -0,0 +1,191 @@ + +; +; BDS.LIB for BDS C v1.51 January 19, 1985 +; +; Header file for .CSM assembly language source files. Contains +; addresses within the C.CCC run-time package to be used by the machine +; language CRL library functions. +; +; If you alter the C.CCC run-time package by reassembling CCC.ASM, +; be sure to go through this file and make sure all the addresses perfectly +; match the corresponding addresses resulting from the CCC.ASM assembly. +; Then the .CSM library functions will be ready to process with CASM.SUB. +; + + page 76 + +CPM: EQU 1 ;true if running under CP/M or MP/M II; else 0 +MPM2: EQU 0 ;true only if running under MP/M II + +; +; System addresses: +; + if not cpm +CCCORG: EQU WHATEVER ;if not runninng under cp/m, set this to load addr, +RAM: EQU WHATEVER2 ;set this to address of CCC's ram area +BASE: EQU WHATEVER3 ;and this to the base of system memory (`base' is + ;the re-boot location under cp/m; for non-cp/m oper- + ;ation, it should be set to a safe place to jump to on + ;error or user-abort. + endif + + + if cpm +base: equ 0000h ;either 0 or 4200h for CP/M systems +fcb: equ base+5ch ;default file control block +tbuff: equ base+80h ;sector buffer +bdos: equ base+5 ;bdos entry point +tpa: equ base+100h ;transient program area +nfcbs: equ 9 ;max number of open files allowed at one time +errorv: equ 255 ;error value returned by BDOS calls +cccorg: equ tpa ;where run-time package resides + + ;************************************************** +ram: equ 667h ;THIS WILL PROBABLY CHANGE IF YOU CUSTOMIZE CCC.ASM + ;************************************************** + endif + + +cr: equ 0dh ;ASCII codes: carriage return +lf: equ 0ah ; linefeed +newlin: equ lf ; newline +tab: equ 9 ; tab +bs: equ 08h ; backspace +cntrlc: equ 3 ; control-C + +; +; Subroutines in C.CCC (the addresses should be that of the +; appropriate jump vector entry points): +; + +fexitv: equ cccorg+09h ;where to go to terminate execution +error: equ cccorg+1dh ;return -1 in HL: +exit: equ error+3 ;close all open files and reboot + + if cpm +close: equ error+6 +setfcb: equ error+9 ;set up fcb at HL from text at DE +fgfd: equ error+12 ;set C according to whether file fd is open +fgfcb: equ error+15 ;figure address of internal fcb for file fd +setfcu: equ error+18 ;set up fcb with possible user number prefix +setusr: equ error+21 ;set current user area to high 5 bits of A +rstusr: equ error+24 ;reset user area to value before last setusr call +khack: equ error+33 ;Kirkland interrupt vector initialization +clrex: equ error+36 ;clear external data routine + endif + + +eqwel: equ cccorg+0e5h + +smod: equ cccorg+10fh +usmod: equ cccorg+129h +smul: equ cccorg+13fh +usmul: equ cccorg+16bh +usdiv: equ cccorg+189h +sdiv: equ cccorg+1cbh + +cmphd: equ cccorg+1ddh +cmh: equ cccorg+1fah +cmd: equ cccorg+202h + +ma1toh: equ cccorg+20ah ;get 1st stack element into HL and A +ma2toh: equ cccorg+213h ; 2nd +ma3toh: equ ma2toh+6 ; 3rd +ma4toh: equ ma2toh+12 ; 4th +ma5toh: equ ma2toh+18 ; 5th +ma6toh: equ ma2toh+24 ; 6th +ma7toh: equ ma2toh+30 ; 7th + +arghak: equ ma2toh+36 ;copy first 6 or so stack elements to argc area + +; +; The following addresses will depend on the value of RAM if you +; customize CCC.ASM....be sure they correspond to the assembly +; results of CCC.ASM in such cases. If you remove some of the data +; areas from CCC.ASM (in case they aren't needed), be sure to remove +; from here also. +; + + org ram + +errnum: ds 1 ;error code from file I/O operations +rseed: ds 8 ;the random generator seed +args: ds 14 ;"arghak" puts args passed on stack here. +iohack: ds 6 ;room for I/O subroutines for use by "inp" + ;and "outp" library routines + +allocp: ds 2 ;pointer to free storage for use by "sbrk" func +alocmx: ds 2 ;highest location to be made available to the + ;storage allocator + + ;20 bytes of misc. scratch & state variables: +tmp ds 1 +tmp1 ds 1 +tmp2 ds 2 +tmp2a ds 2 +unused ds 2 + +curusr ds 1 ;used to save current user number during file I/O +usrnum ds 1 ;set by "setfcu" to user number of given filename + + + ;Console I/O control data: +chmode db 0 ;0: single char mode, 1: line buffered mode +nleft db 0 ;# of chars left in buffer (if chmode == 1) +ungetl db 0 ;"ungetch" data byte (0 if no char pushback) +iobrf db 1 ;check for break on character input/output + +spsav ds 2 ;BDOS's saved SP value upon entry from CCP + + ds 4 ;total of 20 bytes of misc. data area + + +; +; Nothing beyond this point will ordinarily require any modifications +; by the user. +; + +extrns: equ cccorg+15h ;base of external data area (set by CLINK) +cccsiz: equ cccorg+17h ;size of C.CCC for use by CLINK only +codend: equ cccorg+19h ;address of byte following last byte of program code + ; (set by CLINK) +freram: equ cccorg+1bh ;first free address after external area + ; (set by CLINK) + + +arg1: equ args ;these are just convenient names for +arg2: equ args+2 ;the words in the "args" area +arg3: equ args+4 +arg4: equ args+6 +arg5: equ args+8 +arg6: equ args+10 +arg7: equ args+12 + +; +; BDOS call codes: +; + + if cpm +conin: equ 1 ;get a character from console +conout: equ 2 ;write a character to console +lstout: equ 5 ;write a character to list device +dconio: equ 6 ;direct console I/O (only for CP/M 2.0) +pstrng: equ 9 ;print string (terminated by '$') +getlin: equ 10 ;get buffered line from console +cstat: equ 11 ;get console status +select: equ 14 ;select disk +openc: equ 15 ;open a file +closec: equ 16 ;close a file +delc: equ 19 ;delete a file +reads: equ 20 ;read a sector (sequential) +creatc: equ 22 ;make a file +renc: equ 23 ;rename file +sdma: equ 26 ;set dma +gsuser: equ 32 ;get/set user code +readr: equ 33 ;read random sector +writr: equ 34 ;write random sector +cfsizc: equ 35 ;compute file size +srrecc: equ 36 ;set random record + endif + + \ No newline at end of file diff --git a/disks/images/c/BDSCPAT.LBR b/disks/images/c/BDSCPAT.LBR new file mode 100644 index 0000000..4b84713 Binary files /dev/null and b/disks/images/c/BDSCPAT.LBR differ diff --git a/disks/images/c/C.CCC b/disks/images/c/C.CCC new file mode 100644 index 0000000..a421d51 Binary files /dev/null and b/disks/images/c/C.CCC differ diff --git a/disks/images/c/C.SUB b/disks/images/c/C.SUB new file mode 100644 index 0000000..80facf9 --- /dev/null +++ b/disks/images/c/C.SUB @@ -0,0 +1,4 @@ +cc $1.c +clink $1 -sw +;$1 is ready for testing. + \ No newline at end of file diff --git a/disks/images/c/CASM.C b/disks/images/c/CASM.C new file mode 100644 index 0000000..9d7f388 --- /dev/null +++ b/disks/images/c/CASM.C @@ -0,0 +1,953 @@ +/* + CASM.C -- Written by Leor Zolman, 2/82 + + "C Assembly Language" preprocessor. Prepares .CSM-coded assembly + language source files for assembly using ASM.COM or MAC.COM. + See the CASM Appendix in the BDS C User's Guide for complete info. + + Modifications: + Adapted for v1.6, 5/86, LZ + Adapted For v1.5, 11/14/82, LZ + Enable n-level nested INCLUDEs, Cliff Lasser & Leor Zolman, 1/85 + Made to work with with CTOA CRL-to-ASM postprocessor, 11/83, K. Kenny + + Compile and link: + + cc casm.c -o -e4b00 + + l2 casm + (or) clink casm [-n] +*/ + +#include + +#define TITLE "BD Software CRL-format ASM Preprocessor v1.60\n" + + +/* + * Customizable definitions: + */ + +#define VIDEO 1 /* true for video terminal, false otherwise */ +#define DEFUSER "" /* default "include file" user area prefix */ + /* form: "nn/", or "" for currently logged */ +#define DEFDISK "" /* default disk for include files */ + /* form: "d:" , or "" for currently logged */ +#define CASMEXT ".CSM" /* extension on input files */ +#define ASMEXT ".ASM" /* extension on output files */ +#define SUBFILE "A:$$$.SUB" /* Submit file to erase on error. To not */ + /* erase any, use a null string ("") */ + +#define CONTROL_C 3 /* Abort character */ +#define EQUMAX 500 /* maximum number of EQU ops */ +#define FUNCMAX 100 /* maximum number of functions */ +#define NFMAX 25 /* max no. of extern funcs in one function */ +#define LABMAX 150 /* max number of local labels in one func */ +#define TXTBUFSIZE 2000 /* max text for labels & extern func. names */ +#define NESTMAX 3 /* max nesting of includes */ + +/* + * End of customizable section + */ + +#define DIRSIZE 512 /* max # of byte in CRL directory */ +#define TPALOC 0x100 /* base of TPA in your system */ + + /* Global data used throughout processing + of the input file: */ + +FILE *fptab[NESTMAX]; /* input file pointer table */ +FILE *cfp; /* currently active input file pointer */ + +FILE *ofp; /* FP for output file */ + +char *cfname; /* pointer to name of current input file */ +char iname[NESTMAX][30]; /* filenames for current input files */ +char oname[30]; /* filename of output file */ +int nestlev; /* nest level: 0 for top, max NESTMAX-1 */ +char wrkbuf[30]; + +char *equtab[EQUMAX]; /* table of absolute symbols */ +int equcount; /* # of entries in equtab */ + +char *fnames[FUNCMAX]; /* list of functions in the source file */ +int fcount; /* # of entries in fnames */ + +int lino,savlino[NESTMAX]; /* line number values used for error */ + /* reporting. */ + +char doingfunc; /* true if currently processing a function */ + +char errf; /* true if an error has been detected */ +char verbose; /* true to insert wordy comments in output */ +char careful; /* true to detect old CMAC.LIB macros */ +char blankflag; /* true if last line processed was null */ +char debug; /* true if debugging option given */ + + /* Global data used during the processing of a + single function in the source file: */ + +char *nflist[NFMAX]; /* list of needed functions for a function */ +int nfcount; /* number of entries in nflist */ + +struct { + char *labnam; /* name of function label */ + char defined; /* whether it has been defined yet */ +} lablist[LABMAX]; + +int labcount; /* number of local labels in a function */ + +char txtbuf[TXTBUFSIZE], /* where text of needed function names */ + *txtbufp; /* and function labels go */ + +char linbuf[MAXLINE], /* text line buffers */ + linsav[MAXLINE], + workbuf[MAXLINE], + undrbuf[MAXLINE], + pbuf[MAXLINE], *pbufp; + +char *cfunam; /* pointer to name of current function */ +int relblc; /* relocation object count for a function */ + +char pastnfs; /* true if we've passed all needed function */ + /* declarations ("external" pseudo ops) */ + +int argcnt; /* values set by the "parse_line" function */ +char *label, + *op, + *argsp, + *args[40]; + +char *gpcptr; /* general-purpose text pointer */ + +/* + * Open main input file, open output file, initialize needed globals + * and process the file: + */ + +main(aarghc,aarghv) +char **aarghv; +{ + int i,j,k; + char c, *inpnam, *outnam; + + puts(TITLE); + + initequ(); /* initialize EQU table with reserved words */ + fcount = 0; /* haven't seen any functions yet */ + doingfunc = FALSE; /* not currently processing a function */ + errf = FALSE; /* no errors yet */ + verbose = careful = debug = FALSE; + inpnam = outnam = NULL; /* haven't seen any names yet */ + blankflag = FALSE; /* haven't just processed a null line */ + nestlev = 0; /* at top level to start with */ + + while (--aarghc) + { + ++aarghv; /* bump to next arg text */ + if (**aarghv == '-') + { + switch(c = aarghv[0][1]) + { + case 'F': + careful = 1; + break; + + case 'C': + verbose = 1; + break; + + case 'O': + if (aarghv[0][2]) + outnam = &aarghv[0][2]; + else if (--aarghc) + outnam = *++aarghv; + else goto usage; + + break; + + case 'D': + debug = TRUE; + break; + + default: goto usage; + } + } + else + inpnam = *aarghv; + } + + if (!inpnam) { + usage: puts("Usage:\tcasm [-f] [-c] [-o ] \n"); + puts("-F: flag old CMAC.LIB macros if spotted\n"); + puts("-C: don't strip comments from input and output\n"); + puts("-O : Call the output file .ASM\n"); + exit(); + } + + /* set up filenames with proper extensions: */ + for (i = 0; (c = inpnam[i]) && c != '.'; i++) + iname[0][i] = c; + iname[0][i] = '\0'; + + strcpy(oname, outnam ? outnam : iname[0]); + strcat(iname[0],CASMEXT); /* input filename */ + cfname = iname[0]; /* current filename pointer */ + + + if ((cfp = fopen(cfname, "r")) == NULL) + exit(printf("Can't open %s\n",cfname)); + fptab[0] = cfp; + if (debug) + printf("cfp = %04x\n",cfp); + + if (!hasdot(oname)) + strcat(oname,ASMEXT); /* output filename */ + if ((ofp = fopen(oname, "w")) == NULL) + exit(printf("Can't create %s\n",oname)); + + /* begin writing output file */ + fprintf2(ofp,"\nTPALOC\t\tEQU\t%04xH\n",TPALOC); + + fprintf2(ofp,"\nSYS$EXTFLAG\tSET\t0\n"); + fprintf2(ofp,"SYS$EXTADDR\tSET\t0\n"); + fprintf2(ofp,"SYS$EXTSIZE\tSET\t0\n"); + fprintf2(ofp,"\t\tORG\tTPALOC+0205H\n\n"); + + lino = 1; /* initialize line count */ + + while (get_line()) { /* main loop */ + if (kbhit() && getchar() == CONTROL_C) + abort("Aborted by ^C\n"); + process_line(); /* process lines till EOF */ + lino++; + } + + if (doingfunc) /* if ends inside a function, error */ + abort("File ends, but last function is unterminated\n"); + + if (errf) + { + puts("Fix those errors and try again..."); + unlink(oname); + if (*SUBFILE) + unlink(SUBFILE); + } + else + { + /* end of functions */ + fputs2("\nEND$CRL\t\tEQU\t$-TPALOC\n",ofp); + putdir(); /* now put out CRL directory */ + fputs2("\t\tEND\n",ofp); /* end of ASM file */ + fputc(CPMEOF,ofp); /* CP/M EOF character */ + fclose(cfp); /* close input file */ + fclose(ofp); /* close output file */ + printf("%s is ready to be assembled.\n",oname); + } +} + +/* + * Get a line of text from input stream, and process + * "include" ops on the fly: + */ + +int get_line() +{ + int i; + +top: if (!fgets2(linbuf, MAXLINE, cfp)) { /* on EOF: */ + if (nestlev) { /* in "include" file? */ + fclose(cfp); /* yes; return to previous; */ + cfp = fptab[--nestlev]; /* restore buffer ptr */ + cfname = iname[nestlev]; /* and filename */ + lino = savlino[nestlev] + 1; /* and line no. */ + return get_line(); + } + else return NULL; + } + + if (!verbose) /* strip commments, default */ + { + for (i = 0; linbuf[i]; i++) + { + if (linbuf[i] == ';') + { + while (i && isspace(linbuf[i-1])) + i--; + if (!i && blankflag) + { + lino++; + goto top; + } + strcpy(&linbuf[i], "\n"); + blankflag = TRUE; + break; + } + if (linbuf[i] == '\'' || linbuf[i] == '"') + break; + } + if (!linbuf[i]) + blankflag = FALSE; + } + + parse_line(); /* not EOF. Parse line */ + if (streq(op,"INCLUDE") || /* check for file inclusion */ + streq(op,"MACLIB")) { + if (nestlev == NESTMAX) /* if nested to the max, error */ + abort("Only %d inclusion level[s] allowed",NESTMAX); + if (!argsp) + abort("No filename specified"); + /* set up for inclusion */ + savlino[nestlev++] = lino; + + for (i = 0; !isspace(argsp[i]); i++) /* put null after */ + ; /* filename */ + argsp[i] = '\0'; + + *wrkbuf = '\0'; + + if (*argsp == '<') { /* look for magic delimiters */ + strcpy(wrkbuf,DEFUSER); + if (argsp[2] != ':') /* if no explicit disk given */ + strcat(wrkbuf,DEFDISK); /* then use default */ + strcat(wrkbuf,argsp+1); + if (wrkbuf[i = strlen(wrkbuf) - 1] == '>') + wrkbuf[i] = '\0'; + } else if (*argsp == '"') { + strcpy(wrkbuf,argsp+1); + if (wrkbuf[i = strlen(wrkbuf) - 1] == '"') + wrkbuf[i] = '\0'; + } else + strcpy(wrkbuf,argsp); + + while ((cfp = fopen(wrkbuf, "r")) == NULL) + if (hasdot(wrkbuf)) + abort("Missing include file: %s\n", wrkbuf); + else + strcat(wrkbuf, ".LIB"); + + strcpy(&iname[nestlev], wrkbuf); + cfname = iname[nestlev]; + fptab[nestlev] = cfp; + lino = 1; + return get_line(); + } + return 1; +} + +parse_line() +{ + int i; + char c; + + label = op = argsp = NULL; + argcnt = 0; + + strcpy2(pbuf,linbuf); + strcpy2(linsav,linbuf); + pbufp = pbuf; + + if (!*pbufp) return; /* ignore null lines */ + if (!isspace(c = *pbufp)) { + if (c == ';') + return; /* totally ignore comment lines */ + label = pbufp; /* set pointer to label */ + while (isidchr(*pbufp)) /* pass over label identifier */ + pbufp++; + *pbufp++ = '\0'; /* place null after identifier */ + } + + skip_wsp(&pbufp); + if (!*pbufp || *pbufp == ';') + return; + op = pbufp; /* set pointer to op mnemonic */ + while (isalpha(*pbufp)) + pbufp++; /* skip over the op */ + if (*pbufp) *pbufp++ = '\0'; /* place null after the op */ + + + /* now process arguments */ + skip_wsp(&pbufp); + if (!*pbufp || *pbufp == ';') + return; + argsp = linsav + (pbufp - pbuf); /* set pointer to arg list */ + + /* create vector of ptrs to all args + that are possibly relocatable */ + for (argcnt = 0; argcnt < 40;) { + while (!isidstrt(c = *pbufp)) + if (!c || c == ';') + return; + else + pbufp++; + + if (isidchr(*(pbufp - 1))) { + pbufp++; + continue; + } + + args[argcnt++] = pbufp; + while (isidchr(*pbufp)) pbufp++; + if (*pbufp) *pbufp++ = '\0'; + } + error("Too many operands in this instruction for me to handle\n"); +} + +process_line() +{ + char *cptr, c; + int i,j; + + if (op) { + /* check for definitions of global data that will be + exempt from relocation when encountered in the + argument field of assembly instructions: */ + + if (streq(op,"EQU") || streq(op,"SET") || + (!doingfunc && + (streq(op,"DS") || streq(op,"DB") || streq(op,"DW")))) + { + fputnam(ofp,linbuf); + cptr = sbrk2(strlen(label) + 1); + strcpy(cptr,label); + equtab[equcount++] = cptr; + if (equcount >= EQUMAX) + abort( + "Too many EQU lines...increase 'EQUMAX' and recompile CASM"); + return; + } + + if (streq(op,"EXTERNAL")) { + if (!doingfunc) abort( + "'External's for a function must appear inside the function"); + if (pastnfs) error( + "Externals must all be together at start of function\n"); + for (i = 0; i < argcnt; i++) { + nflist[nfcount++] = txtbufp; + strcpy(txtbufp,args[i]); + bumptxtp(args[i]); + } + if (nfcount >= NFMAX) { + printf("Too many external functions in function \"%s\"\n", + cfunam); + abort("Change the NFMAX constant and recompile CASM"); + } + return; + } + + if (streq(op,"FUNCTION")) { + + if (doingfunc) { + printf("'Function' op encountered in a function.\n"); + abort("Did you forget an 'endfunc' op?"); + } + if (!argcnt) + abort("A name is required for the 'function' op"); + + cfunam = sbrk2(strlen(args[0]) + 1); + fnames[fcount++] = cfunam; + strcpy(cfunam,args[0]); +#if VIDEO + if (debug) putchar('\n'); + printf("Processing the %s function... \r",cfunam); + if (debug) putchar('\n'); +#endif + doingfunc = 1; + txtbufp = txtbuf; + labcount = 0; + nfcount = 0; + pastnfs = 0; + + if (verbose) + fprintf2(ofp,"\n\n; The \"%s\" function:\n",cfunam); + + fputnam(ofp, cfunam); + fputs2("$BEG\tEQU\t$-TPALOC\n", ofp); + return; + } + + if (streq(op,"ENDFUNC") || streq(op,"ENDFUNCTION")) { + if (!doingfunc) + abort("'Endfunc' op encountered while not in a function"); + + if (!pastnfs) flushnfs(); /* flush needed function list */ + fputnam (ofp, cfunam); + fputs2("$END\tEQU\t$\n", ofp); + doreloc(); /* flush relocation parameters */ + + for (i = 0; i < labcount; i++) /* detect undefined labels */ + if (!lablist[i].defined) { + printf("The label %s in function %s is undefined\n", + lablist[i].labnam,cfunam); + errf = 1; + } + doingfunc = 0; + return; + } + } + + if (careful) + if (streq(op,"RELOC") || streq(op,"DWREL") || streq(op,"DIRECT") || + streq(op,"ENDDIR") || streq(op,"EXREL") || streq(op,"EXDWREL") || + streq(op,"PRELUDE") || streq(op,"POSTLUDE") || streq(op,"DEFINE")) + error("Old macro '%s' leftover from \"CMAC.LIB\" days...\n", + op); + + /* Don't scan conditional pseudo op lines */ + if (streq(op,"IF") || streq(op,"ENDIF")) + return fputnam(ofp,linbuf); + + /* No special pseudo ops, so now process + the line as a line of assemby code: */ + + if (streq(op,"END")) return; /* don't allow "end" yet */ + + if (!doingfunc || (!label && !op)) /* if nothing interesting on */ + return fputnam(ofp,linbuf); /* line, ignore it */ + if (!pastnfs) /* if haven't flushed needed */ + flushnfs(); /* function list yet, do it */ + + /* check for possible label */ + if (label) { + sprintf (undrbuf, "%s$L$%s\tEQU\t$-%s$STRT\n", + cfunam, label, cfunam); + fputnam (ofp,undrbuf); + for (i=0; linbuf[i]; i++) + if (isspace(linbuf[i]) || linbuf[i] == ':') + break; + else + linbuf[i] = ' '; + if (linbuf[i] == ':') linbuf[i] = ' '; + for (i = 0; i < labcount; i++) /* check if in label table */ + if (streq(label,lablist[i].labnam)) { /* if found, */ + if (lablist[i].defined) { /* check for redefinition */ + error("Re-defined label:"); + printf("%s, in function %s\n", + lablist[i].labnam,cfunam); + } + else + lablist[i].defined = 1; + goto out; + } + lablist[i].labnam = txtbufp; /* add new entry to */ + lablist[i].defined = 1; /* label list */ + strcpy(txtbufp,label); + bumptxtp(label); + if (labcount++ >= LABMAX) + error("Label table overflow. Increase LABMAX"); + } +out: + if (!op) return fputnam (ofp, linbuf); /* if label only, all done */ + + /* if a non-relocatable op, */ + if (norelop(op)) return fputnam(ofp,linbuf); /* then we're done */ + + if (argcnt && doingfunc) + for (i = 0; i < argcnt; i++) { + if (gpcptr = isef(args[i])) + sprintf(workbuf,"%s$EF$%s-%s$STRT", + cfunam,gpcptr,cfunam); + else if (norel(args[i])) continue; + else { + sprintf(workbuf,"%s$L$%s",cfunam,args[i]); + for (j = 0; j < labcount; j++) + if (streq(args[i],lablist[j].labnam)) + goto out2; + lablist[j].labnam = txtbufp; /* add new entry to */ + lablist[j].defined = 0; /* label list */ + strcpy(txtbufp,args[i]); + bumptxtp(txtbufp); + labcount++; + } + + out2: + replstr(linbuf, workbuf, args[i] - pbuf, strlen(args[i])); + + if (streq(op,"DW")) { + sprintf (undrbuf, "%s$R%03d\tEQU\t$-%s$STRT\n", + cfunam, relblc++, cfunam); + fputnam (ofp, undrbuf); + if (argcnt > 1) + error("Only one relocatable value allowed per DW\n"); + } + else { + sprintf (undrbuf,"%s$R%03d\tEQU\t$+1-%s$STRT\n", + cfunam, relblc++, cfunam); + fputnam (ofp, undrbuf); + } + break; + } + fputnam (ofp, linbuf); +} + + +/* + Test for ops in which there is guanranteed to be no need + for generation of relocation parameters. Note that the list + of non-relocatable ops doesn't necessarily have to be complete, + because for any op that doesn't match, an argument must still + pass other tests before it is deemed relocatable. This only + speeds things up by telling the program not to bother checking + the arguments. +*/ + +norelop(op) +char *op; +{ + if (streq(op,"MOV")) return 1; + if (streq(op,"INR")) return 1; + if (streq(op,"DCR")) return 1; + if (streq(op,"INX")) return 1; + if (streq(op,"DCX")) return 1; + if (streq(op,"DAD")) return 1; + if (streq(op,"MVI")) return 1; + if (streq(op,"DB")) return 1; + if (streq(op,"DS")) return 1; + if (op[2] == 'I') { + if (streq(op,"CPI")) return 1; + if (streq(op,"ORI")) return 1; + if (streq(op,"ANI")) return 1; + if (streq(op,"ADI")) return 1; + if (streq(op,"SUI")) return 1; + if (streq(op,"SBI")) return 1; + if (streq(op,"XRI")) return 1; + if (streq(op,"ACI")) return 1; + } + if (streq(op,"ORG")) return 1; + if (streq(op,"TITLE")) return 1; + if (streq(op,"PAGE")) return 1; + if (streq(op,"EJECT")) return 1; + if (streq(op,"MACRO")) return 1; + return 0; +} + + +flushnfs() +{ + int i,j, length; + + pastnfs = 1; + relblc = 0; + + if (verbose) + fputs2("\n\n; List of needed functions:\n",ofp); + + for (i=0; i < nfcount; i++) { + strcpy(workbuf,"\t\tDB\t'"); + length = strlen(nflist[i]); + length = length < 8 ? length : 8; + for (j = 0; j < length - 1; j++) + workbuf[6+j] = nflist[i][j]; + workbuf[6+j] = '\0'; + fprintf2(ofp,"%s','%c'+80H\n",workbuf,nflist[i][j]); + } + + fputs2("\t\tDB\t0\n",ofp); + + if (verbose) + fputs2("\n; Length of body:\n",ofp); + + sprintf(undrbuf,"\t\tDW\t%s$END-$-2\n",cfunam); + fputnam (ofp, undrbuf); + + if (verbose) + fputs2("\n; Body:\n",ofp); + + sprintf(undrbuf,"%s$STRT\tEQU\t$\n",cfunam); + fputnam (ofp, undrbuf); + if (nfcount) { + sprintf(undrbuf,"%s$R%03d\tEQU\t$+1-%s$STRT\n", + cfunam,relblc++,cfunam); + fputnam (ofp, undrbuf); + sprintf(undrbuf,"\t\tJMP\t%s$STRTC-%s$STRT\n",cfunam,cfunam); + fputnam (ofp, undrbuf); + } + sprintf(undrbuf,"%s$EF$%s\tEQU\t%s$STRT\n",cfunam,cfunam,cfunam); + fputnam (ofp, undrbuf); + for (i=0; i < nfcount; i++) { + sprintf(undrbuf,"%s$EF$%s\tJMP\t0\n",cfunam,nflist[i]); + fputnam (ofp, undrbuf); + } + sprintf(undrbuf,"\n%s$STRTC\tEQU\t$\n",cfunam); + fputnam (ofp, undrbuf); +} + + +doreloc() +{ + int i; + + if(verbose) + fputs2("\n; Relocation parameters:\n",ofp); + + fprintf2(ofp,"\t\tDW\t%d\n",relblc); + for(i = 0; i < relblc; i++) + fprintf2(ofp,"\t\tDW\t%s$R%03d\n",cfunam,i); + fputs2("\n",ofp); +} + +putdir() +{ + int i,j, length; + int bytecount; + + bytecount = 0; + + fputs2("\n\t\tORG\tTPALOC\n\n; Directory:\n",ofp); + for (i = 0; i < fcount; i++) { + strcpy(workbuf,"\t\tDB\t'"); + length = strlen(fnames[i]); + length = length < 8 ? length : 8; + for (j = 0; j < length - 1; j++) + workbuf[6+j] = fnames[i][j]; + workbuf[6+j] = '\0'; + fprintf2(ofp,"%s','%c'+80H\n",workbuf,fnames[i][j]); + sprintf(undrbuf,"\t\tDW\t%s$BEG\n",fnames[i]); + fputnam (ofp, undrbuf); + bytecount += (length + 2); + } + fputs2("\t\tDB\t80H\n\t\tDW\tEND$CRL\n",ofp); + + bytecount += 3; + if (bytecount > DIRSIZE) { + printf("CRL Directory size will exceed 512 bytes;\n"); + printf("Break the file up into smaller chunks, please!\n"); + exit(-1); + } + + fputs2("\n\n; External information:\n", ofp); + fputs2("\t\tORG\tTPALOC+0200H\n", ofp); + fputs2("\t\tIF\tSYS$EXTFLAG\n", ofp); + fputs2("\t\tDB\t0BDH\n", ofp); + fputs2("\t\tDW\tSYS$EXTADDR\n", ofp); + fputs2("\t\tENDIF\n", ofp); + fputs2("\t\tIF\tNOT SYS$EXTFLAG\n", ofp); + fputs2("\t\tDB\t0, 0, 0\n", ofp); + fputs2("\t\tENDIF\n", ofp); + fputs2("\t\tDW\tSYS$EXTSIZE\n", ofp); + +} + + +initequ() +{ + equtab[0] = "A"; + equtab[1] = "B"; + equtab[2] = "C"; + equtab[3] = "D"; + equtab[4] = "E"; + equtab[5] = "H"; + equtab[6] = "L"; + equtab[7] = "M"; + equtab[8] = "SP"; + equtab[9] = "PSW"; + equtab[10]= "AND"; + equtab[11]= "OR"; + equtab[12]= "MOD"; + equtab[13]= "NOT"; + equtab[14]= "XOR"; + equtab[15]= "SHL"; + equtab[16]= "SHR"; + equcount = 14; +} + + +int isidchr(c) /* return true if c is legal character in identifier */ +char c; +{ + return isalpha(c) || c == '$' || isdigit(c) || c == '.' || c == '_'; +} + + +int isidstrt(c) /* return true if c is legal as first char of idenfitier */ +char c; +{ + return isalpha(c) || c == '_'; +} + + +int streq(s1, s2) /* return true if the two strings are equal */ +char *s1, *s2; +{ + if (*s1 != *s2) return 0; /* special case for speed */ + while (*s1) if (*s1++ != *s2++) return 0; + return (*s2) ? 0 : 1; +} + + +skip_wsp(strptr) /* skip white space at *strptr and modify the ptr */ +char **strptr; +{ + while (isspace(**strptr)) (*strptr)++; +} + + +strcpy2(s1,s2) /* copy s2 to s1, converting to upper case as we go */ +char *s1, *s2; +{ + while (*s2) + *s1++ = toupper(*s2++); + *s1 = '\0'; +} + + +/* + General-purpose string-replacement function: + 'string' is pointer to entire string, + 'insstr' is pointer to string to be inserted, + 'pos' is the position in 'string' where 'insstr' + is to be inserted + 'lenold' is the length of the substring in 'string' + that is being replaced. +*/ + +replstr(string, insstr, pos, lenold) +char *string, *insstr; +{ + int length, i, j, k, x; + + length = strlen(string); + x = strlen(insstr); + k = x - lenold; + i = string + pos + lenold; + if (k) movmem(i, i+k, length - (pos + lenold) + 1); + for (i = 0, j = pos; i < x; i++, j++) + string[j] = insstr[i]; +} + +/* Function to put text to the output file, replacing underscores with + cues to keep ASM happy. */ + +fputnam (file, str) + FILE *file; + char *str; + { + char c; + char quoted; + quoted = FALSE; + while (c = *str++) { + if (c == '\'') quoted ^= 1; + else if (c == '\n') putc2 ('\r', file); + if (c == '_' && !quoted) putc2 ('Q', file); + else putc2 (c, file); + } + } + +putc2(c,file) +FILE *file; +{ + if (debug) + putchar(c); + else + fputc(c, file); +} + + +error(msg,arg1,arg2) +char *msg; +{ + printf("\n\7%s: %d: ",cfname,lino); + printf(msg,arg1,arg2); + errf = 1; +} + + +abort(msg,arg1,arg2) +char *msg; +{ + int i; + + error(msg,arg1,arg2); + putchar('\n'); + for (i = nestlev; i >= 0; i--) + fclose(fptab[i]); + if (*SUBFILE) + unlink(SUBFILE); + exit(-1); +} + + +sbrk2(n) /* allocate storage and check for out of space condition */ +{ + int i; + if ((i = sbrk(n)) == ERROR) + abort("Out of storage allocation space\n"); + return i; +} + +bumptxtp(str) /* bump txtbufp by size of given string + 1 */ +char *str; +{ + txtbufp += strlen(str) + 1; + if (txtbufp >= txtbuf + (TXTBUFSIZE - 8)) + abort("Out of text space. Increase TXTBUFSIZE and recompile CASM"); +} + + +int norel(id) /* return true if identifier is exempt from relocatetion */ +char *id; +{ + if (isequ(id)) return 1; + return 0; +} + + +int isequ(str) /* return true if given string is in the EQU table */ +char *str; +{ + int i; + for (i = 0; i < equcount; i++) + if (streq(str,equtab[i])) + return 1; + return 0; +} + + +char *isef(str) /* return nflist entry if given string is an external */ +char *str; /* function name */ +{ + int i; + for (i = 0; i < nfcount; i++) + if (streq(str,nflist[i])) + return nflist[i]; + return 0; +} + +int hasdot(str) /* return true if given string has a dot in it */ +char *str; +{ + while (*str) + if (*str++ == '.') + return TRUE; + return FALSE; +} + +fgets2(arg1, arg2, arg3) +{ + int i; + i = fgets(arg1, arg2, arg3); + if (debug) + printf("\n fgets got --> %s\n",arg1); + return i; +} + + + +fputs2(arg1,arg2) +{ + if (debug) + puts(arg1); + else + if (fputs(arg1,arg2) == ERROR) + abort("Out of disk space for output file."); +} + +fprintf2(arg1,arg2,arg3,arg4,arg5) +{ + if (debug) + printf(arg2, arg3, arg4, arg5); + else + if (fprintf(arg1,arg2,arg3,arg4,arg5) == ERROR) + abort("Out of disk space for output file."); +} + \ No newline at end of file diff --git a/disks/images/c/CASM.SUB b/disks/images/c/CASM.SUB new file mode 100644 index 0000000..a3a3064 --- /dev/null +++ b/disks/images/c/CASM.SUB @@ -0,0 +1,6 @@ +casm $1 +asm $1.ddz ;where 'd' is the disk drive you are running this on +era $1.asm +cload $1 +era $1.hex + \ No newline at end of file diff --git a/disks/images/c/CC.COM b/disks/images/c/CC.COM new file mode 100755 index 0000000..13613ee Binary files /dev/null and b/disks/images/c/CC.COM differ diff --git a/disks/images/c/CC2.COM b/disks/images/c/CC2.COM new file mode 100755 index 0000000..e01ac58 Binary files /dev/null and b/disks/images/c/CC2.COM differ diff --git a/disks/images/c/CCC.ASM b/disks/images/c/CCC.ASM new file mode 100644 index 0000000..2752d96 --- /dev/null +++ b/disks/images/c/CCC.ASM @@ -0,0 +1,1611 @@ +; +; CCC.ASM: BDS C Run-Time Package (C.CCC) v1.6, 2/86 +; +; Copyright (c) 1982, 1983, 1986 by BD Software, Inc. +; +; This is the source to the BDS C run-time package module. When running +; in a standard CP/M system environment, the run-time package object module +; resides at the start of the TPA (typically 100h). The code generated by +; the BDS C Compiler usually has its origin immediately following the end of +; the run-time package module. +; +; This file may be assembled either by Digital Research's assemblers +; (ASM and MAC) or by Microsoft's assembler (M80/L80). Set the M80 symbol +; (below) to specify which assembler shall be used. The final result of the +; assembly is a run-time package module named "C.CCC", ready for use by +; CLINK.COM or L2.COM. +; +; Assembly instructions for MAC.COM / ASM.COM: +; (set M80 to FALSE) +; >asm ccc +; >load ccc +; >ren c.ccc=ccc.com +; +; Assembly instructions with M80.COM for standard CP/M TPA operation: +; (set M80 to TRUE) +; >m80 ccc,ccc=ccc.asm +; >l80 /p:100,ccc/n,ccc/e +; >ren c.ccc=ccc.com +; + +M80 EQU FALSE ;TRUE for M80 and L80, FALSE if using ASM/MAC and LOAD + +; +; Equate statements in CAPITAL letters may be configured to control the +; following environmental and auxilliary options of the run-time environment: +; +; a) operating system environment, or lack thereof (CPM, MPM2) +; b) recognition of the CP/M "user area" mechanism (USAREA) +; c) CDB debugger interface (USERST, RSTNUM) +; d) code compression through use of restart vectors 1-7 (ZOPT1-ZOPT7) +; +; All the above options (except CPM and sometimes ZOPT1-ZOPT7) may be altered +; freely WITHOUT requiring the reassembly of the CSM-coded portions of the +; C library (object in DEFF2.CRL). Changing ZOPT1-ZOPT7 requires library +; reassembly only when PRESRV is set to FALSE. +; +; If generating code for an operating-system-independent application (when +; the CPM equate is set to FALSE), make sure to set the following values: +; +; e) the origin of the run-time package code segment (ORIGIN) +; f) the origin of the run-time package's local data area (RAM) +; g) the transfer address upon program termination (EXITAD) +; + +false equ 0 +true equ not false + +CPM EQU TRUE ;True if to be run under any CP/M- or MP/M-like system +MPM2 EQU FALSE ;True ONLY if running MP/M II (forces R/O file closes) + +PRESRV EQU TRUE ;True to preserve CRL-file address compatibility + ; under various ZOPT1-ZOPT7 configurations + ;(changing to FALSE will shorten run-time pkg., but + ;will require re-CASM-ing .CSM files for new DEFF2.CRL) + +USAREA EQU TRUE ;True if "user areas" are implemented on target system + +USERST EQU FALSE ;True to use a restart vector for CDB interfacing +RSTNUM EQU 6 ;Use "RST n" as default CDB vector (if USERST true) + ;(If used, be sure corresponding ZOPTn below is FALSE) +rstloc equ rstnum*8 ;physical address of debugger restart vector + +ZOPT1 EQU FALSE ;The following five equates control the +ZOPT2 EQU FALSE ;initialization of restart vectors 1 through 7 +ZOPT3 EQU FALSE ;(rst 1 - rst 7) for use by C programs to achieve +ZOPT4 EQU FALSE ;optimum space efficiency. If any of these vectors are +ZOPT5 EQU FALSE ;used by your system for I/O, set them FALSE here! +ZOPT6 EQU FALSE ; (set FALSE if CDB w/RST 6 is to be used with object.) +ZOPT7 EQU FALSE ; (set FALSE if DDT or SID are to be used with object.) + +; +; Use this section to configure run-time package +; for non-CP/M-resident operation (e.g., for ROM): +; + + IF NOT CPM ;fill in the appropriate values... +ORIGIN EQU NEWBASE ;Address at which programs are to run +RAM EQU WHATEVER ;R/W memory area for non-CP/M configurations + ;(default: immediately after C.CCC under CP/M) +EXITAD EQU WHENDONE ;where to go when done executing + ENDIF + +; +; Some CP/M-specific symbolic values: +; + + if cpm +NFCBS EQU 8 ;maximum # of files open at one time +base equ 0 ;start of system ram +bdos equ base+5 ;bdos entry pt. +tpa equ base+100h +tbuff equ base+80h +origin equ tpa +exitad equ base ;warm boot location + +conin equ 1 ;BDOS call codes...console input +cstat equ 11 ;interrogate console status +closec equ 16 ;close file +gsuser equ 32 ;get/set user code + endif + +; +; The location of the jump vectors and utility routines must remain +; constant relative to the beginning of this run-time module. +; +; Do NOT change ANYTHING between here and the start of the +; "init" routine!!!!!!!! +; + + IF NOT M80 + org origin + ENDIF + +; +; The "lxi sp,0" instruction at the start of the code is changed by +; CLINK, if the "-t" option is NOT used, into: +; lhld base+6 +; sphl +; +; If "-t " is used, then the sequence becomes: +; lxi sp, +; nop +; +; If "-n" is used, to indicate no-warm-boot, then the sequence becomes: +; jmp snobsp +; nop +; + + lxi sp,0 ;These two instructions change depending on whether + nop ;or not the CLINK "-t" or "-n" options are given. + + nop + nop + + jmp skpfex ;skip over the following vector (don't ask...) + +fexitv: jmp exitad ;final exit vector. If "-n" used, this + ;becomes address of the "nobret" routine. + +skpfex: call init ;do ARGC & ARGV processing, plus misc. initializations + call main ;go crunch!!!! + jmp vexit ;close open files and reboot + +extrns: ds 2 ;set by CLINK to external data base address +cccsiz: dw main-origin ;size of this code (for use by CLINK) +codend: ds 2 ;set by CLINK to (last addr of code + 1) +freram: ds 2 ;set by CLINK to (last addr of externals + 1) + +; +; Jump vectors to some file i/o utility routines: +; + +error: jmp verror ;loads -1 into HL and returns +exit: jmp vexit ;close all open files and reboot + + IF CPM +close: jmp vclose ;close a file +setfcb: jmp vsetfcb ;set up fcb at HL given filename at DE +fgfd: jmp vfgfd ;return C set if file fd in A not open +fgfcb: jmp vfgfcb ;compute address of internal fcb for fd in A +setfcu: jmp vstfcu ;set up FCB and process user number prefix +setusr: jmp vsetusr ;set user area to upper 5 bits of A, save previous +rstusr: jmp vrstusr ;restore user area to what it was before setusr call +snobsp: jmp vsnobsp ;set up SP for non-boot ("-tn") CLINK option +nobret: jmp vnobret ;return to CCP when non-boot ("-tn") in effect. +khack: jmp vkhack ;Kirkland interrupt vector initialization + ENDIF + + IF NOT CPM ;if not under CP/M, file I/O routines + jmp verror ;are not used. + jmp verror + jmp verror + jmp verror + jmp verror + jmp verror + jmp verror + jmp verror + jmp verror + jmp verror + ENDIF + +clrex: jmp vclrex ;routine to clear external data area + + ds 9 ;reserved + +; +; The following routines fetch a variable value from either +; the local stack frame or the external area, given the relative +; offset of the datum required immediately following the call; +; for the "long displacement" routines, the offset must be 16 bits, +; for the "short displacement" routines, the offset must be 8 bits. +; + +; +; long-displacement, double-byte external indirection: +; +; format: call ldei ; get 16-bit value in HL +; dw offset_from_extrns ; >= 256 +; + +ldei: pop h ;get address of offset + mov e,m ;put offset in DE + inx h + mov d,m + inx h + push h ;save return address + lhld extrns ;add offset to external area base + dad d +mindir: mov a,m ;and get the value into HL + inx h + mov h,m + mov l,a + ret + +; +; short-displacement, double-byte external indirection: +; +; format: call sdei ; get 16-bit value in L +; db offset_from_extrns ; < 256 +; + +sdei: pop h + mov e,m + inx h + push h + mvi d,0 + lhld extrns + dad d + mov a,m + inx h + mov h,m + mov l,a + ret + +; +; long-displacement, single-byte external indirection: +; +; format: call lsei ; get 8-bit value in L +; dw offset_from_extrns ; >= 256 +; + +lsei: pop h + mov e,m + inx h + mov d,m + inx h + push h + lhld extrns + dad d + mov l,m + ret + +; +; short-displacement, single-byte external indirection: +; +; format: call ssei ; get 8-bit value in L +; db offset_from_externs ; < 256 +; + +ssei: pop h + mov e,m + inx h + push h + mvi d,0 + lhld extrns + dad d + mov l,m + ret + +; +; long-displacement, double-byte local indirection: +; +; format: call ldli ; get 16-bit value in HL +; dw offset_from_BC ; >= 256 +; + +ldli: pop h + mov e,m + inx h + mov d,m + inx h + push h + xchg + dad b + mov a,m + inx h + mov h,m + mov l,a + ret + +; +; short-displacement, double-byte local indirection: +; +; format: call sdli ; get 16-bit value in HL +; db offset_from_BC ; < 256 +; + +sdli: pop h + mov e,m + inx h + push h + xchg + mvi h,0 + dad b + mov a,m + inx h + mov h,m + mov l,a + ret + +; +; Flag conversion routines: +; + +pzinh: lxi h,1 ;return HL = true if Z set + rz + dcx h + ret + +pnzinh: lxi h,0 ;return HL = false if Z set + rz + inx h + ret + +pcinh: lxi h,1 ;return HL = true if C set + rc + dcx h + ret + +pncinh: lxi h,0 ;return HL = false if C set + rc + inx h + ret + +ppinh: lxi h,1 ;return HL = true if P (plus) flag set + rp + dcx h + ret + +pminh: lxi h,1 ;return HL = true if M (minus) flag set + rm + dcx h + ret + +pzind: lxi d,1 ;return DE = true if Z set + rz + dcx d + ret + +pnzind: lxi d,0 ;return DE = false if Z set + rz + inx d + ret + +pcind: lxi d,1 ;return DE = true if C set + rc + dcx d + ret + +pncind: lxi d,0 ;return DE = false if C set + rc + inx d + ret + +ppind: lxi d,1 ;return DE = true if P (plus) flag set + rp + dcx d + ret + +pmind: lxi d,1 ;return DE = true if M (minus) flag set + rm + dcx d + ret + + +; +; Relational operator routines: take args in DE and HL, +; and return a flag bit either set or reset. +; +; ==, >, < : +; + +eqwel: mov a,l ;return Z if HL == DE, else NZ + cmp e + rnz ;if L <> E, then HL <> DE + mov a,h ;else HL == DE only if H == D + cmp d + ret + +blau: xchg ;return C if HL < DE, unsigned +albu: mov a,d ;return C if DE < HL, unsigned + cmp h + rnz ;if D <> H, C is set correctly + mov a,e ;else compare E with L + cmp l + ret + +bgau: xchg ;return C if HL > DE, unsigned +agbu: mov a,h ;return C if DE > HL, unsigned + cmp d + rnz ;if H <> D, C is set correctly + mov a,l ;else compare L with E + cmp e + ret + +blas: xchg ;return C if HL < DE, signed +albs: mov a,h ;return C if DE < HL, signed + xra d + jp albu ;if same sign, do unsigned compare + mov a,d + ora a + rp ;else return NC if DE is positive and HL is negative + stc ;else set carry, since DE is negative and HL is pos. + ret + +bgas: xchg ;return C if HL > DE, signed +agbs: mov a,h ;return C if DE > HL, signed + xra d + jp agbu ;if same sign, go do unsigned compare + mov a,h + ora a + rp ;else return NC is HL is positive and DE is negative + stc + ret ;else return C, since HL is neg and DE is pos + + +; +; Multiplicative operators: *, /, and %: +; + +smod: mov a,d ;signed MOD routine: return (DE % HL) in HL + push psw ;save high bit of DE as sign of result + call tstn ;get absolute value of args + xchg + call tstn + xchg + call usmod ;do unsigned mod + pop psw ;was DE negative? + ora a ;if not, + rp ; all done + mov a,h ;else make result negative + cma + mov h,a + mov a,l + cma + mov l,a + inx h + ret + + IF PRESRV + nop ;maintain address compatibility with some + nop ; pre-release v1.4's. + ENDIF + +usmod: mov a,h ;unsigned MOD: return (DE % HL) in HL + ora l + rz + push d + push h + call usdiv + pop d + call usmul + mov a,h + cma + mov h,a + mov a,l + cma + mov l,a + inx h + pop d + dad d + ret + +smul: jmp usmul ;turns out signed and unsigned multipilication + ; are equivalent for 16 bits, so just do unsigned + + ;rst optimization of function entry sequence (ZOPT1): +fentrc: pop d ;pop arg byte address into DE + push b ;save BC + ldax d ;put stack offset byte value into L, setting up + mov l,a ; HL with negative stack offset + mvi h,0ffh + inx d ;DE now points to return address + dad sp ;calculate new SP value + sphl ;set new SP value + mov b,h ;place into BC as new frame base ptr + mov c,l + xchg ;put return address in HL + pchl ;and return + + +smul2: lda tmp + rar + rnc + jmp cmh + + ds 3 ;preserve address compatibility with previous versions + +tstn: mov a,h + ora a + rp + cma + mov h,a + mov a,l + cma + mov l,a + inx h + lda tmp + inr a + sta tmp + ret + +usmul: push b ;unsigned multiply: return (DE * HL) in HL + call usm2 + pop b + ret + +usm2: mov b,h + mov c,l + lxi h,0 +usm3: mov a,b + ora c + rz + mov a,b + rar + mov b,a + mov a,c + rar + mov c,a + jnc usm4 + dad d +usm4: xchg + dad h + xchg + jmp usm3 + +usdiv: mov a,h ;unsigned divide: return (DE / HL) in HL + ora l ;return 0 if HL is 0 + rz + push b + call usd1 + mov h,b + mov l,c + pop b + ret + + +usd1: mvi b,1 +usd2: mov a,h + ora a + jm usd3 + dad h + inr b + jmp usd2 + +usd3: xchg + +usd4: mov a,b + lxi b,0 +usd5: push psw +usd6: call cmphd + jc usd7 + inx b + push d + mov a,d + cma + mov d,a + mov a,e + cma + mov e,a + inx d + dad d + pop d +usd7: xra a + mov a,d + rar + mov d,a + mov a,e + rar + mov e,a + pop psw + dcr a + rz + push psw + mov a,c + ral + mov c,a + mov a,b + ral + mov b,a + jmp usd6 + +sdiv: xra a ;signed divide: return (DE / HL) in HL + sta tmp + call tstn + xchg + call tstn + xchg + call usdiv + jmp smul2 + +cmphd: mov a,h ;this returns C if HL < DE + cmp d ; (unsigned compare only used + rc ; within C.CCC, not from C) + rnz + mov a,l + cmp e + ret + +; +; Shift operators << and >>: +; + +sderbl: xchg ;shift DE right by L bits +shlrbe: inr e ;shift HL right by E bits +shrbe2: dcr e + rz + xra a + mov a,h + rar + mov h,a + mov a,l + rar + mov l,a + jmp shrbe2 + +sdelbl: xchg ;shift DE left by L bits +shllbe: inr e ;shift HL left by E bits +shlbe2: dcr e + rz + dad h + jmp shlbe2 + + +; +; Routines to 2's complement HL and DE: +; + +cmh: mov a,h + cma + mov h,a + mov a,l + cma + mov l,a + inx h + ret + +cmd: mov a,d + cma + mov d,a + mov a,e + cma + mov e,a + inx d + ret + + +; +; The following routines yank a formal parameter value off the stack +; and place it in both HL and A (low byte), assuming the caller +; hasn't done anything to its stack pointer since IT was called. +; +; The mnemonics are "Move Arg #n To HL", +; where arg #1 is the third thing on the stack (where the first +; and second things are, respectively, the return address of the +; routine making the call to here, and the previous return +; address to the routine which actually pushed the args on the +; stack.) Thus, a call to "ma1toh" would return with the first +; passed parameter in HL and A; "ma2toh" would return the second, +; etc. Note that if the caller has pushed [n] items on the stack +; before calling "ma [x] toh", then the [x-n]th formal parameter +; value will be returned, not the [x]th. +; + +ma1toh: lxi h,4 ;get first arg +ma0toh: dad sp + mov a,m + inx h + mov h,m + mov l,a + ret + +ma2toh: lxi h,6 ;get 2nd arg + jmp ma0toh + +ma3toh: lxi h,8 ;get 3rd arg + jmp ma0toh + +ma4toh: lxi h,10 ;get 4th arg + jmp ma0toh + +ma5toh: lxi h,12 ;get 5th arg + jmp ma0toh + +ma6toh: lxi h,14 ;get 6th arg + jmp ma0toh + +ma7toh: lxi h,16 ;get 7th arg + jmp ma0toh + +; +; This routine takes the first 7 args on the stack +; and places them contiguously at the "args" ram area. +; This allows a library routine to make one call to arghak +; and henceforth have all it's args available directly +; through lhld's instead of having to hack the stack as it +; grows and shrinks. Note that arghak should be called as the +; VERY FIRST THING a function does, before even pushing BC. +; + +arghak: lxi d,args ;destination for block move in DE + lxi h,4 ;pass over two return address + dad sp ;source for block move in HL + push b ;save BC + mvi b,14 ;countdown in B +arghk2: mov a,m ;copy loop + stax d + inx h + inx d + dcr b + jnz arghk2 + pop b ;restore BC + ret + +; +; ABSOLUTELY NO CHANGES SHOULD EVER BE MADE TO THE CODE BEFORE +; THIS POINT IN THIS SOURCE FILE (except for customizing the EQU +; statements at the beginning of the file). +; + + +; +; This routine is called first to do argc & argv processing (if +; running under CP/M) and other initializations: +; + +init: pop h ;store return address + shld tmp2 ; somewhere safe for the time being + + IF CPM + lxi h,arglst-2 ;set up "argv" for the C main program + ENDIF + + IF NOT CPM + lxi h,0 + ENDIF + + push h + + ;Initialize storage allocation pointers: + lhld freram ;get address after end of externals + shld allocp ;store at allocation pointer (for "sbrk.") + lxi h,1000 ;default safety space between stack and + shld alocmx ; highest allocatable address in memory + ; (for use by "sbrk".). + + ;Initialize random seed: + lxi h,59dch ;let's stick something wierd into the + shld rseed ;first 16 bits of the random-number seed + + ;Initialize I/O hack locations: + mvi a,0dbh ;"in" op, for "in xx; ret" subroutine + sta iohack + mvi a,0d3h ;"out" op for "out xx; ret" subroutine + sta iohack+3 + mvi a,0c9h ;"ret" for above sobroutines + sta iohack+2 ;the port number is filled in by the + sta iohack+5 ;"inp" and "outp" library routines. + + IF CPM + call khack ;initialize Kirkland debugger vector + ENDIF + + IF CPM ;under CP/M: clear console, process ARGC & ARGV: + mvi c,cstat ;interrogate console status to see if there + call bdos ; happens to be a stray character there... + + ora a ;(used to be `ani 1'...they tell me this works + nop ; better for certain bizarre CP/M-"like" systems) + + jz initzz + mvi c,conin ;if input present, clear it + call bdos + +initzz: lxi h,tbuff ;if arguments given, process them. + lxi d,comlin ;get ready to copy command line + mov b,m ;first get length of it from loc. base+80h + inx h + mov a,b + ora a ;if no arguments, don't parse for argv + jnz initl + lxi d,1 ;set argc to 1 in such a case. + jmp i5 + +initl: mov a,m ;ok, there are arguments. parse... + stax d ;first copy command line to comlin + inx h + inx d + dcr b + jnz initl + xra a ;place zero following line + stax d + + lxi h,comlin ;now compute pointers to each arg + lxi d,1 ;arg count + lxi b,arglst ;where pointers will all go + xra a ;clear "in a string" flag + sta tmp1 +i2: mov a,m ;between args... + inx h + cpi ' ' + jz i2 + ora a + jz i5 ;if null byte, done with list + cpi '"' + jnz i2a ;quote? + sta tmp1 ;yes. set "in a string" flag + jmp i2b + +i2a: dcx h +i2b: mov a,l ;ok, HL is a pointer to the start + stax b ;of an arg string. store it. + inx b + mov a,h + stax b + inx b + inx d ;bump arg count +i3: mov a,m + inx h ;pass over text of this arg + ora a ;if at end, all done + jz i5 + push b ;if tmp1 set, in a string + mov b,a ; (so we have to ignore spaces) + lda tmp1 + ora a + mov a,b + pop b + jz i3a + cpi '"' ;we are in a string. + jnz i3 ;check for terminating quote + xra a ;if found, reset "in string" flag + sta tmp1 + dcx h + mov m,a ;and stick a zero byte after the string + inx h ;and go on to next arg +i3a: cpi ' ' ;now find the space between args + jnz i3 + dcx h ;found it. stick in a zero byte + mvi m,0 + inx h + jmp i2 ;and go on to next arg + +i5: push d ;all done finding args. Set argc. + + mvi b,3*nfcbs ;now initialize all the file info + lxi h,fdt ;by zeroing the fd table) +i6: mvi m,0 + inx h + dcr b + jnz i6 + ENDIF + + IF NOT CPM ;if not under CP/M, force ARGC value + lxi h,1 ; of one. + push h + ENDIF + + call clrex ;clear externals, if CLINK -z option NOT used + xra a + sta ungetl ;clear the push-back byte, + sta errnum ;and file error code + + mvi a,0c3h ;CC '-Z' optimization initialization + +; +; -Z optimization initializations: +; + + IF ZOPT1 + sta 8 ;rst 1: jmp fentrc + lxi h,fentrc + shld 9 + ENDIF + + IF NOT ZOPT1 AND PRESRV + nop + dw 0,0,0,0 ;more NOPs + ENDIF + + + IF ZOPT2 + sta 10h + lxi h,fexitc ;rst 2:jmp fexitc + shld 11h + ENDIF + + IF NOT ZOPT2 AND PRESRV + nop + dw 0,0,0,0 ;more NOPs + ENDIF + + + IF ZOPT5 + sta 28h ;rst5: jmp sdli + lxi h,sdli + shld 29h + ENDIF + + IF NOT ZOPT5 AND PRESRV + nop + dw 0,0,0,0 ;more NOPs + ENDIF + + + IF ZOPT6 + sta 30h ;rst6: jmp ldli + lxi h,ldli + shld 31h + ENDIF + + IF NOT ZOPT6 AND PRESRV + nop + dw 0,0,0,0 ;more NOPs + ENDIF + + + IF ZOPT3 + lxi h,237eh ;rst3: mov a,m + shld 18h ; inx h + lxi h,6f66h ; mov h,m + shld 1ah ; mov l,a + mvi a,0c9h ; ret + sta 1ch + ENDIF + + IF NOT ZOPT3 AND PRESRV + nop + dw 0,0,0,0 ;more NOPs + dw 0,0,0,0 + ENDIF + + + IF ZOPT4 + lxi h,2373h ;rst4: mov m,e + shld 20h ; inx h + lxi h,0c972h ; mov m,d + shld 22h ; ret + ENDIF + + IF NOT ZOPT4 AND PRESRV + dw 0,0,0 ;lotsa NOPs + dw 0,0,0 + ENDIF + + + IF ZOPT7 + lxi h,235eh + shld 38h + lxi h,0c956h + shld 3ah + + lxi h,2b72h + shld 3ch + lxi h,0c973h + shld 3eh + ENDIF + + IF NOT ZOPT7 AND PRESRV + dw 0,0,0,0,0,0 ;you guessed it -- NOPs + dw 0,0,0,0,0,0 + ENDIF + + lhld tmp2 + pchl ;all done initializing. + + IF ZOPT2 ;object of rst 2 vector, if enabled +fexitc: pop d ;get offset address + xchg ;return value in DE, &offset in HL + mov l,m ;put byte offset in HL + mvi h,0 + dad sp ;add to SP + sphl + xchg ;put return value back in HL + pop b ;restore BC + ret ;and return to previous function + ENDIF + + IF NOT ZOPT2 AND PRESRV + dw 0,0,0 ;NOPs + dw 0,0 + ENDIF + + +; +; The following two routines are used when the "-tn" CLINK option +; is given, in order to preserve the SP value passed to the transient +; command by the CCP and return to the CCP after execution without +; needing to perform a warm-boot. +; + + IF CPM +vsnobsp: + lxi h,0 ;get CCP's SP value in HL + dad sp + shld spsav ;save it for later + lhld base+6 ;get BIOS pointer + lxi d,-2100 ;subtract size of CCP plus a fudge + dad d + sphl ;make that the new SP value + jmp tpa+3 ;and get things under way... + +vnobret: + lhld spsav ;restore CCP's SP + sphl + ret ;return to CCP + ENDIF + +; +; The following routine gets called to clear the external +; data area, unless the CLINK "-z" option is used. +; + +vclrex: lhld freram ;clear externals + xchg + lhld extrns + call cmh + dad d ;HL now holds size of external data area +clrex1: mov a,h ;loop till done + ora l + rz + dcx d + dcx h + xra a + stax d + jmp clrex1 + + +; +; Initialize Kirkland interrupt vector... enables +; programs compiled with "-k" to run without the debugger: +; + + IF USERST +vkhack: lxi h,0E1H+2300H ;pop h - inx h + shld rstloc ; put at "RST 6" location (or wherever) + lxi h,023H+0E900H ;inx h - pchl + shld rstloc+2 + ret + ENDIF + + IF NOT USERST +vkhack: ret + ENDIF + + IF NOT USERST AND PRESRV + ds 12 + ENDIF + +; +; General purpose error value return routine: +; + +verror: lxi h,-1 ;general error handler...just + ret ;returns -1 in HL + +; +; Here are file I/O handling routines, only needed under CP/M: +; + +; +; Close any open files and reboot: +; + +vexit: + IF CPM ;if under CP/M, close all open files + mvi a,7+nfcbs ;start with largest possible fd +exit1: push psw ;and scan all fd's for open files + call vfgfd ;is file whose fd is in A open? + jc exit2 ;if not, go on to next fd + mov l,a ;else close the associated file + mvi h,0 + push h + call vclose + pop h +exit2: pop psw + dcr a ;and go on to next one + cpi 7 + jnz exit1 + ENDIF + + jmp fexitv ;done closing...now return + ; to CP/M or whatever. + + +; +; Close the file whose fd is 1st arg: +; + + IF CPM ;here comes a lot of CP/M stuff... +vclose: + call ma1toh ;get fd in A + call vfgfd ;see if it is open + jc verror ;if not, complain + mov a,m + call setusr ;set user area to match current fd + ani 4 ;check if open for writing + + ENDIF + + IF CPM AND NOT MPM2 ;if not MP/M, and + jz close2 ;the file isn't open for write, don't bother to close + ENDIF + + IF CPM AND MPM2 AND PRESRV ;always close all files under MP/M + nop + nop + nop + ENDIF + + IF CPM + push h ;save fd table entry addr + call ma2toh ;get the fd in A again + push b + call vfgfcb ;get the appropriate fcb address + xchg ;put it in DE + mvi c,closec ;get BDOS function # for close + call bdos ;and do it! + pop b + pop h +close2: call rstusr ;reset user number to original state + mvi m,0 ;close the file logically + cpi 255 ;if 255 came back from bdos, we got problems + lxi h,0 + rnz ;return 0 if OK + dcx h ;return -1 on error + ret + +; +; Determine status of file whose fd is in A...if the file +; is open, return Cy clear and with the address of the fd table +; entry for the open file in HL. If the file is not open, +; return Cy set: +; + +vfgfd: mov d,a + sui 8 + rc ;if fd < 8, error + cpi nfcbs + cmc ;don't allow too big an fd either + rc + push d + mov e,a ;OK, we have a value in range. Now + mvi d,0 ; see if the file is open or not + lxi h,fdt + dad d ;offset for 3-byte table entries + dad d + dad d + mov a,m + ani 1 ;bit 0 is high if file is open + stc + pop d + mov a,d + rz ;return C set if not open + cmc + ret ;else reset C and return + +; +; Set up a CP/M file control block at HL with the file whose +; simple null-terminated name is pointed to by DE: +; Format for filename must be: "[white space][d:]filename.ext" +; The user number prefix hack is NOT recognized by this subroutine. +; + +vsetfcb: push b + call igwsp ;ignore blanks and tabs + push h ;save fcb ptr + inx d ;peek at 2nd char of filename + ldax d + dcx d + cpi ':' ;default disk byte value is 0 + mvi a,0 ; (for currently logged disk) + jnz setf1 + ldax d ;oh oh...we have a disk designator + call mapuc ;make it upper case + sui 'A'-1 ;and fudge it a bit + inx d ;advance DE past disk designator to filename + inx d +setf1: mov m,a ;set disk byte + inx h + mvi b,8 + call setnm ;set filename, pad with blanks + call setnm3 ;ignore extra characters in filename + ldax d + cpi '.' ;if an extension is given, + jnz setf2 + inx d ;skip the '.' +setf2: mvi b,3 + call setnm ;set the extension field and pad with blanks + xra a ;and zero the appropriate fields of the fcb + mov m,a + lxi d,20 + dad d + mov m,a + inx h + mov m,a ;zero random record bytes of fcb + inx h + mov m,a + inx h + mov m,a + pop d + pop b + ret + +; +; This routine copies up to B characters from (DE) to (HL), +; padding with blanks on the right. An asterisk causes the rest +; of the field to be padded with '?' characters: +; + +setnm: push b +setnm1: ldax d + cpi '*' ;wild card? + mvi a,'?' ;if so, pad with ? characters + jz pad2 + +setnm2: ldax d + call legfc ;next char legal filename char? + jc pad ;if not, go pad for total of B characters + mov m,a ;else store + inx h + inx d + dcr b + jnz setnm1 ;and go for more if B not yet zero + pop b +setnm3: ldax d ;skip rest of filename if B chars already found + call legfc + rc + inx d + jmp setnm3 + +pad: mvi a,' ' ;pad with B blanks +pad2: mov m,a ;pad with B instances of char in A + inx h + dcr b + jnz pad2 + pop b + ret + +; +; Process filename having optional user area number prefix of form "/", +; return the effective user area number of the given filename in the upper +; 5 bits of A, and also store this value at "usrnum". Note that if no user +; number is specified, the current user area is presumed by default. After +; the user area prefix is processed, do a regular "setfcb": +; +; Note: a filename is considered to have a user number if the first char +; in the name is a decimal digit and the first non-decimal-digit +; character in the name is a slash (/). + +vstfcu: push b ;save BC + push h ;save vcb pointer + call igwsp ;ignore blanks and tabs + call isdec ;decimal digit? + jnc setfc2 ;if so, go process + +setfc0: push d ;save text pointer + mvi c,gsuser ;else get current effective user number + mvi e,0ffh + ENDIF + + IF CPM AND USAREA + call bdos ;get current user area if implemented + ENDIF + + IF CPM AND NOT USAREA + mvi a,0 + nop + ENDIF + + IF CPM + pop d ;restore text pointer +setfc1: rlc ;rotate into upper 5 bits of A + rlc + rlc + sta usrnum ;and save + pop h ;restore junk + pop b + jmp setfcb ;and parse rest of filename + +setfc2: mvi b,0 ;clear user number counter + push d ;save text pointer in case we invalidate user prefix +setfc3: sui '0' ;save next digit value + mov c,a ; in C + mov a,b ;multiply previous sum by 10 + add a ;*2 + add a ;*4 + add a ;*8 + add b ;*9 + add b ;*10 + add c ;add new digit + mov b,a ;put sum in B + inx d ;look at next char in text + ldax d ;is it a digit? + call isdec + jnc setfc3 ;if so, go on looping and summing digits + cpi '/' ;make sure number is terminated by a slash + jz setfc4 + pop d ;if not, entire number prefix is not really a + jmp setfc0 ; user number, so just ignore it all. + +setfc4: inx d ;ok, allow the user number + pop h ;get old text pointer off the stack + mov a,b ;get user number value + jmp setfc1 ;and go store it and parse rest of filename + + +; +; Test if char in A is legal character to be in a filename: +; + +legfc: call mapuc + cpi '.' ; '.' is illegal in a filename or extension + stc + rz + cpi ':' ;so is ':' + stc + rz + cpi 7fh ;delete is no good + stc + rz + cpi '!' ;if less than exclamation pt, not legal char + ret ;else good enough + +; +; Map character in A to upper case if it is lower case: +; + +mapuc: cpi 'a' + rc + cpi 'z'+1 + rnc + sui 32 ;if lower case, map to upper + ret + +; +; Ignore blanks and tabs at text pointed to by DE: +; + +igwsp: dcx d +igwsp1: inx d + ldax d + cpi ' ' + jz igwsp1 + cpi 9 + jz igwsp1 + ret + +; +; Return Cy if char in A is not a decimal digit: +; + +isdec: cpi '0' + rc + cpi '9'+1 + cmc + ret + + +; +; This routine does one of two things, depending +; on the value passed in A. +; +; If A is zero, then it finds a free file slot +; (if possible), else returns C set. +; +; If A is non-zero, then it returns the address +; of the fcb corresponding to an open file whose +; fd happens to be the value in A, or C set if there +; is no file associated with fd. +; + +vfgfcb: push b + ora a ;look for free slot? + mov c,a + jnz fgfc2 ;if not, go away + mvi b,nfcbs ;yes. do it... + lxi d,fdt + lxi h,fcbt + mvi c,8 +fgfc1: ldax d + ani 1 + mov a,c + jnz fgfc1a ;found free slot? + pop b ;yes. all done. + ret + +fgfc1a: push d + lxi d,36 ;fcb length to accommodate random I/O + dad d + pop d + inx d ;bump to next 3-byte table entry + inx d + inx d + inr c + dcr b + jnz fgfc1 +fgfc1b: stc + pop b + ret ;return C if no more free slots + +fgfc2: call vfgfd ;compute fcb address for fd in A: + jc fgfc1b ;return C if file isn't open + + sui 8 + mov l,a ;put (fd-8) in HL + mvi h,0 + dad h ;double it + dad h ;4*a + mov d,h ;save 4*a in DE + mov e,l + dad h ;8*a + dad h ;16*a + dad h ;32*a + dad d ;36*a + xchg ;put 36*a in DE + lxi h,fcbt ;add to base of table + dad d ;result in HL + mov a,c ;and return original fd in A + pop b + ret + +; +; The following two subroutines change the current CP/M user area for +; use with file I/O: +; + +vsetusr: + push b ;SET user number to upper bits of A, save current: + push h + push d + push psw ;save A + mvi c,gsuser ;get user code + mvi e,0ffh + ENDIF + + IF CPM AND USAREA + call bdos + ENDIF + + IF CPM AND NOT USAREA + mvi a,0 + nop + ENDIF + + IF CPM + sta curusr ;save current user number + pop psw ;get new user number byte + push psw + rar ;shift user number down to low bits + rar + rar + ani 1fh ;and mask off high order garbage +setu0: mov e,a + mvi c,gsuser ;set user code + ENDIF + + IF CPM AND USAREA + call bdos + ENDIF + + IF CPM AND NOT USAREA AND PRESRV + nop + nop + nop + ENDIF + + IF CPM + pop psw + pop d + pop h + pop b + ret + +vrstusr: + push b + push h + push d + push psw + lda curusr ;get last saved user number + jmp setu0 ;and go set current user area to that + + ENDIF ;end of CP/M-related file I/O routines + + + IF NOT CPM +main: equ $ ;where main program resides when not under CP/M + ;(under CP/M, the data area comes first) + ENDIF + + +; +; Ram area: +; + + IF CPM ; Plug this value into BDS.LIB before CASM'ing +ram equ $ ; the new library. The "org ram" at the end of this + ENDIF ; source file should cause the assembler to print + ; the value of "ram" at the end of the assembly. + + IF NOT CPM + org ram ;if not under CP/M, use custom ram area address + ENDIF + +errnum: ds 1 ;error code from file I/O operations +rseed: ds 8 ;the random generator seed +args: ds 14 ;"arghak" puts args passed on stack here. +iohack: ds 6 ;room for I/O subroutines for use by "inp" + ;and "outp" library routines + +allocp: ds 2 ;pointer to free storage for use by "sbrk" func +alocmx: ds 2 ;highest location to be made available to the + ;storage allocator + + ;20 bytes of misc. scratch & state variables: +tmp ds 1 +tmp1 ds 1 +tmp2 ds 2 +tmp2a ds 2 +unused ds 2 + +curusr ds 1 ;used to save current user number during file I/O +usrnum ds 1 ;set by "setfcu" to user number of given filename + + ;Console I/O control data: +chmode db 0 ;0: single char mode, 1: line buffered mode +nleft db 0 ;# of chars left in buffer (if chmode == 1) +ungetl db 0 ;"ungetch" data byte (0 if no char pushback) +iobrf db 1 ;check for break on character input/output + +spsav ds 2 ;BDOS's saved SP value upon entry from CCP + + ds 4 ;total of 20 bytes of misc. data area + +; +;-------------------------------------------------------------------------- +; The following data areas are needed only if running under CP/M: +; + + IF CPM +; +; The fcb table (fcbt): 36 bytes per file control block +; + +fcbt: ds 36*nfcbs ;reserve room for fcb's (extra byte for IMDOS) + + +; +; The fd table: three bytes per file specifying r/w/open as follows: +; BYTE 1: +; bit 0 is high if open, low if closed +; bit 1 is high if open for read +; bit 2 is high if open for write (both b1 and b2 may be high) +; bits 3-7 contain the user number in which the file is active (0-31) +; BYTES 2&3: +; Highest sector number seen so far during I/O (for cfsize calls) +; + +fdt: ds 3*nfcbs + +; +; The command line is copied here by init: +; + +comlin: ds 131 ;copy of the command line pointed to by entries + ;in arglst + + +; +; This is where "init" places the array of argument pointers: +; + +arglst: ds 40 ;the "argv" paramater points here (well, + ;actually to 2 bytes before arglst). Thus, + ;up to 20 parameters may be passed to "main" + ENDIF + +; +; End of CP/M-only data area +;--------------------------------------------------------------------------- + + IF CPM +main equ $ ;where "main" program will be loaded under CP/M + ENDIF + + IF NOT M80 + org ram ;set next pc value back to ram origin, so the value + ENDIF ;will be displayed by the assembler for convenience + + end + + \ No newline at end of file diff --git a/disks/images/c/CCONFIG.C b/disks/images/c/CCONFIG.C new file mode 100644 index 0000000..4d81df0 --- /dev/null +++ b/disks/images/c/CCONFIG.C @@ -0,0 +1,297 @@ +/* + CCONFIG.C + BDS C v1.6 Automated Configuration Program + Written 4/86 by Leor Zolman + BD Software, Inc. + + compile & link: + cc cconfig.c -e5000 + cc cconfig2.c -e5000 + clink cconfig cconfig2 + + Note: This program may be used as a template for creating a + configuration tool for any general purpose utility that contains + a block of bytes of customization data. I therefore donate this + program to the public domain. + -leor + +*/ + +#include +#include "cconfig.h" + +main() +{ + int i; + + init(); + + p("\nBDS C v1.6 Automatic Configuration System\n\n") + p("This program makes physical changes to the files CC.COM and") + p("CLINK.COM so as to customize their operation for your specific") + p("file system and operating system environment. Do NOT run this") + p("program until you have backed up your master BDS C distribution") + p("disks and physically removed them from your disk drives.\n\n") + + p("Have you backed up your master disks and placed copies of CC.COM") + p("and CLINK.COM in the currently logged directory?") + if (!ask(0)) + { + p("Then do so now, and run this program again when ready\n") + exit(); + } + + p("\n\nThen we are ready to begin.\n") + p("\n Note: Typing ^Z- (control-Z and a return) in\n") + p(" response to any question in the option dialogue\n") + p(" causes the option value to remain unchanged and\n") + p(" control to return to the main menu.\n\n") + + read_block(); + + setjmp(jbuf); + + while(1) + { + display(); /* display current options status */ + p("Type the code number of the option you wish") + p("to change, 'all' to go through the entire list, or") + p("'q' to quit: ") + switch(c = tolower(igsp(gets(strbuf)))) + { + case 'q': if (made_changes) + if (ask("\nWrite changes to disk?")) + { + write_block(); + p("New CC.COM and CLINK.COM written.\n") + } + else + p("Old configuration left intact.\n") + else + p("No changes specified.\n") + + exit(); + + case 'a': p("\n\tNote: ^Z returns to the main") + p("menu at any time.\n\n") + for (i = 0; i < NBYTES; i++) + { + p("\n\n"); + old_val = cblock[i]; + (*funcs[i])(); + if (old_val != cblock[i]) + made_changes = TRUE; + } + continue; + + default: if (!isdigit(c) || + (i = atoi(strbuf)) < 0 || i >= NBYTES) + { + p("Invalid selection. Try again...") + continue; + } + p("\n") + old_val = cblock[i]; + (*funcs[i])(); + if (old_val != cblock[i]) + made_changes = TRUE; + } + } +} + + +excurlog() +{ + p("\nNote: The term \"currently logged\", as used in the following") + p("dialogue, refers to the disk drive and user area that will be") + p("currently logged at the time CC.COM or CLINK.COM is invoked, not") + p("necessarily the drive and user area currently logged right now") + p("while you run CCONFIG.\n\n") +} + + +dodefdsk() +{ + p("DEFAULT LIBRARY DISK DRIVE:\n") + excurlog(); + p("The default library disk drive is the drive that CC and CLINK") + p("automatically search for system header files and default library") + p("object modules. If you do not choose a specific drive, then") + p("the currently logged disk at the time of command invokation will") + p("be searched by default.") + p("Enter either an explicit default library disk drive, or type") + p("RETURN to always search the currently logged drive: ") + + if (isalpha(c = toupper(igsp(gets0(strbuf))))) + defdsk = c - 'A'; + else + defdsk = 0xFF; +} + +dodefusr() +{ + p("DEFAULT LIBRARY USER AREA:\n") + excurlog(); + p("The default library user area is the user area that CC and CLINK") + p("automatically search for system header files and default library") + p("object modules. If you don't choose a specific user area, then") + p("the currently logged user area at the time of command invokation") + p("will be searched by default.\n") + + p("Enter either an explicit default library user area, or type RETURN") + p("to always search the currently logged user area: ") + + if (isdigit(igsp(gets0(strbuf)))) + defusr = atoi(strbuf); + else + defusr = 0xFF; +} + +dodefsub() +{ + p("\"SUBMIT FILE\" DRIVE SELECTION:\n") + excurlog(); + p("In order to terminate a batch (\"submit\") file sequence upon") + p("fatal compiler or linker error, CC and CLINK must know which") + p("disk drive contains the temporary scratch file used by SUBMIT.COM") + p("and similar utilities. This will usually be either drive A: or") + p("the currently logged drive. Enter the drive name now, or type") + p("RETURN to use the \"currently logged drive\": ") + + if (isalpha(c = toupper(igsp(gets0(strbuf))))) + defsub = c - 'A'; + else + defsub = 0xFF; +} + +doconpol() +{ + p("CONSOLE POLLING FOR CONTROL-C:\n") + p("When console polling is enabled, CC and CLINK will constantly") + p("check the console keyboard during their operation to see if") + p("control-C has been typed. If control-C is detected, the command") + p("is immedieatly aborted and control returns to CP/M command level.") + p("Any characters OTHER than control-C are ignored and discarded.") + p("Therefore, if your system supports keyboard \"type-ahead\" and you") + p("want to take advantage of that feature during CC or CLINK") + p("operation, you may not want console-polling activated.\n") + p("Do you wish to have console-polling take place? ") + + conpol = yesp(); +} + +dowboote() +{ + p("WARM-BOOT SUPPRESSION CONTROL:\n") + p("CC and CLINK have the ability to return to CP/M command level") + p("following completion of their tasks without having to perform") + p("a \"warm-boot\" (the re-loading of the CP/M Console Command") + p("Processor (CCP) from disk). They take advantage of this ability") + p("any time a compilation or linkage does not require the use of the") + p("memory occupied by the CCP. This \"warm-boot suppression\" results") + p("in a speedier return to command level.\nOn some CP/M-like systems,") + p("though, this feature doesn't work because a valid stack pointer is") + p("never provided to transient commands by the operating system. One") + p("symptom is that the command will appear to terminate normally, but") + p("instead of returning to command level, the system hangs.") + p("In the case of CC.COM, for example, a .CRL file may") + p("be successfully generated before the crash.\nIf something like") + p("this happens on") + p("your system, you must a) DISABLE warm-boot suppression to insure") + p("clean command termination, and b) don't use the -n CLINK option") + p("when the target system cannot handle warm-boot suppression.") + p("\nDo you want warm-boot suppression? "); + + wboote = !yesp(); +} + +dopstrip() +{ + p("PARITY BIT CONTROL:\n") + p("This option deals with the handling of parity bits (the high-order") + p("bit of ASCII-encoded text characters) by the compiler during") + p("compilation. Normally, CC strips (forces to zero) the parity bits") + p("from C source input files.") + p("The only case where this might be undesireable is when a") + p("special character set, utilizing the high-order bit as part of") + p("the character representation, is being used. Bilingual or") + p("extended character sets, for example, may use the parity bit in") + p("this way. If this is the case in your situation, then do not") + p("enable parity-bit stripping. Otherwise, you should let") + p("the parity bits be stripped, so that the compiler will not be") + p("confused by source files produced under certain text editors") + p("that use the parity bit for formatting information.\n") + + p("Do you wish to let parity bits be stripped? ") + pstrip = yesp(); +} + +donouser() +{ + p("USER-AREA SWITCHING CONTROL:\n") + p("Normally CC and CLINK expect to be running on a CP/M") + p("(or CP/M-like) system supporting \"user areas\" (the subdivision") + p("of disk drive directories into 32 partitions numbered 0-31.)") + p("The upshot is that specific user areas may be directly addressed") + p("by CC and CLINK during the course of their operations, thus") + p("possibly creating a conflict between themselves and certain") + p("third-party command processors (MicroShell, ZCPR3, etc.) that") + p("maintain an automatic search path mechanism for data files. If") + p("you are running such a utility on your system and you notice") + p("that files aren't being correctly located by CC and CLINK, try") + p("disabling user-area switching with this option. The effect will") + p("be that CC and CLINK will no longer perform any user-area") + p("operations at all, allowing your own command processor to") + p("determine the default user areas for file operations.\n") + p("If your system does not support user areas at all, then you") + p("definitely want to disable user-area switching here.\n") + p("\n(Note: In order to disable user-area switching in C-generated") + p("COM files, it is necessary to customize the run-time package") + p("by changing the value of the NOUSER symbol in CCC.ASM.)\n") + p("\nDo you wish to disable user-area switching? ") + nouser = yesp(); +} + + +dowerrs() +{ + p("RED EDITOR ERROR FILE CONTROL:\n") + p("CC can write out an error file containing information about the") + p("location and nature of source file errors detected during") + p("the course of an unsuccessful compilation. The RED text editor") + p("recognizes this file and makes the editing of those errors very") + p("convenient. If you wish, you can have CC automatically write out") + p("such an error file whenever source file errors are detected. If") + p("you choose not to have CC write the file out automatically every") + p("time, you may still choose to have the file written during") + p("individual compilations through use of the CC command-line") + p("option \"-w\".\n") + p("Do you wish to have the RED error file written out automatically") + p("every time compilation errors are detected? ") + werrs = yesp(); +} + +docdbrst() +{ + p("CDB RESTART VECTOR SELECTION:\n") + p("The CDB Debugger allows interactive debugging of C programs") + p("through the use of an interrupt vector down in low system") + p("memory, just as DDT or SID uses restart 7. As distributed,") + p("CDB is compiled to use RST 6 for this purpose, and the compiler") + p("correspondingly presumes a default of -k6 when the -k option is") + p("given without an argument. If you wish to change the restart") + p("vector used by CDB, then you must recompile CDB according to the") + p("CDB documentation to change its default restart location.\nBy") + p("choosing a new restart vector value HERE, you are only telling") + p("CC.COM what the new default is, so that you don't have to bother") + p("specifying it when using the -k option on the CC command line.\n") + + p("Enter the restart vector (1-7) you wish to have CC use as the") + p("default -k argument: ") + + if (isdigit(igsp(gets0(strbuf)))) + cdbrst = atoi(strbuf); + else + p("Value left unchanged.\n") +} + \ No newline at end of file diff --git a/disks/images/c/CCONFIG.COM b/disks/images/c/CCONFIG.COM new file mode 100755 index 0000000..3283eef Binary files /dev/null and b/disks/images/c/CCONFIG.COM differ diff --git a/disks/images/c/CCONFIG.H b/disks/images/c/CCONFIG.H new file mode 100644 index 0000000..4986a3f --- /dev/null +++ b/disks/images/c/CCONFIG.H @@ -0,0 +1,31 @@ + +#define MAXCOL 80 /* Number of columns on your terminal */ + +#define NBYTES 10 /* Number of bytes in configuration block */ + +#define defdsk cblock[0] /* default library disk byte */ +#define defusr cblock[1] /* default library user area byte */ +#define defsub cblock[2] /* default submit file disk drive byte */ +#define conpol cblock[3] /* console interrupt polling flag byte */ +#define wboote cblock[4] /* warm-boot control byte */ +#define pstrip cblock[5] /* parity stripping control byte */ +#define nouser cblock[6] /* ignore user areas control byte */ +#define werrs cblock[7] /* write PROGERRS.$$$ for RED control byte */ +#define optim cblock[8] /* optimization control byte */ +#define cdbrst cblock[9] /* CDB default restart vector */ + +#define p(text) prnt(text); /* maximizes source text line width */ + +int column; /* current column position for prnt() function */ +int made_changes; /* true if any options re-configured */ +char old_val; /* old value of each option, to detect changes */ + +char cblock[NBYTES]; +int (*funcs[NBYTES])(); + +int fd_cc, fd_clink; /* file descriptors */ +char secbuf[128]; /* sector buffer for reading/writing CC, CLINK */ +char strbuf[120], c; + +char jbuf[JBUFSIZE]; + \ No newline at end of file diff --git a/disks/images/c/CCONFIG2.C b/disks/images/c/CCONFIG2.C new file mode 100644 index 0000000..3477c1d --- /dev/null +++ b/disks/images/c/CCONFIG2.C @@ -0,0 +1,302 @@ +/* + CCONFIG2.C: Second primary source file for the CCONFIG + utility. See CCONFIG.C for essential information +*/ + +#include +#include "cconfig.h" + +dooptim() +{ + char c; + int i; + + p("CODE OPTIMIZATION CONTROL:\n") + p("Compiled BDS C code can be optimized for either speed or space,") + p("through the use of several unique 'tuning' controls. The") + p("configuration you are about to perform sets only the default") + p("optimization mode; any") + p("compilation may be individually tailored by using the -o and -z") + p("CC command-line options.\n\n") + p("There are three code optimization modes for BDS C: ") + p("'fast', 'short' and 'extended-short'.\n\n") + p("FAST mode causes all code sequences to run") + p("as fast as possible; this can be achieved by using the \"-o\" and") + p("\"-e \" CC command-line options while making all variables") + p("in the program external.\n") + p("SHORT mode replaces several common code sequences by") + p("calls to equivalent subroutines in the run-time package.") + p("This slows execution down a bit, due to the subroutine overhead,") + p("but saves considerable space. This is the default") + p("mode set in the distribution package.\n") + + p("(Press RETURN to continue)"); getch(); + + p("EXTENDED-SHORT mode does everything that simple-short mode does,") + p("but") + p("also takes advantage of any unused system restart vectors that") + p("may be available on a SPECIFIC target computer system.") + p("This is accomplished by collapsing") + p("certain very common, short (3-6 byte) code sequences into") + p("1-byte RST instructions. To use this mode you must first know") + p("which RST vectors") + p("are available on the target system. Then you change the") + p("appropriate symbols (ZOPT1-ZOPT7)") + p("in the run-time package source file and re-assemble the run-time") + p("package. Finally, the \"-z\" CC command-line option is") + p("used to tell CC which RST vectors are available.\n") + + go: p("\nPlease choose the default optimization mode:\n") + p("Fast (F), Short (S), or Extended-Short (E): ") + + switch(c = toupper(getch())) + { + case 'F': optim = 0; + break; + + case 'S': optim = 0x80; + break; + + case 'E': optim = 0x80; + p("For extended mode, you need to specifiy those restart") + p("vectors that are guaranteed to be unused by any other") + p("software on the target system. Any restart vector") + p("except RST 0 may be used, i.e., RST 1 through RST 7.\n") + p("Answer 'y' or 'n' to each query to specify if the") + p("respective RST vector is available") + p("for extended-short RST optimization:\n") + for (i = 1; i < 8; i++) + { + p("RST ") + putchar(i+'0'); + p(" ? ") + optim |= yesp() << (i - 1); + } + break; + + default: p("Invalid selection. Try again:\n"); + goto go; + } +} + +char *gets0(str) /* Accept text input, ^Z aborts back to menu level */ +char *str; +{ + gets(str); + if (igsp(str) == 'Z'-0x40) + longjmp(jbuf); + return str; +} + + +int yesp() +{ + char c; + while (1) + { + column = 1; /* prevent spurious newlines */ + + if ((c = toupper(igsp(gets0(strbuf)))) == 'Y') + return TRUE; + else if (c == 'N') + return FALSE; + p("Please answer 'yes' or 'no'... ? ") + } +} + + +display() +{ + int i; + + p("\nThe configuration options are currently set as follows:\n\n") + + p(" Code# Option Current Setting\n") + p(" ----- ------ ---------------") + p("\n 0: Default Drive ") + if (defdsk == 0xff) + p("Currently logged drive") + else + printf("Drive %c:", defdsk + 'A'); + + p("\n 1: Default User Area ") + if (defusr == 0xff) + p("Currently logged user area") + else + printf("User %d", defusr); + + p("\n 2: Submit File Drive ") + if (defsub == 0xff) + p("Currently logged drive") + else + printf("Drive %c:", defsub + 'A'); + + p("\n 3: Console Interrupts ") + if (conpol) p("Enabled") else p("Disabled") + + p("\n 4: Suppress Warm Boot? ") + if (wboote) p("No") else p("Yes") + + p("\n 5: Strip Source Parity? ") + if (pstrip) p("Yes") else p("No") + + p("\n 6: Recognize User Areas? ") + if (nouser) p("No") else p("Yes") + + p("\n 7: Write RED Error File? ") + if (werrs) p("Yes") else p("No") + + p("\n 8: Optimization Mode ") + if (optim == 0) + p("Fast Execution, Long Code Sequences") + else + { + p("Short Code, ") + if (optim == 0x80) + p("No Restarts") + else + { + p("Use RST vectors: ") + for (i = 1; i < 8; i++) + if (optim & (1 << (i - 1))) + printf("%d ",i); + } + } + + p("\n 9: Default CDB RST Vector ") + printf("RST %d", cdbrst); + + p("\n\n") +} + +read_block() +{ + if ((fd_cc = open("CC.COM", 2)) == ERROR || + (fd_clink = open("CLINK.COM", 2)) == ERROR) + { + p("\nCCONFIG requires copies of both CC.COM and CLINK.COM") + p("to be present in the currently logged directory. Please copy") + p("them to this directory now, then run CCONFIG again.\n") + exit(); + } + if (read(fd_cc, secbuf, 1) != 1) + { + p("Disk error reading CC.COM.") + exit(); + } + movmem(&secbuf[0x55], cblock, NBYTES); +} + +write_block() +{ + movmem(cblock, &secbuf[0x55], NBYTES); + seek(fd_cc, 0, 0); + if (write(fd_cc, secbuf, 1) == 1) + close(fd_cc); + else + { + p("\nError writing CC.COM.") + foo: p("Please place fresh copies of CC.COM and") + p("CLINK.COM in the current directory, and run CCONFIG") + p("again. Sorry, but I don't know why this happened.\n") + exit(); + } + + read(fd_clink, secbuf, 1); + movmem(cblock, &secbuf[0x03], NBYTES); + seek(fd_clink, 0, 0); + if (write(fd_clink, secbuf, 1) == 1) + close(fd_clink); + else + { + p("\nError writing CLINK.COM.") + goto foo; + } + + p("\nCC.COM and CLINK.COM successfully updated.\n"); +} + +prnt(str) /* print given text, automatically filling to length of line */ +char *str; +{ + char c; + + while (c = *str++) + { + if (c != '\n' && (wdlen(str) + column++) < (MAXCOL - 3)) + { + putchar(c); + if (!*str) + putchar(' '); + continue; + } + + putchar('\n'); + + if (!isspace(c)) + putchar(c); + + column = 1; + } +} + + +int getch() /* get a char of text */ +{ + int c; + if ((c = getchar()) == -1) + longjmp(jbuf); + p("\n") + return c; +} + + +int wdlen(txt) /* return length of text word */ +char *txt; +{ + int i; + for (i = 0; *txt && !isspace(*txt++); i++) + ; + return i; +} + + +int ask(txt) +char *txt; +{ + char strbuf[30]; + + if (txt) + p(txt) + + gets(strbuf); + + column = 0; + + if (tolower(igsp(strbuf)) == 'y') + return TRUE; + else + return FALSE; +} + +char igsp(txt) /* return first non-space character */ +char *txt; +{ + char c; + while (isspace(c = *txt++)) + ; + return c; +} + +init() +{ + + int dodefdsk(), dodefusr(), dodefsub(), doconpol(), dowboote(); + int dopstrip(), donouser(), dowerrs(), dooptim(), docdbrst(); + + initptr(&funcs, &dodefdsk, &dodefusr, &dodefsub, &doconpol, &dowboote, + &dopstrip, &donouser, &dowerrs, &dooptim, &docdbrst, NULL); + + made_changes = column = 0; +} + \ No newline at end of file diff --git a/disks/images/c/CHARIO.C b/disks/images/c/CHARIO.C new file mode 100644 index 0000000..fafcad8 --- /dev/null +++ b/disks/images/c/CHARIO.C @@ -0,0 +1,166 @@ +/* CHARIO.C Character-oriented file I/O + + Written 1980 by Scott W. Layson + This code is in the public domain. + +These routines deal with reading and writing large blocks of +characters, when they do not fit neatly in sectors. At the moment, +only sequential output is supported; input is fully random. */ + + +#define TRUE (-1) +#define FALSE 0 +#define NULL 0 + + +/* i/o buffer */ +struct iobuf { + int fd; + int isect; /* currently buffered sector */ + int nextc; /* index of next char in buffer */ + char buff [128]; + }; + +/* seek opcodes */ +#define ABSOLUTE 0 +#define RELATIVE 1 + +#define INPUT 0 +#define OUTPUT 1 +#define UPDATE 2 + + +copen (buf, fname) /* open a file for char input */ + struct iobuf *buf; + char *fname; +{ + buf->fd = open (fname, INPUT); + if (buf->fd == -1) return (-1); + read (buf->fd, &buf->buff, 1); + buf->isect = 0; + buf->nextc = 0; + return (buf); + } + + +ccreat (buf, fname) /* create a file for char output */ + struct iobuf *buf; + char *fname; +{ + buf->fd = creat (fname); + if (buf->fd == -1) return (-1); + buf->isect = 0; + buf->nextc = 0; + return (buf); + } + + +cclose (buf) /* close the file assoc. with buf */ + struct iobuf *buf; +{ + close (buf->fd); + } + + +cseek (buf, nbytes, code) /* seek to a character (input only!) */ + struct iobuf *buf; + unsigned nbytes, code; +{ + int newsect; + + if (buf < 0) return (-1); + if (code == RELATIVE) nbytes += buf->isect * 128 + buf->nextc; + newsect = nbytes / 128; + if (newsect != buf->isect + && (seek (buf->fd, newsect, ABSOLUTE) == -1 + || read (buf->fd, &buf->buff, 1) == -1)) return (-1); + buf->nextc = nbytes % 128; + buf->isect = newsect; + return (nbytes); + } + + +cread (buf, dest, nbytes) /* read some bytes into dest */ + struct iobuf *buf; + char *dest; + unsigned nbytes; +{ + int navail, nsects, nleft, nread1, nread2; + + if (buf < 0) return (-1); + navail = umin (nbytes, 128 - buf->nextc); + movmem (&buf->buff[buf->nextc], dest, navail); + nbytes -= navail; + buf->nextc += navail; + dest += navail; + nsects = nbytes / 128; + if (nsects) { + nread1 = read (buf->fd, dest, nsects); + if (nread1 == -1) return (navail); + buf->isect += nread1; + if (nread1 < nsects) return (navail + nread1 * 128); + dest += nread1 * 128; + } + else nread1 = 0; + if (buf->nextc == 128) { + nread2 = read (buf->fd, &buf->buff, 1); + if (nread2 == -1) return (navail); + ++(buf->isect); + buf->nextc = 0; + if (nread2 < 1) return (navail + nread1 * 128); + } + nleft = nbytes % 128; + movmem (&buf->buff, dest, nleft); + buf->nextc += nleft; + return (navail + nbytes); + } + + +cwrite (buf, source, nbytes) /* write some bytes from source */ + struct iobuf *buf; + char *source; + unsigned nbytes; +{ + unsigned nleft, nfill, nsects; + + if (buf < 0) return (-1); + if (buf->nextc) { + nfill = umin (nbytes, 128 - buf->nextc); + movmem (source, &buf->buff[buf->nextc], nfill); + buf->nextc += nfill; + nbytes -= nfill; + source += nfill; + } + if (buf->nextc == 128) { + ++(buf->isect); + buf->nextc = 0; + if (write (buf->fd, &buf->buff, 1) < 1) return (-1); + } + nsects = nbytes / 128; + if (nsects && write (buf->fd, source, nsects) < nsects) + return (-1); + nbytes %= 128; + movmem (source + nsects * 128, &buf->buff, nbytes); + buf->nextc += nbytes; + return (nsects * 128 + nbytes); + } + + +cflush (buf) /* flush an output buffer */ + struct iobuf *buf; +{ + if (buf->nextc && write (buf->fd, &buf->buff, 1) < 1) + return (-1); + return (1); + } + + +umin (a, b) /* unsigned min */ + unsigned a, b; +{ + return ((a < b) ? a : b); + } + + +/* End of CHARIO.C -- Character oriented file I/O */ +s) /* write some bytes from source \ No newline at end of file diff --git a/disks/images/c/CLIB.COM b/disks/images/c/CLIB.COM new file mode 100755 index 0000000..a4fec2f Binary files /dev/null and b/disks/images/c/CLIB.COM differ diff --git a/disks/images/c/CLINK.COM b/disks/images/c/CLINK.COM new file mode 100755 index 0000000..39b8ec6 Binary files /dev/null and b/disks/images/c/CLINK.COM differ diff --git a/disks/images/c/CLOAD.C b/disks/images/c/CLOAD.C new file mode 100644 index 0000000..ce0bd5f --- /dev/null +++ b/disks/images/c/CLOAD.C @@ -0,0 +1,159 @@ +/* + CASM Image Hex-to-Crl Converter + + Copyright (c) 1983 William C. Colley III + + Created 10 March 1983 by William C. Colley III + +This utility converts the Intel hex image that results from the CASM/ASM +process to a BDS C relocatable object image. CLOAD is necessary due to the +CP/M LOAD.COM utility's inability to handle binary images having an origin +address at anywhere other than 0100h. + +To use the program, you do the following: + + A>cload [.hex] [-o [.crl]] + +The optional -o option allows you to specify the name of the output file. If +you don't use -o, the output file will be named .crl. The input file- +name extension defaults to ".hex" if none is specified. The output filename +extension defaults to ".crl". + +Compile & Link: + cc cload.c + clink cload -n + +*/ + +#include + +#define HARD 1 +#define SOFT 0 + +#define STACKSZ 1024 + +/* These things are used to manipulate the input and output files. */ + +char hexname[MAXLINE], crlname[MAXLINE]; +FILE *hex; int crl; + +/* These things are used to manipulate the core buffer. */ + +char *bbase, *bend, *bsize; + +/* These things are used to do the reading of the Intel hex file. */ + +char bcnt, chks; +union { + struct { char l, h; } b; + unsigned w; +} addr; + +/* These things are reserved for the use of the main() function. */ + +char *p; int i; + +/* This thing is reserved for the use of the hgetc() function. */ + +int j; + +/* This thing is reserved for the use of the hgetn() function. */ + +int k; + +main(argc,argv) +int argc; +char *argv[]; +{ + char hgetc(), *endext(), *topofmem(); + + puts("CASM Image Hex-to-Crl Converter -- v1.6\n"); + puts("Copyright (c) 1983 William C. Colley III\n\n"); + + for (p = hexname; --argc && p; ) { + if (**++argv == '-') p = (*++*argv == 'O' ? crlname : NULL); + else { + if (*p) p = NULL; + else { + makename(p,*argv,p == hexname ? ".HEX" : ".CRL",SOFT); + p = hexname; + } + } + } + + if (!p || !hexname[0]) { + puts("Usage: A>cload hexname[.ext] [-o crlname[.ext]]\n"); + exit(); + } + if (!crlname[0]) makename(crlname,hexname,".CRL",HARD); + + if ((hex = fopen(hexname,"r")) == ERROR) die(NULL); + if ((crl = creat(crlname)) == ERROR) die(NULL); + + bbase = bsize = sbrk(5000); bend = topofmem() - STACKSZ; + + for (;;) { + while ((i = getc(hex)) != ':') + if (i == ERROR || i == CPMEOF) badfile(); + chks = 0; bcnt = hgetc(); addr.b.h = hgetc(); + addr.b.l = hgetc(); hgetc(); + if (bcnt == 0) { + if (hgetc(),chks) badfile(); + break; + } + for (p = bbase + addr.w - 0x100; bcnt; --bcnt) { + if (p > bend) die("Out of memory"); + if (p > bsize) bsize = p; + *p++ = hgetc(); + } + if (hgetc(),chks) badfile(); + } + + i = (bsize - bbase + SECSIZ) / SECSIZ; + + if(write(crl,bbase,i) != i || fclose(hex) == ERROR || close(crl) == ERROR) + die(NULL); + + puts(crlname); + puts(" successfully generated.\n"); +} + +makename(new,old,ext,flg) +char *new, *old, *ext; +int flg; +{ + while (*old) { + if (*old == '.') { strcpy(new,flg ? ext : old); return; } + *new++ = *old++; + } + strcpy(new,ext); +} + +int hgetc() +{ + int j; + + j = hgetn() << 4; chks += (j += hgetn()); return j; +} + +int hgetn() +{ + int k; + + if ((k = getc(hex)) >= '0' && k <= '9') return k - '0'; + if (k >= 'A' && k <= 'F') return k - ('A' - 10); + badfile(); +} + +badfile() +{ + die("Defective Intel hex file"); +} + +die(msg) +char *msg; +{ + puts(msg ? msg : errmsg(errno())); putchar('\n'); exit(); +} + + \ No newline at end of file diff --git a/disks/images/c/CRCK.COM b/disks/images/c/CRCK.COM new file mode 100755 index 0000000..94ed532 Binary files /dev/null and b/disks/images/c/CRCK.COM differ diff --git a/disks/images/c/CRCK.DOC b/disks/images/c/CRCK.DOC new file mode 100644 index 0000000..2dc5899 --- /dev/null +++ b/disks/images/c/CRCK.DOC @@ -0,0 +1,21 @@ +CRCK.COM +-------- + +A Checksum program, CRCK.COM, is provided to verify that all files in +the BDS C package survived shipment intact. + +The usage of CRCK.COM is as follows: + +CRCK -- displays checksum for all files that match the + specification + +CRCK f -- If a second parameter being the letter "F" follows + the , then a file named CRCKLIST.CRC is + written to disk containing all the checksum info + that was displayed on the console. + +Note that you should have backed up the original distribution disks before +running CRCK with the "f" option, or else the new CRCKLIST.CRC might wipe +out the original copy supplied on the master distribution disks. + + \ No newline at end of file diff --git a/disks/images/c/CRCKLST1.CRC b/disks/images/c/CRCKLST1.CRC new file mode 100644 index 0000000..916b688 --- /dev/null +++ b/disks/images/c/CRCKLST1.CRC @@ -0,0 +1,22 @@ +EXAMPLES.LBR CRC = EDCF +C .CCC CRC = BE99 +C .SUB CRC = B68C +SOURCES .LBR CRC = D853 +CC .COM CRC = D3C4 +CC2 .COM CRC = 6CE1 +CRCK .COM CRC = 6A0F +CRCK .DOC CRC = B69F +LDIR .COM CRC = FB59 +CHARIO .C CRC = 169D +CLIB .COM CRC = F655 +CLINK .COM CRC = B3AF +-READ .ME CRC = 2C76 +DEFF .CRL CRC = 97CC +DEFF2 .CRL CRC = 422C +--BDSC-1.60C CRC = 0000 +-LBR .NOT CRC = 0C9B +CCONFIG .COM CRC = 1F6E +FILES .DOC CRC = 9379 +LBREXT .COM CRC = F6A4 +ZCASM .LBR CRC = B247 + \ No newline at end of file diff --git a/disks/images/c/DEFF.CRL b/disks/images/c/DEFF.CRL new file mode 100644 index 0000000..f048221 Binary files /dev/null and b/disks/images/c/DEFF.CRL differ diff --git a/disks/images/c/DEFF2.CRL b/disks/images/c/DEFF2.CRL new file mode 100644 index 0000000..5451581 Binary files /dev/null and b/disks/images/c/DEFF2.CRL differ diff --git a/disks/images/c/DEFF2A.CSM b/disks/images/c/DEFF2A.CSM new file mode 100644 index 0000000..63907e2 --- /dev/null +++ b/disks/images/c/DEFF2A.CSM @@ -0,0 +1,1047 @@ +; +; BD Software C Compiler v1.6 +; Standard Library Machine Language Functions (part A) +; Copyright (c) 1982, 1986 by BD Software, Inc. +; +; This file is in "CSM" format; to convert to CRL format, +; use CASM.SUB in conjunction with CASM.COM, ASM.COM and CLOAD.COM. +; +; Functions appearing in this file: +; +; cmode iobreak getchar kbhit ungetch putchar +; gets getline +; rand srand srand1 nrand +; csw setmem movmem memcmp +; call calla +; inp outp peek poke +; sleep pause exit +; bdos bios biosh +; codend externs endext topofmem +; exec execv +; rbrk sbrk rsvstk +; index +; setjmp longjmp +; + + INCLUDE "bds.lib" + + + FUNCTION cmode + call ma1toh ;get arg + xchg ;put in DE + lxi h,chmode ;get address of char mode flag + mov d,m ;get old mode in D + mov m,e ;set new mode + xra a ;clear pushback byte + sta ungetl + inx h + mov m,a ;and line buffer char count + mov l,d ;return old value of chmode + mvi h,0 + ret + ENDFUNC + + + FUNCTION iobreak + call ma1toh ;get arg + sta iobrf + ret + ENDFUNC + + FUNCTION getchar + lda ungetl ;any character pushed back? + mov l,a + ora a + jz getit + xra a ;yes. return it and clear the pushback + sta ungetl ;byte in C.CCC. + mov h,a ;clear h + ret + +getit: + push b + lxi h,chmode ;get address of chmode flag + mov a,m + ora a + jz single ;jump if single mode + inx h + push h ;save &nleft + mov a,m ;get number of chars left in buf + ora a + jnz gnext ;jump if characters in buffer + ;fill buffer: + lxi d,gcbuff ;DE = buffer address + mvi c,getlin + call bdos ;read console buffer + mvi c,conout + mvi e,lf + call bdos ;linefeed to console + lxi h,gcline + shld gcptr ;initialize gcptr + lda gcnum ;number of chars just read + lxi h,nleft ;HL = &nleft + mov m,a ;set number of characters + cpi maxl + jz gnext ;if buffer completely full, don't append nl + mov e,a + mvi d,0 ;DE = number of characters + inr m ;nleft++ + lxi h,gcline + dad d ;HL = addr of next char pos after end + mvi m,newlin ;append newline char + +gnext: pop h ;now take a char from the buffer + dcr m ;nleft-- + lhld gcptr ;get next char + mov a,m + inx h ;bump ptr + shld gcptr + jmp gotit + +single: mvi c,conin ;get single char from bdos + call bdos + cpi cr ;carriage return? + jnz gotit + mvi c,conout ;if so, echo linefeed + mvi e,lf + call bdos + mvi a,newlin ;and return newline (linefeed).. + +gotit: mov b,a ;save char in B + lda iobrf ;checking for BREAK character? + ora a + mov a,b ;restore char into A + pop b ;restore BC + jz gotit2 ;if not checking for BREAK, skip test + cpi cntrlc ;control-C ? + jz exit ;if so, exit the program. +gotit2: cpi 1ah ;control-Z ? + lxi h,-1 ;if so, return -1. + rz + mov l,a ;else return char in HL + mvi h,0 + ret + +maxl equ 79 ;max length of line of buffered console input +gcptr ds 2 ;pointer into line where first char is +gcbuff db maxl ;max line length fro BDOS 10 +gcnum db 0 ;number of characters just read by BDOS 10 +gcline ds maxl+1 ;buffer for characters, in case BDOS 10 is used + ENDFUNC + + FUNCTION kbhit + lda ungetl ;any character ungotten? + mvi h,0 + mov l,a + ora a + rnz ;if so, return true + + lda nleft ;get number of chars left in buffer + ora a + rnz ;if any characters in buffer, return true + + push b + mvi c,cstat ;else interrogate console status + call bdos + pop b + + ora a ;0 returned by BDOS if no character ready + lxi h,0 + rz ;return 0 in HL if no character ready + inr l ;otherwise return 1 in HL + ret + ENDFUNC + + FUNCTION ungetch + lda ungetl + mov l,a + push h + call ma2toh + sta ungetl + pop h + mvi h,0 + ret + ENDFUNC ungetch + + FUNCTION putchar + call ma1toh ;get character in A + push b + mvi c,conout + cpi newlin ;newline? + jnz put1 ;if not, just go put out the character + mvi e,cr ;else...put out CR-LF + call bdos + mvi c,conout + mvi a,lf + +put1: mov e,a + call bdos + +put2: lda iobrf ;checking for BREAK characters on keyboard? + ora a + jz put4 ;if not, all done + + mvi c,cstat ;now, is input present at the console? + call bdos + ora a + jnz put3 + pop b ;no...all done. + ret + +put3: mvi c,conin ;yes. sample it (this will always echo the + call bdos ; character to the screen, alas) + cpi cntrlc ;is it control-C? + jz exit ;if so, abort and reboot +put4: pop b ;else ignore it. + ret + ENDFUNC + + FUNCTION gets + call ma1toh ;get destination address + push b ;save BC + push h + push h + lxi h,-150 ;use space below stack for reading line + dad sp + push h ;save buffer address + mvi m,88h ;Allow a max of about 135 characters + mvi c,getlin + xchg ;put buffer addr in DE + call bdos ;get the input line + mvi c,conout + mvi e,lf ;put out a LF + call bdos + pop h ;get back buffer address + inx h ;point to returned char count + mov b,m ;set B equal to char count + inx h ;HL points to first char of line + pop d ;DE points to start destination area +copyl: mov a,b ;copy line to start of buffer + ora a + jz gets2 + mov a,m + stax d + inx h + inx d + dcr b + jmp copyl + +gets2: xra a ;store terminating null + stax d + pop h ;return buffer address in HL + pop b + ret + ENDFUNC + +; +; Getline(str,lim) +; char *str; +; +; Gets a line of text from the console, up to 'lim' characters. +; + + FUNCTION getline + push b ;save BC + call ma3toh ;get max no. of chars + mov c,a ;save max length in C + dcr c ;allow room for final terminating null + lxi d,10 ;allow a bit extra stack for good measure + dad d + call cmh ;save amount of space to allocate on stack + push h + call ma3toh ;get destination address + xthl ;push dest addr, get back stack offset + dad sp ;allocate space on stack + push h ;save buffer address + mov m,c ;Set max # of characters + mvi c,getlin + xchg ;put buffer addr in DE + call bdos ;get the input line + mvi c,conout + mvi e,lf ;put out a LF + call bdos + pop h ;get back buffer address + inx h ;point to returned char count + mov b,m ;set B equal to char count + inx h ;HL points to first char of line + pop d ;DE points to start destination area + mov c,b ;save char count in C +copyl: mov a,b ;copy line to start of buffer + ora a + jz gets2 + mov a,m + stax d + inx h + inx d + dcr b + jmp copyl + +gets2: xra a ;store terminating null + stax d + mov l,c ;return char count in HL + mvi h,0 + pop b + ret + ENDFUNC + + FUNCTION rand + lhld rseed + xchg + mvi a,48h + ana e + jz rand1 + jpe rand1 + stc +rand1: lhld rseed+2 + mov a,h + ral + mov h,a + mov a,l + ral + mov l,a + shld rseed+2 + mov a,d + ral + mov h,a + mov a,e + ral + mov l,a + shld rseed + mov a,h + ani 7fh + mov h,a + ret + ENDFUNC + + FUNCTION srand + call ma1toh + mov a,h + ora l + jz srand2 + shld rseed + shld rseed+2 + ret + +srand2: lxi d,stg1 + push b + mvi c,9 + call bdos + lxi h,0bdbdh +srand3: push h + mvi c,11 + call bdos + pop h + inx h + inx h + inx h + ani 1 + jz srand3 + shld rseed + shld rseed+2 + mvi c,conout + mvi e,cr + call bdos + mvi c,conout + mvi e,lf + call bdos + mvi c,conin ;clear the character + call bdos + pop b + ret +stg1: db 'Wait a few seconds, and type a CR: $' + ENDFUNC + + + FUNCTION srand1 + EXTERNAL puts + call ma1toh + push h + call puts ;print prompt string + pop h + push b + lxi h,5678h +sr1a: push h + mvi c,cstat + call bdos + pop h + inx h + inx h + inx h + ora a + jz sr1a + shld rseed + shld rseed+2 + pop b + ret + ENDFUNC + + FUNCTION nrand + EXTERNAL puts + call arghak + lhld arg1 ;get n (1st arg) + mov a,h + ana l + cpi 255 ;was it -1 (set seed) ? + jnz nrand1 + lhld arg2 ;copy seed + shld seed + lhld arg3 + shld seed+2 + lhld arg4 + shld seed+4 + ret ;all done + +nrand1: push b + mov a,h ;look at first arg again + ora l + jnz nrand3 ;is it 0 (randomize)? + lhld arg2 + push h ;yes. print out string + call puts ;call puts + pop d + lxi h,5a97h ;yes. start w/something odd +nrand2: push h + mvi c,cstat ;interrogate console status + call bdos + pop h + inx h ;and keep it odd + inx h ;and growing + ora a + jz nrand2 ;until user types something. + shld seed ;then plaster the value all over the + shld seed+2 ;seed. + shld seed+4 + pop b + ret + +nrand3: lda seed ;now compute next random number. from this + ori 1 ; point on, the code is that of Prof. Paul Gans + sta seed ;lsb of SEED must be 1 + + mvi b,6 ;clear 6 PROD bytes to 0 + lxi h,prod +randm1: mvi m,0 + inx h + dcr b + jnz randm1 + + lxi b,6 ;set byte counter +randm2: lxi h,plier-1 + dad b ;make addr of lsb of PLIER + mov a,m ;PLIER byte + push b ;save byte counter + mvi b,8 ;set bit counter + +randm3: mov d,a ;save PLIER byte + lxi h,prod ;shift whole PROD left one bit + mvi c,6 + xra a +randm4: mov a,m ;get byte + ral ;shift left + mov m,a ;put byte + inx h + dcr c + jnz randm4 + + mov a,d ;recover PLIER byte + ral ;look at current high bit + jnc randm6 ;0 means no add cycle + + push psw ;add SEED to PROD + xra a + mvi c,6 + lxi h,prod + lxi d,seed +randm5: ldax d + adc m + mov m,a + inx h + inx d + dcr c + jnz randm5 + pop psw + +randm6: dcr b ;test bit counter + jnz randm3 ;go cycle more bits + pop b ;recover byte counter + dcr c ;test it + jnz randm2 ;go process more bytes + + mvi b,6 ;complement PROD, add 1 to it, + lxi h,seed ;and transfer it to SEED. + lxi d,prod + xra a + cmc +randm7: ldax d + cma + aci 0 + mov m,a + inx h + inx d + dcr b + jnz randm7 + + dcx h ;put the two high order bytes + mov a,m ;into HL for return to C, not + ani 7fh ;neglecting to zero the high + mov h,a ;order bit so a positive int + lda seed+4 ;is returned + mov l,a + pop b + ret + +plier: db 0c5h,87h,1 + db 0eh,9ah,0e0h + +seed: db 1,0,0,0,0,0 + +prod: db 0,0,0,0,0,0 + ENDFUNC + + FUNCTION csw + in 255 + mov l,a + mvi h,0 + ret + ENDFUNC + + FUNCTION setmem + call arghak + push b + lhld arg2 + xchg + lhld arg1 + lda arg3 + mov c,a + inx d +setm2: dcx d + mov a,d + ora e + jnz setm3 + pop b + ret + +setm3: mov m,c + inx h + jmp setm2 + ENDFUNC + + FUNCTION movmem + call arghak + lhld arg3 ;get block length + mov a,h + ora l + rz ;do nothing if zero length + push b + mov b,h + mov c,l ;set BC to length + lhld arg2 ;get dest addr + xchg ;put in DE + lhld arg1 ;get source addr in HL + call cmphd ;if source < dest, do tail-first + jc tailf ;else do head-first + +headf: mvi a,2 ;test for Z-80 + inr a + jpe m8080h ;Z80? + db 0edh,0b0h ;yes. do block move. + pop b + ret ;and done. + +m8080h: mov a,m + stax d + inx h + inx d + dcx b + mov a,b + ora c + jnz m8080h + pop b + ret + +tailf: dcx b ;tail first. Compute new source + dad b ;and destination addresses + xchg + dad b + xchg + inx b + mvi a,2 ;test for Z80 + inr a + jpe m8080t ;Z80? + db 0edh,0b8h ;yes. do block move. + pop b + ret + +m8080t: mov a,m + stax d + dcx h + dcx d + dcx b + mov a,b + ora c + jnz m8080t + pop b + ret + +cmphd: mov a,h + cmp d + rnz + mov a,l + cmp e + ret + ENDFUNC + + FUNCTION memcmp + call ma3toh ;get length in HL + push b ;save BC + mov b,h + mov c,l ;move length to BC + call ma3toh ;get block2 address in HL + xchg ;move to DE + call ma2toh ;get block1 address in HL +loop: mov a,b ;all done? + ora c + jnz loop1 + lxi h,1 ;if so, return TRUE, for perfect match + pop b + ret + +loop1: dcx b ;decrement count + ldax d ;get block2 byte + cmp m ;compare to block1 byte + inx d ;bump pointers + inx h + jz loop ;if so far so good, go on comparing + lxi h,0 ;else a mismatch + pop b + ret + ENDFUNC + + FUNCTION call + call arghak + push b + lhld arg5 + xchg + lhld arg4 + mov b,h + mov c,l + lda arg2 + lxi h,call2 + push h + lhld arg1 + push h + lhld arg3 + ret + +call2: pop b + ret + ENDFUNC + + FUNCTION calla + call arghak + push b + lhld arg5 ;get de value + xchg + lhld arg4 ;get bc value + mov b,h + mov c,l + lda arg2 ;get a value + lxi h,calla2 ;get return address + push h ;push it + lhld arg1 ;get address of routine + push h + lhld arg3 ;get hl value + ret ;call routine + +calla2: mov l,a ;put A value in HL + mvi h,0 ;clear high byte + pop b + ret + ENDFUNC + + FUNCTION inp + call ma1toh + sta iohack+1 ;store as arg to ram area input subroutine + call iohack ;call the subroutine to get value + mov l,a ;and put into HL + mvi h,0 + ret + ENDFUNC + + FUNCTION outp + call ma1toh ;get port number + sta iohack+4 ;store as arg to ram area output subroutine + call ma2toh ;get data byte + call iohack+3 ;output it + ret + ENDFUNC + + FUNCTION peek +peek: call ma1toh + mov l,m + mvi h,0 + ret + ENDFUNC peek + + + FUNCTION poke + call arghak + lhld arg1 + lda arg2 + mov m,a + ret + ENDFUNC + + FUNCTION sleep + call ma1toh + push b + inx h +sl1: dcx h + mov a,h + ora l + jnz sl1a + pop b + ret + +sl1a: lxi d,10000 +sl2: dcx d + mov a,d + ora e + jnz sl2 + push h + mvi c,cstat + call bdos + ora a + pop h + jz sl1 + push h + mvi c,conin + call bdos + cpi cntrlc + jz exit + pop h + jmp sl1 + ENDFUNC + + FUNCTION pause + push b +paus1: mvi c,cstat + call bdos + ora a + jz paus1 + pop b + ret + ENDFUNC + + + FUNCTION exit + jmp exit + ENDFUNC + + FUNCTION bdos + call arghak + push b + lda arg1 ;get C value + mov c,a + lhld arg2 ;get DE value + xchg ;put in DE + call bdos ;make the bdos call + pop b + ret ;and return to caller + ENDFUNC + + FUNCTION bios + call arghak + push b + lhld base+1 ;get addr of jump table + 3 + dcx h ;set to addr of first jump + dcx h + dcx h + lda arg1 ;get function number (1-85) + mov b,a ;multiply by 3 + add a + add b + mov e,a ;put in DE + mvi d,0 + dad d ;add to base of jump table + push h ;and save for later + lhld arg2 ;get value to be put in BC + mov b,h ;and put it there + mov c,l + lxi h,retadd ;where call to bios will return to + xthl ;get address of vector in HL + pchl ;and go to it... +retadd: mov l,a ;all done. now put return value in HL + mvi h,0 + pop b + ret ;and return to caller + ENDFUNC + + FUNCTION biosh + call arghak + push b + lhld base+1 ;get addr of jump table + 3 + dcx h ;set to addr of first jump + dcx h + dcx h + lda arg1 ;get function number (1-85) + mov b,a ;multiply by 3 + add a + add b + mov e,a ;put in DE + mvi d,0 + dad d ;add to base of jump table + push h ;and save for later + + lhld arg2 ;get value to be put in BC + mov b,h ;and put it there + mov c,l + + lhld arg3 ;get value to be put in DE + mov d,h ;adn put it there + mov e,l + + lxi h,retadd ;where call to bios will return to + xthl ;get address of vector in HL + pchl ;and go to it... +retadd: pop b ;all done. Leave return value in HL + ret ;and return to caller + ENDFUNC + + FUNCTION codend + lhld codend + ret + ENDFUNC + + FUNCTION externs + lhld extrns + ret + ENDFUNC + + FUNCTION endext + lhld freram + ret + ENDFUNC + + FUNCTION topofmem + lhld base+6 + lda tpa ;check for "NOBOOT" hackery + cpi 0c3h ; "jmp" at start of C.CCC (as inserted by "-n")? + dcx h ;if CCC doesn't begin with "lxi h," then top of + rnz ;memory is just below the base of the bdos + lxi d,-2100 ;else subtract CCP size (plus little more for good + dad d ;measure) and return that as top of memory. + ret + ENDFUNC + + FUNCTION exec + EXTERNAL execl + call ma1toh ;get filename + lxi d,0 ;load null parameter in DE + push d ;push null parameter + push h ;push filename + call execl ;do an execl + pop d ;clean up stack + pop d + ret + ENDFUNC + + + FUNCTION execv + EXTERNAL execl + call arghak + push b ;save BC + lhld arg2 ;get -> arg list + mvi b,0 ;clear arg count +execv1: inr b ;bump arg count + mov e,m + inx h + mov d,m + inx h + mov a,d + ora e ;last arg? + jnz execv1 ;if not, keep looking for last one + + mov a,b ;save arg count in case of error + sta savcnt + + dcx h ;HL -> next to last arg +execv2: mov d,m ;now push args on stack + dcx h + mov e,m + dcx h + dcr b + push d + jnz execv2 + +execv3: lhld arg1 ;get program name + push h ;save as first arg to execl + call execl ;go do it; shouldn't come back. + lda savcnt ;woops, we're back. Must've been an error... + inr a ;bump to take prog name into consideration + add a + mov l,a ;put size of passed parameter list + mvi h,0 ;into HL, and adjust stack + dad sp + sphl + pop b ;restore BC + lxi h,-1 ;return error value + ret + +savcnt: ds 1 ;save arg count here + ENDFUNC + + + FUNCTION rbrk + lhld freram + shld allocp + ENDFUNC + + + FUNCTION sbrk + call ma1toh ;get # of bytes needed in HL + mov a,h ;check for -1 + ana l + inr a + jnz sbrk2 ;go to sbrk2 if HL wasn't FFFF + + lhld freram ;it WAS ffff: reset sbrk to base of free ram + shld allocp + ret + +sbrk2: xchg ;put into DE + lhld allocp ;get current allocation pointer + push h ;save it + dad d ;get tentative last address of new segment + jc brkerr ;better not allow it to go over the top! + dcx h + xchg ; now last addr is in DE + lhld alocmx ;get safety factor + mov a,h ;negate + cma + mov h,a + mov a,l + cma + mov l,a + inx h + dad sp ;get HL = (SP - alocmx) + + call cmpdh ;is DE less than HL? + jnc brkerr ;if not, can't provide the needed memory. + xchg ;else OK. + inx h + shld allocp ;save start of next area to be allocated + pop h ;get pointer to this area + ret ;and return with it. + +brkerr: pop h ;clean up stack + jmp error ;and return with -1 to indicate can't allocate. + +cmpdh: mov a,d + cmp h + rc + rnz + mov a,e + cmp l + ret + ENDFUNC + + FUNCTION rsvstk + call ma1toh ;get the value to reserve + shld alocmx ;and set new safety factor + ret + ENDFUNC + +; +; Index(str,substr) +; char *str, *substr; +; +; Returns index of substr in str, or -1 if not found. +; + + FUNCTION index + call arghak + lhld arg1 + xchg ;main str ptr in DE + lhld arg2 ;substr ptr in HL + dcx d +index1: inx d + ldax d ;end of str? + ora a + jnz index2 + lxi h,-1 ;yes. not found. + ret +index2: cmp m ;quick check for dissimilarity + jnz index1 ;loop if not same right here + push d ;else do long compare + push h +index3: inx h + inx d + mov a,m ;end of substr? + ora a + jnz index4 ;if not, go on testing + pop d ;else matches + pop d ;get starting address of substr in DE + lhld arg1 ;subtract beginning of str + call cmh + dad d ;and return the result + ret + +index4: ldax d ;current char match? + cmp m + jz index3 ;if so, keep testing + pop h ;else go on to next char in str + pop d + jmp index1 + ENDFUNC + + FUNCTION setjmp + call ma1toh + mov m,c ;save BC + inx h + mov m,b + inx h + xchg + lxi h,0 + dad sp + xchg + mov m,e ;save SP + inx h + mov m,d + inx h + pop d ;save return address + push d + mov m,e + inx h + mov m,d + lxi h,0 ;and return 0 + ret + ENDFUNC + + FUNCTION longjmp + call ma1toh ;get buffer address + mov c,m ;restore BC + inx h + mov b,m + inx h + mov e,m ;restore SP...first put it in DE + inx h + mov d,m + inx h + shld tmp2 ;save pointer to return address + call ma2toh ;get return value + xchg ;put return val in DE, old SP in HL + sphl ;restore SP with old value + pop h ;pop retur address off stack + lhld tmp2 ;get back ptr to return address + mov a,m + inx h + mov h,m + mov l,a ;HL holds return address + xchg ;put ret addr in DE, get return value in HL + push d ;push return address on stack + ret ;and return... + ENDFUNC + + end + \ No newline at end of file diff --git a/disks/images/c/DEFF2B.CSM b/disks/images/c/DEFF2B.CSM new file mode 100644 index 0000000..bfbec10 --- /dev/null +++ b/disks/images/c/DEFF2B.CSM @@ -0,0 +1,1107 @@ +; +; BD Software C Compiler v1.6 +; Standard Library Machine Language Functions (part C) +; Copyright (c) 1982, 1986 by BD Software, Inc. +; +; This file is in "CSM" format; to convert to CRL format, +; use CASM.SUB in conjunction with CASM.COM, ASM.COM and CLOAD.COM +; +; Functions appearing in this file: +; +; setfcb open close creat unlink rename fabort +; fcbaddr read write seek tell hseek htell +; cfsize oflow errno errmsg execl +; + + + INCLUDE "bds.lib" + +; +; Setfcb: +; setfcb(fcbaddr, filename) +; char *filename; +; +; Parse a given filename onto a given FCB area. This function does NOT +; recognize user number prefixes on filenames; that is a feature limited +; to internal subroutines within the C low-level-file-I/O library and not +; generally available to users. +; + + FUNCTION setfcb + call arghak + push b + lhld arg2 ;get pointer to name text +igsp: mov a,m + inx h + cpi ' ' + jz igsp + cpi tab + jz igsp + dcx h + xchg ;set DE pointing to 1st non-space char + lhld arg1 ;get --> fcb area + call setfcb ; do it + lxi h,0 ;all OK. + pop b + ret + ENDFUNC + + +; +; Open: +; int open(filename,mode) +; char *filename; +; +; Open a file for read (mode == 0), write (mode == 1) or both (mode = 2), +; and detect a user-number prefix. Returns a file descriptor. +; + + FUNCTION open + call arghak + xra a + call fgfcb ;any fcb's free? + jnc open2 ;if not, error + mvi a,10 ;"no more file slots" + jmp error + +open2: sta tmp + xchg + lhld arg1 + xchg + push b + call setfcu ;parse name and set usenum + lda usrnum + call setusr ;set new user number + + mvi c,openc + call bdos + cpi errorv ;successful open? + pop b + + mvi a,11 ; set error code in case of error + jz oerror ;if error, go abort + + lda tmp + call fgfd ;get HL pointing to fd table entry + lda arg2 + ora a ;open for read? + mvi d,3 + jz open4 + dcr a + mvi d,5 + jz open4 ;write? + dcr a + mvi a,12 ;"bad mode" for open operation... + jnz oerror ;...if not mode 2 + mvi d,7 ;else must be mode 2. +open4: lda usrnum ;get user number for the file + add d ;add r/w bit codes + mov m,a ;and store in fd table + inx h ;clear max sector number field of fd entry + xra a + mov m,a + inx h + mov m,a + lda tmp ;get back fd + mov l,a + mvi h,0 + call rstusr ;reset user number + ret + +oerror: call rstusr ;reset user number + sta errnum ;store error code number + jmp error ;and return general error condition + ENDFUNC + + +; +; Close: +; close(fd); +; +; Close a file opened via "open" or "creat": +; + + FUNCTION close + jmp close ;jump to the close routine in C.CCC + ENDFUNC + + +; +; Creat: +; int creat(filename) +; char *filename; +; Creates the named file, first deleting any old versions, and opens it +; for both read and write. Returns a file descriptor. +; + + FUNCTION creat + EXTERNAL unlink,open + + call arghak + lhld arg1 + push b + + push h + call unlink ;erase any old versions of file + pop d + + lda usrnum ;set to appropriate user area computed by "unlink" + call setusr + mvi c,creatc ;create the file + lxi d,fcb ;assume fcb has been set by "unlink" + call bdos + call rstusr ;restore previous user number + cpi errorv + pop b + jnz creat0 ;if no error, go open + mvi a,13 ;"can't create file" error code + sta errnum + jmp error + +creat0: lxi h,2 ;now open for read/write + push h + lhld arg1 + push h + call open + pop d + pop d + ret + ENDFUNC creat + + +; +; Unlink: +; unlink(filename) +; char *filename; +; +; Deletes the named file. User number prefixes are recognized: +; + + FUNCTION unlink + call ma1toh + push b + xchg + lxi h,fcb + call setfcu ;parse for fcb and compute user number + lda usrnum + call setusr ;set to correct user number + mvi c,delc ;delete + call bdos + call rstusr ;restore original user number + lxi h,0 + pop b ;restore BC + cpi errorv ;was BDOS able to find the file? + rnz ;if so, all done. + mvi a,11 ;set error code for "file not found" + sta errnum + dcx h ;return -1 + ret + ENDFUNC + + +; +; Rename: +; int rename(old_name,new_name) +; char *old_name, *new_name; +; +; Renames the given file. User number prefixes are allowed, but only +; the one on the first filename (if specified) effects the operation. +; + + FUNCTION rename + call arghak + push b +renam: lhld arg1 ;get old name + xchg + lxi h,wfcb + call setfcu ;compute user number and set fcb + lda usrnum + call setusr ;set to user number of first name + lhld arg2 + xchg + lxi h,wfcb+16 + call setfcu ;parse second name, but ignore user number + lxi d,wfcb + mvi c,renc ;perform rename operation + call bdos + call rstusr ;reset user number + lxi h,0 + pop b ;restore BC + cpi errorv ;was BDOS able to find the file? + rnz ;if so, all done + mvi a,11 ;set error code for "file not found" + sta errnum + dcx h ;return -1 + ret + +wfcb: ds 53 ;space for working fcb's + ENDFUNC + + +; +; Fabort: +; fabort(fd); +; Abort all operations on file fd. Has no effect under MP/M II. +; + + FUNCTION fabort + call ma1toh + call fgfd + jnc abrt2 ;legal fd? + mvi a,7 + sta errnum ;set "bad fd" error code + jmp error + +abrt2: + IF NOT MPM2 + mvi m,0 ;clear entry in fd table + ENDIF + + lxi h,0 + ret + ENDFUNC + + +; +; Fcbaddr: +; char *fcbaddr(fd) +; Returns a pointer to the internal file control block associated +; with open file having descriptor fd. +; + + + FUNCTION fcbaddr + call ma1toh + call fgfd ;is it an open file? + jnc fcbad2 ;if so, go do it + mvi a,7 + sta errnum ;"bad fd" error code + jmp error + +fcbad2: call ma1toh + call fgfcb ;get fcb addr in HL + ret + ENDFUNC + +; +; Read: +; +; i = read(fd, buf, n); +; +; Read a number of sectors using random-record I/O. +; +; The return value is either the number of sectors successfully +; read, 0 for EOF, or -1 on error with errno() returning the error +; code (or errmsg(errno()) returning a pointer to an error message). +; +; The Random Record Field is incremented following each successful +; sector is read, just as if the normal (sequential) read function +; were being used. "seek" must be used to go back to a previous +; sector. +; + + FUNCTION read + + call arghak + lda arg1 + call fgfd + mov d,m ;save fdt entry in D + mvi a,7 ;prepare for possible "bad fd" + jc rerror + + mov a,d + ani 2 + mvi a,8 ;prepare for possible "no read permission" + jz rerror + + push b + mov a,d ;get fd table entry + call setusr ;set user area to that of the file + + lda arg1 ;get fd + call fgfcb + shld tmp2 ;save fcb address + lxi h,0 + shld tmp2a +r2: lhld arg3 ;get countdown + mov a,h + ora l ;done? +r2aa: lhld tmp2a + jnz r2a +r2done: call rstusr ;reset user number + pop b ;yes. return with success count in HL + ret + +r2a: lhld arg2 ;get transfer addr in DE + xchg + mvi c,sdma ;set DMA there + call bdos + + lhld tmp2 + xchg + mvi c,readr ;code for BDOS random read + push d ;save DE so we can fudge nr field if + call bdos ;we stop reading on extent boundary... + pop d + ora a + jz r4 ;go to r4 if no problem + + cpi 1 ;ok, we have SOME kind of hangup... + jz r2b ;check for EOF condition: + cpi 4 ; error codes 1 and 4 both indicate reading + jz r2b ; unwritten data..treat as EOF + + mov b,a ;have we successfully read anything yet? + lda tmp2a + ora a + mov b,a ;get error code back in A + jnz r2c ;if we have read something in, don't set errnum + sta errnum ;otherwise nothing read, so set error code. + +r2c: lxi h,-1 ;put ERROR value in HL + jmp r2done + +r2b: lhld tmp2a ;return count + jmp r2done + +r4: lhld arg3 ;decrement countdown + dcx h + shld arg3 + lhld arg2 ;bump DMA address + lxi d,128 + dad d + shld arg2 + lhld tmp2a ;bump success count + inx h + shld tmp2a + lhld tmp2 ;get address of fcb + lxi b,33 ;get addr of random record field + dad b + mov c,m ;bump + inx h ; value + mov b,m ; of + inx b ; random + mov m,b ; field + dcx h ; by one + mov m,c + mov a,b ;overflow past 16-bit record count? + ora c + jnz r2 ; go for next sector if no overflow + inx h ;else set 3rd byte of random sector count + inx h + mvi m,1 + mvi a,14 ;"seek past 65536th record of file" + sta errnum + jmp r2aa ;and don't read any more. + +rerror: sta errnum + jmp error + ENDFUNC + +; +; Write: +; i = write(fd, buf, n); +; +; The random sector write function. Returns either the number +; of sectors successfully written, or -1 on hard error. Any return +; value other than n (the third arg) should be considered an error, +; after which errno() can tell you the error condition and errmsg(errno()) +; can return a pointer to an appropriate error message text. +; + + FUNCTION write + + call arghak + lda arg1 + call fgfd + shld arg5 ;save pointer to fd table entry + mov d,m ;save fd table entry in D + mvi a,7 ;prepare for possible "bad fd" + jc werror + + mov a,d + ani 4 + mvi a,9 ;prepare for possible "no write permission" + jz werror + + push b + mov a,d ;set user number + call setusr + lda arg1 ;get fd + call fgfcb ;compute fcb address + shld tmp2 ;save it away + lxi h,0 ;clear success count + shld tmp2a + +writ1: lhld arg3 ;done yet? + mov a,h + ora l + jnz writ2 + + ;take care of maximum sector count for cfsize: + lhld tmp2 ;get fcb address + lxi d,33 ;point to random record field + dad d + mov e,m + inx h + mov d,m ;DE now holds random record number for next rec + push d ;save it + lhld arg5 ;get fd table pointer + inx h ;point to max value + mov e,m ;get in DE + inx h + mov d,m ;now DE is old max value, HL points to end of entry + xthl ;DE = old max, HL = current sector, STACK = tab ptr + xchg ;HL = old max, DE = current sector + call cmphd ;is old max less than current sector? + pop h ;get tab ptr in HL + jnc writ1a ;if old max not < current sector, don't update max + mov m,d ;else update max value with new sector number + dcx h + mov m,e + +writ1a: lhld tmp2a ;if so, return count +wrdone: call rstusr ;reset user number + pop b + ret + +writ2: lhld arg2 ;else get transfer address + push h ;save on stack + xchg ;put in DE + mvi c,sdma ;set DMA there + call bdos + + pop h ;get back transfer address + lxi d,128 ;bump by 128 bytes for next time + dad d + shld arg2 ;save -> to next 128 bytes + + lhld tmp2 ;get addr of fcb + xchg + mvi c,writr ;write random sector + call bdos + lhld tmp2a ;get success count in HL + ora a ;error? + jz writ3 ;if not, go do bookkeeping + + sta errnum ;else save error code + jmp wrdone + +writ3: inx h ; else bump successful sector count, + shld tmp2a + + lhld arg3 ; debump countdown, + dcx h + shld arg3 + + lhld tmp2 ; get address of fcb + lxi b,33 ; get address of random field + dad b + mov c,m ; bump 16-bit value at random + inx h ; record + mov b,m ; field + inx b ; of + mov m,b ; fcb + dcx h ; by one + mov m,c + + mov a,b ;overflow past 16-bit record count? + ora c + jnz writ1 ; go for next sector if no overflow + inx h ;else set 3rd byte of random sector count + inx h + mvi m,1 + mvi a,14 ;set "past 65536th sector" error code + sta errnum + jmp writ1a ;and don't read any more. + +werror: sta errnum + jmp error + + ENDFUNC + +; +; Seek: +; +; seek(fd, offset, origin) +; seeks to offset records if origin == 0, +; to present position + offset if origin == 1, +; or to end of file + offset if origin == 2. +; (note that in the last case, the offset must be non-positive) +; +; There are no errors returned by this function, aside from a +; possible bad fd, because all the function does is fudge the +; random-record field of an fcb...if the seek is out of bounds, +; a subsequent direct file I/O operation (such as read or write) +; will draw the error. +; + + FUNCTION seek + EXTERNAL cfsize + + call arghak + push b ;save BC + lda arg1 + call fgfcb ;figure addr of fcb + mvi a,7 ;prepare for possible "bad fd" error code + jnc seek0 + sta errnum ;set the error code + pop b ;restore BC + jmp error + +seek0: push h ;save addr of fcb + lxi d,33 ;get current position in DE + dad d + mov e,m + inx h + mov d,m + lhld arg2 ;get offset in HL + lda arg3 ;is origin == 0? + ora a + jz rseek2 ;if so, HL holds new position + dcr a ;no. is origin == 1? + jnz rseek1 + dad d ;yes. add offset to current position + jmp rseek2 ;and result is in HL + +rseek1: ;else origin must be 2... + lhld arg1 ;compute file size + push d ;save current position + push h + call cfsize + pop d ;pop argument + pop d ;pop useless current position + xchg ;place file size in DE + +; call fgfd +; mov a,m +; call setusr ;set the file's native user number +; +; pop d ;get fcb pointer back in DE +; push d +; mvi c,cfsizc ;compute end of file position +; call bdos +; call rstusr ;reset user number +; pop h ;get fcb addr in HL again +; push h +; call rseek3 ;get DE = position + + lhld arg2 ;add offset + dad d ;and HL holds new position +rseek2: xthl ;get fcb, push new position + lxi d,33 + dad d ;HL points to random field of fcb + pop d ;get new position in DE + mov m,e ;and put into fcb + inx h + mov m,d + xchg ;and return the position value + pop b ;pop saved BC off stack + ret + +;rseek3: lxi d,33 +; dad d +; mov e,m +; inx h +; mov d,m +; ret + + ENDFUNC + +; +; Tell: +; +; i = tell(fd); +; +; Return random record position of file: +; + + FUNCTION tell + + call ma1toh ;get fd in A + call fgfcb + jnc tell0 + mvi a,7 ; "bad fd" error + sta errnum + jmp error + +tell0: lxi d,33 ;go to random record field + dad d + mov a,m ;get position in HL + inx h + mov h,m + mov l,a + ret + + ENDFUNC + + +; +; Hseek: +; +; int hseek(fd, hoffset, loffset, origin) +; +; Like seek(), except offset is specified as a 24-bit value, the high-order +; 8 bits in hoffset and the low-order 16 bits in loffset. +; +; NOTE: Seeking relative to EOF (origin value of 2) should NOT be performed +; if there has been any WRITING done to the END OF THE FILE since +; the file was last opened. +; + + FUNCTION hseek + + call arghak + push b ;save BC + lda arg1 + call fgfcb ;figure addr of fcb + mvi a,7 ;prepare for possible "bad fd" error code + jnc hseek0 + sta errnum ;set the error code + pop b ;restore BC + jmp error + +hseek0: push h ;save addr of fcb + call hseek3 ; CDE = current position + lhld arg3 ; BHL = offset value + lda arg2 + mov b,a + lda arg4 ;is origin == 0? + ora a + jz hseek2 ;if so, BHL holds new position + dcr a ;no. is origin == 1? + jz hseek1a ;if so, go add offset to current position + +hseek1: lda arg1 + call fgfd ;origin == 2. + mov a,m + call setusr ;set the file's native user number + pop d ;get fcb pointer back in DE + push d + mvi c,cfsizc ;compute end of file position + call bdos + call rstusr ;reset user number + pop h ;get fcb addr in HL again + push h + call hseek3 ;get CDE = EOF record number + lhld arg3 ;BHL contains offset +hseek1a: + dad d ;add CDE to BHL + mov a,b + adc c + mov b,a ;BHL contains new position +hseek2: xthl ;get fcb, push low 16 bits of new position + lxi d,33 + dad d ;HL points to random field of fcb + pop d ;get low 16 bits of new position in DE + mov m,e ;and put into fcb + inx h + mov m,d + inx h + mov m,c ;and set high order byte + xchg ;and return the low 16 bits of new position + pop b ;pop saved BC off stack + ret + +hseek3: lxi d,33 + dad d + mov e,m + inx h + mov d,m + inx h + mov c,m + ret + ENDFUNC + +; +; Htell: +; +; i = htell(fd); +; +; Return high-order byte of 24-bit random record position of file: +; + + FUNCTION htell + + call ma1toh ;get fd in A + call fgfcb + jnc htell0 + mvi a,7 ; "bad fd" error + sta errnum + jmp error + +htell0: lxi d,35 ;go to random record field + dad d + mov l,m ;put value in L register, + mvi h,0 ;zero H register. + ret + + ENDFUNC + + +; +; cfsize: +; cfsize(fd) +; +; Compute size of file, but leave random-record field at original value. +; +; NOTE: For files greater than 8 megabytes, do NOT use cfsize. Instead, +; use hseek() to seek to end of file, then use htell() & tell() to obtain +; high byte and low word, respectively, of the maximum record number. +; + + FUNCTION cfsize + call ma1toh + call fgfcb + jnc cfsiz2 + mvi a,7 ;"bad fd" error + sta errnum + jmp error + +cfsiz2: push b ;save BC + push h ;save fcb address + call ma3toh ;set user area + call fgfd ;get pointer to fd table entry + + mov a,m + call setusr + inx h + shld tmp2 ;save pointer to max sector value + + pop d ;restore fcb address into DE + lxi h,33 ;get to random record field + dad d + push h ;save ptr to random record field for after BDOS call + + mov a,m + inx h + mov h,m + mov l,a ;HL = current setting + push h ;save current value of random record field + + mvi c,cfsizc ;compute file size + call bdos + pop b ;pop old random record value into BC + pop h ;get pointer to random record field + + mov e,m ;get end-of-file sector number into DE + inx h + mov d,m + + mov m,b ;restore original value + dcx h + mov m,c + + lhld tmp2 ;get pointer to fd table max sector value + push h ;save ptr to max value + mov a,m ;get max sector value in HL + inx h + mov h,m + mov l,a ;now old max in HL, fsize value in DE + call cmphd ;is old max < current fsize? + jnc cfsiz3 ;if not, just return old max as current max + xthl ;get back pointer to old max value + mov m,e ;update with new fsize value + inx h + mov m,d + xchg ;put end-of-file sector number in HL for return + +cfsiz3: pop d ;clean up stack + call rstusr ;reset user area + pop b + ret + ENDFUNC + +; +; Oflow: +; i = oflow(fd); +; +; Returns true if the highest-order byte (the third byte) of the +; sector count in the fcb for the given file is non-zero: +; + + FUNCTION oflow + call ma1toh + call fgfcb + jnc oflow0 + mvi a,7 ;"bad fd" error + sta errnum + jmp error ;abort if file isn't valid + +oflow0: lxi d,35 ;look at high byte of sector position + dad d + mov a,m + ora a ;is it zero? + lxi h,0 + rz ;if so, no overflow + inx h ;else overflow. + ret + ENDFUNC + + +; +; Errno: +; int errno() +; Returns last recorded file I/O error condition, set following the +; last error encountered by the "read" and "write" functions. +; + + FUNCTION errno + + lda errnum + mov l,a + mvi h,0 + ret + + ENDFUNC + +; +; Errmsg: +; errmsg(n) +; Prints out the BDS C file I/O error message having number n, as returned +; by the "errno()" function. +; + + FUNCTION errmsg + +nerrs: equ 14 ;highest legal error code + + + call ma1toh ;get the number + cpi nerrs+1 + jc errms2 + lxi h,nerrs+1 ;get the error error message +errms2: dad h ;double to get table offset + lxi d,txtab ;get base of text pointer table + dad d ;add to get appropriate pointer + mov a,m ;return pointer in HL + inx h + mov h,m + mov l,a + ret + +txtab: dw err0 + dw err1 + dw err2 + dw err3 + dw err4 + dw err5 + dw err6 + dw err7 + dw err8 + dw err9 + dw err10 + dw err11 + dw err12 + dw err13 + dw err14 + dw errerr + + +err0: db 'No errors occurred yet',0 +err1: db 'Reading unwritten data',0 +err2: db 'Disk out of data space',0 +err3: db 'Can''t close current extent',0 +err4: db 'Seek to unwritten extent',0 +err5: db 'Can''t create new extent',0 +err6: db 'Seek past end of disk',0 +err7: db 'Bad file descriptor',0 +err8: db 'File not open for read',0 +err9: db 'File not open for write',0 +err10: db 'Too many files open',0 +err11: db 'File not found',0 +err12: db 'Bad mode to "open"',0 +err13: db 'Can''t create the file',0 +err14: db 'Seek past 65535th record',0 + +errerr: db 'Errmsg: error number out of range',0 + ENDFUNC + + +; +; Execl modified 1/16/84 to work across user areas for programs > 16K long +; + + FUNCTION execl + + call arghak + push b + lhld arg1 + xchg + lxi h,-60 ;compute &nfcb for use here + dad sp + push h ; save for much later (will pop into BC) + push h ;make a few copies for local use below + push h + call setfcu ;set up COM file for execl-ing + lda usrnum + call setusr ;set destination user area + pop h ;get new fcb addr + lxi b,9 ;set extension to COM + dad b + mvi m,'C' + inx h + mvi m,'O' + inx h + mvi m,'M' + pop d ;get new fcb addr again + mvi c,openc ;open the file for reading + call bdos + cpi errorv + jnz noerrr +err: pop h + pop b + call rstusr + jmp error + +noerrr: lhld arg2 ;any first parameter? + mov a,h + ora l + jnz excl0 + lxi d,arg2 ;no...null out first default fcb slot + push d + lxi h,fcb + call setfcb + pop h + jmp excl0a ;and go null out 2nd fcb slot + +excl0: xchg ;yes.. place into first default fcb slot + lxi h,fcb + call setfcb + lhld arg3 ;any second parameter given? + mov a,h + ora l + jnz excl0a + lxi h,arg3 + +excl0a: xchg ;yes: stick it into second default fcb slot + lxi h,fcb+16 + call setfcb + lxi d,tbuff+1 ;now construct command line: + xra a ; zero tbuff+1 just in case there + stax d ; are no arg strings + lxi h,8 ;get pointer to 1st arg string in HL + dad sp ; by offsetting 4 objects from the current SP + mvi b,0 ;char count for com. line buf. +excl1: push h ;and construct command line + mov a,m ;get addr of next arg string pointer + inx h + mov h,m + mov l,a ;0000 indicates end of list. + ora h ;end of list? + jz excl3 + + mvi a,' ' ;no. install next string + dcx h +excl2: call mpuc ;convert to upper case for command line buffer + stax d + inx d + inr b + inx h + mov a,m + ora a ;end of string? + jnz excl2 + pop h ;yes. + inx h ;bump param pointer + inx h + jmp excl1 ;and go do next string + +excl3: pop h ;clean up stack + mov a,b ;check for command buffer overflow + cpi 46h + jc excl30 ;if no overflow, go load file + lxi d,errmsg + mvi c,9 ;else comlain and abort... + call bdos + jmp err + +errmsg: db 7,'EXECL: Command line overflow',cr,lf,'$' + +excl30: lxi h,tbuff ;set length of command line + mov m,b ;at location tbuff + +excl3a: lxi d,code0 ;copy loader down to end of tbuff + lxi h,tpa-55 + mvi b,55 ;length of loader +excl4: ldax d + mov m,a + inx d + inx h + dcr b + jnz excl4 + + pop b ;get fcb pointer in BC + ;reset the SP: + lhld base+6 ;get BDOS pointer in HL + lda tpa ;look at first op byte of run-time pkg + cpi 31h ;begin with "lxi sp,"? + jnz go0 ;if so, use the same value now... + lhld tpa+1 ;else get special SP value + jmp go1 + +go0: cpi 21h ;begin with "lxi h" (the NOBOOT sequence?) + jnz go1 ;if not, just use the BDOS addr as top of memory + lxi d,-2050 ;for NOBOOT, subtract 2100 from BDOS addr + dad d ;and make that the new SP +go1: sphl + + lxi h,base + push h ;set base of ram as return addr + + lda curusr ;push current user number for bootcode to reset + mov e,a + push d + + jmp tpa-55 ;(go to `code0:') + +mpuc: cpi 61h ;convert character in A to upper case + rc + cpi 7bh + rnc + sui 32 + ret + +; +; This loader code is now: 55 bytes long. +; Modified for v1.51 to reset user area only after entire load (11/83) +; + +code0: lxi d,tpa ;destination address of new program +code1: push d ;push dma addr + push b ;push fcb pointer + mvi c,sdma ;set DMA address for new sector + call bdos + pop d ;get pointer to working fcb in DE + push d ;and re-push it + mvi c,reads ;read a sector + call bdos + pop b ;restore fcb pointer into BC + pop d ;and dma address into DE + ora a ;end of file? + jz tpa-8 ;if not, get next sector (goto `code2:') + + mov d,b + mov e,c + mvi c,closec + call bdos + + pop d ;restore current user number to E + mvi c,gsuser + call bdos ;reset user number + + mvi c,sdma ;reset DMA pointer + lxi d,tbuff + call bdos + + jmp tpa ;and go invoke the program + +code2: lxi h,80h ;bump dma address + dad d + xchg + jmp tpa-52 ;and go loop (at code1) + + ENDFUNC + + + END + \ No newline at end of file diff --git a/disks/images/c/DEFF2C.CSM b/disks/images/c/DEFF2C.CSM new file mode 100644 index 0000000..479fd7d --- /dev/null +++ b/disks/images/c/DEFF2C.CSM @@ -0,0 +1,471 @@ +; +; LONG function for long integer package: +; + + INCLUDE "bds.lib" + + + FUNCTION long + +; temporary storage is allocated in the +; "args" area of the run-time environment + +u equ args ;temporary quad storage (4 bytes) +uh equ u ;high word of u +ul equ u+2 ;low word of u +mq equ u+4 ;temporary quad storage used by + ;multiplication and division routines +temp equ mq+4 ;temporary storage byte used by div'n routine + + +; long is main routine which dispatches to the various functions +; of the package according to the value of its first argument + +long: push b ;save for benefit of caller + call ma2toh ;get 1st arg (function code) into HL and A + mov d,h + mov e,l + dad h + dad d ;HL now has triple the function code + lxi d,jtab ;base of jump table + dad d + pchl ;dispatch to appropriate function + +jtab: jmp lmake ;jump table for quad functions + jmp lcomp + jmp ladd + jmp lsub + jmp lmul + jmp ldiv + jmp lmod + + +; lmake converts integer (arg3) to a long (arg2) + +lmake: call ma4toh ;get arg3 into HL + mov a,h ;look at sign first + ora a + push psw ;save it + cm cmh ;take abs value + xchg ;into (DE) + lxi b,0 ;zero out high word + pop psw + cm qneg ;complement if necessary + jmp putarg ;copy result into arg2 and return + +;all other routines copy their arguments into the quad register (BCDE) +;and the temporary quad storage location u (note that temporary storage +;must be used to keep the routines from clobbering the user's arguments) + + +;lcomp compares arg2 with arg3, returns -1, 0, 1 for <, =, >, resp + +lcomp: call ma3toh ;get pointer to arg2 + call qld + lxi h,u + call qst ;arg2 now in u + call ma4toh ;get pointer to arg3 + call qld ;arg3 now in (BCDE) + lxi h,-1 ;presume < + call qsub + call qtst + pop b ;restore bc for caller + rm + inx h + rz + inx h + ret + +; long addition + +ladd: call getargs ;get args into (BCDE) and u + call qadd ;do the addition + jmp putarg ;copy result into arg2 and return + +lsub: call getargs + call qsub + jmp putarg + +lmul: call getargs + call qmul + jmp putarg + +ldiv: call getargs + call qdiv + jmp putarg + +lmod: call getargs + call qmod + jmp putarg + +;getargs gets arg3 into u, arg4 into (BCDE) + +getargs: + call ma5toh ;get ptr to arg3 (note use ma5 cause of + ;return addr on stack) + call qld ;arg3 now in (BCDE) + lxi h,u + call qst ;now in u + call ma6toh ;get ptr to arg4 + jmp qld ;arg4 now in (BCDE) + + +; putarg copies (BCDE) into result arg (arg2) and cleans up + +putarg: call ma3toh ;get pointer to arg2 + call qst ;copy (BCDE) into it + pop b ;restore BC for caller + ret + + + +; quad subtraction u - (BCDE) -> (BCDE) + +qsub: call qneg ;complement (BCDE) and fall thru to add + +; quad addition u + (BCDE) -> (BCDE) + +qadd: push h + lxi h,u+3 ;tenSHUN + mov a,m ;hup + add e ;two + mov e,a ;three + dcx h ;four + mov a,m ;hup + adc d ;two + mov d,a ;three + dcx h ;four + mov a,m ;hup + adc c ;two + mov c,a ;three + dcx h ;four + mov a,m ;hup + adc b ;two + mov b,a ;three + pop h ;four + ret ;at ease + + +; two's complement (BCDE) + +qneg: push h + xra a + mov l,a + sbb e + mov e,a + mov a,l + sbb d + mov d,a + mov a,l + sbb c + mov c,a + mov a,l + sbb b + mov b,a + pop h + ret + + +qneghl: push b + push d + call qld + call qneg + call qst + pop d + pop b + ret + +; signed quad multiplication +; u * (BCDE) --> (BCDE) + +qmul: call csign ;take abs values and compute signs + push psw ;save result sign + call uqmul ;compute product +qmul1: pop psw + jm qneg ;complement product if needed + ret + +; csign takes abs vals of u, (BCDE), and computes product of their signs + +csign: mov a,b ;look at (BCDE) first + ora a + push psw ;save flags + cm qneg ;complement if needed + lxi h,u ;now look at u + mov a,m + ora a + jp csign1 + call qneghl + pop psw + xri 80h ;flip sign + ret +csign1: pop psw + ret + +; unsigned quad multiplication +; u * (BCDE) --> (BCDE) (expects ptr. to u in (HL) + +uqmul: lxi h,u + push h ;put pointer to u on stack + lxi h,mq + call qst ;(BCDE) -> mq + lxi b,0 ;init product to 0 + lxi d,0 +uqmul1: call qtsthl ;test if mq is 0 + jz uqmul2 ;if so, done + xra a ;clear carry + call qrarhl ;shift mq over + cc qadd ;add u to (BCDE) if lsb=1 + xthl ;get pointer to u + xra a ;clear carry + call qralhl ;double u + xthl ;get back pointer to mq + jmp uqmul1 +uqmul2: pop h ;restore stack + ret + +; signed division u / (BCDE) --> (BCDE) + +qdiv: call qtst ;first test for zero divisor + rz + call csign ;take care of signs + push psw ;save quotient sign + call uqdiv + call qld ;get quotient in (BCDE) + jmp qmul1 ;adjust sign of result + +; signed remainder u mod (BCDE) --> (BCDE) + +qmod: call qtst ;test for zero modulus + rz + lda u ;sign of u is that of result + ora a + push psw ;save flags + call csign ;get abs val of args + call uqdiv ;remainder in (BCDE) + jmp qmul1 + + +; unsigned division u / (BCDE) --> mq, remainder in (BCDE) + + + +uqdiv: lxi h,mq ;mq will contain quotient + call qclrhl ;clear it + push h ;save it on the stack + + mvi l,1 ;now normalize divisor +uqdiv1: mov a,b ;look at most signif non-sign bit + ani 40h + jnz uqdiv2 + call qral ;if not 1, shift left + inr l + jmp uqdiv1 +uqdiv2: mov a,l + sta temp ;save normalization count + lxi h,u + call qxchg ;want divid in (BCDE), divisor in u + xthl ;pointer to mq in (HL), u on stack + +;main loop + +uqdiv3: call trial ;trial subtraction of divisor + call qralhl ;shift in the carry + lda temp ;get the count + dcr a + jz uqdiv4 ;done + sta temp ;save count again + xthl ;divisor in (HL) + xra a + call qrarhl ;shift it right one + xthl ;quotient in (HL) + jmp uqdiv3 + +uqdiv4: inx sp + inx sp ;clean off top of stack + ret + + +trial: call qsub ;subtract divid from divisor + call qneg ;actually want divisor from divid + stc ;assume was positive + rp + call qadd ;else must restore dividend + xra a ;clear carry + ret + + +; +; routines to manipulate quads +; +; qld loads the quad pointed to by (HL) into (BCDE) + +qld: push h + mov b,m + inx h + mov c,m + inx h + mov d,m + inx h + mov e,m + pop h + ret + +; qst is inverse of qld + +qst: push h + mov m,b + inx h + mov m,c + inx h + mov m,d + inx h + mov m,e + pop h + ret + + + +; rotate (BCDE) right thru carry + +qrar: mov a,b + rar + mov b,a + mov a,c + rar + mov c,a + mov a,d + rar + mov d,a + mov a,e + rar + mov e,a + ret + +; same for quad pointed to by (HL) + +qrarhl: push h + mov a,m + rar + mov m,a + inx h + mov a,m + rar + mov m,a + inx h + mov a,m + rar + mov m,a + inx h + mov a,m + rar + mov m,a + pop h + ret + + +; rotate (BCDE) left thru carry + +qral: mov a,e + ral + mov e,a + mov a,d + ral + mov d,a + mov a,c + ral + mov c,a + mov a,b + ral + mov b,a + ret + +; qralhl does it for quad pointed to by (HL) + +qralhl: inx h + inx h + inx h ;get to rightmost byte + mov a,m + ral + mov m,a + dcx h + mov a,m + ral + mov m,a + dcx h + mov a,m + ral + mov m,a + dcx h + mov a,m + ral + mov m,a + ret + + +;qclrhl clears quad pointed to by (HL) + +qclrhl: push h + xra a + mov m,a + inx h + mov m,a + inx h + mov m,a + inx h + mov m,a + pop h + ret + + +; qtst tests sign of (BCDE), setting the usual flags + +qtst: mov a,b ;look at most signif byte + ora a + rnz + ora c ;test for zero + ora d + ora e +qtst1: rp + mvi a,1 + ora a + ret + +qtsthl: mov a,m + ora a + rnz + push h + inx h + ora m + inx h + ora m + inx h + ora m + pop h + jmp qtst1 + +; swap (BCDE) with thing pointed to by HL + +qxchg: push h + mov a,m + mov m,b + mov b,a + inx h + mov a,m + mov m,c + mov c,a + inx h + mov a,m + mov m,d + mov d,a + inx h + mov a,m + mov m,e + mov e,a + pop h + ret + + ENDFUNCTION + + end + \ No newline at end of file diff --git a/disks/images/c/EXAMPLES.LBR b/disks/images/c/EXAMPLES.LBR new file mode 100644 index 0000000..a6dda06 Binary files /dev/null and b/disks/images/c/EXAMPLES.LBR differ diff --git a/disks/images/c/FILES.DOC b/disks/images/c/FILES.DOC new file mode 100644 index 0000000..e7bdf85 --- /dev/null +++ b/disks/images/c/FILES.DOC @@ -0,0 +1,131 @@ +List of all files in the v1.6 pre-release distribution package + +read.me - general intro + +cc.com - core compiler package +cc2.com +clink.com +clib.com +deff.crl +deff2.crl +c.ccc + +c.sub - submit file for trivial compilation + +stdio.h - standard header file +stdlib1.c - Source to C-coded libary functions +stdlib2.c +stdlib3.c + +bds.lib - source to assembly-language library functionsy +deff2a.csm +deff2b.csm +deff2c.csm + +casm.c - assembly language preprocessorp +casm.sub +cload.c + +ccc.asm - run-time package source + +cconfig.h - new configuration program. Run with CC.COM and CLINK.COM +cconfig.c present in the current directory to configure CC and CLINK. +cconfig2.c + +l2.c - Alternate linker +chario.c + +dio.h - Directed I/O package +dio.c + +wildexp.c - Wild-card expansion package + +hardware.h - Hardware-dependent port definitions (for CMODEM package) +cmodem.h - MODEM7-compatible telecommunications package +cmodem.c +cmodem2.c + +noboot.c - More miscellaneous utilities +tail.c +ucase.c +lpr.c +date.c +cp.c - General purpose file-copy utility. Replaces PIP.r +di.c + + ***** CDB Debugger *** + +cdbupdat.doc +cdb.h +cdb.com +cdb1.h +cdb.c +build.c +cdb2.ovl +cdb2.h +cdb2.c +atbreak.c +break.c +command.c +print.c +parse.c +util.c +null.sym +dasm.csm +dasm.crl +cdbconfg.c +target.c + + ***** RED package **** + +red-read.me +red.h +redbuf.h +red1.h +red2.c +red3.c +red4.c +red5.c +red6.c +red7.c +red8.c +red9.c +red10.c +red11.c +red12.c +red13.c +red14.c +cred.sub +lred.sub +l2red.sub +rconfig.com - RED configuration program + + *** BCD package *** + +mconfig.h +bcd1.csm +bcd2.csm +bmath.c +bcd.crl +demo1.c +lmath.c +tstinv.c + +long.c - Long Integer package C source + + *** Checksum utility *** + +crck.doc - Documentation for CRCK.COM +crck.com +crcklist.crc - Checksum list for all files in the package + + *** v1.50a compatibility package *** + +bdscio.h +deff15.crl + + *** Additional files *** + +bugs.doc - Bug fix history of this version +(cconfig.com) - Executable form of CCONFIG program (may not be included) + \ No newline at end of file diff --git a/disks/images/c/L2.C b/disks/images/c/L2.C new file mode 100644 index 0000000..61b09fa --- /dev/null +++ b/disks/images/c/L2.C @@ -0,0 +1,952 @@ + +#define TITLE "L2 Linker v3.0\n" + +/* ******** + * L2.C * Auxilliary linker for BDS C + ******** + Written 1980 by Scott W. Layson + This code is in the public domain. + + This is an improved linker for BDS C CRL format. + + Modified to v2.2.3, 11/27/1982 by David Kirkland + Version 2.2, as distributed by BDS C UG, was given the following + modifications: + - The c debugger is supported. This adds the "-NS", "-S", and + "-D" command line options. + - DEFF3.CRL is scanned, if it is present on disk + - New mechanism for default drive selection--the DEF_DRIVE macro added. + - Minor changes to messages. + - Eliminates need for SCOTT.C by change to fscanf format string + in function "loadsyms" when reading .SYM file for overlay processing. + - Ability to rescan DEFF*.CRL if reply with a carriage return to prompt + message when functions are missing. + - "-I" option, which allows interactive entry of command line + arguments. If the command line ends in a "-i", then L2 treats + the command line as Incomplete, and prompts the user for more + arguments. This is especially useful if you have a replacement + CCP which does not allow 127 character long command lines + (e.g., ZCPR). This option orginally implemented, in a different + way, by Gil Shapiro. + + Modified to v2.2.4, 03/24/1983 by David Kirkland + - "-N" option added to produce .COM files which do not perform a + warm boot after execution + As in clink, if both "-n" and "-t" are specified, "-t" is given + priority. + - "-NS" option removed/"-S" option changed. Now the default is NO + system library files (see CDB docs for explanation of system + library files); system library functions made it impossible to set + a breakpoint at the return of library functions in certain instances. + + Modified to v3.0, 6/86 by Leor Zolman + - Obtains all storage allocation by calling alloc()/free(), so as + not to conflict with buffered I/O storage allocation of BDS C v1.6. + - Added SHORTL2 #definition, to allow a real short version that can't + handle the -w options or do overlays. This avoids dragging in the + BDS C buffered I/O package. + + Compilation/linkage instructions: + cc l2.c -e5600 (use -e5300 if linking with L2.COM) + cc chario.c + + clink l2 chario + (or) l2 l2 chario + +The DEF_DRIVE macro is used to define the drive from which L2 will load C.CCC, +DEFF.CRL, DEFF2.CRL, and DEFF3.CRL (if it exists). The macro takes as an +argument the filename and extension, and "returns" the name with whatever drive +designator is needed. The macro also encloses the name in quotes; thus, the +argument when the macro is invoked must NOT be within quotes. +That is, to open C.CCC on the proper drive, we use the C code + if (ERROR==fopen(DEF_DRIVE(C.CCC), iobuf)) ..... + */ + +#include +#define DEF_DRIVE(fn) "fn" /* Make this "0/A:fn" for, say, user 0 on A */ +#define SUB_FILE "$$$.SUB" /* submit file to delete on error exit... + * if you use SDOS, use "a:$$$$.sub"; if you've + * hacked your CCP, you may need to change the + * drive designator letter */ +#define RST_NUM 6 /* C debugger RST number. Should be identical + to the RSTNUM symbol in CCC.ASM */ +#define SHORTL2 0 /* For shorter L2 (no -w options or overlay + capability), make this 1 (else 0) */ +#define OVERLAYS 1 /* If SHORTL2 is 1, this must be 0 (false) */ + /* Otherwise, 0 disables overlays, making L2 + a little shorter */ +#define NDEFF 3 /* Number of DEFF?.CRL files in std library */ + +/* These #defines from NOBOOT.C for version 1.50 */ +#define SNOBSP 0x0138 /* Location of Set NoBoot SP routine in C.CCC */ +#define NOBRET 0x013B /* Location of NoBoot RETurn routine in C.CCC */ + +#define NUL 0 +#define FLAG char +#define repeat while (1) + +#define STDOUT 1 + +/* Phase control */ +#define INMEM 1 /* while everything still fits */ +#define DISK1 2 /* overflow; finish building table */ +#define DISK2 3 /* use table to do window link */ +int phase; + + +/* function table */ +struct funct { + char fname[9]; + FLAG flinkedp; /* in memory already? */ + FLAG fdebug; /* TRUE unless this routine required + only by a lib function after -s */ + char *faddr; /* address of first ref link if not linked */ + } *ftab; +int nfuncts; /* no. of functions in table */ +int maxfuncts; /* table size */ + +#define LINKED 1 /* (flinkedp) function really here */ +#define EXTERNAL 2 /* function defined in separate symbol table */ + +char fdir [512]; /* CRL file function directory */ + +/* command line parameters etc. */ +int nprogs, nlibs; +char progfiles [30] [15]; /* program file names */ +char libfiles [20] [15]; /* library file names */ +int deflibindex; /* index of first default (DEFF*) library */ +FLAG symsp, /* write symbols to .sym file? */ + appstatsp, /* append stats to .sym file? */ + sepstatsp; /* write stats to .lnk file? */ + +char mainfunct[10]; +FLAG ovlp; /* make overlay? */ +char symsfile [15]; /* file to load symbols from (for overlays) */ + +/* C debugger variables */ +FLAG Dflag; +FLAG SysStat; /* TRUE if "-s" option given & now active */ +int SysNum; /* index into libfiles of "-s", or -1 if none */ + +FLAG Tflag; /* TRUE if "-t" option given */ +FLAG Nflag; /* TRUE if "-n" option given */ +unsigned Tval; /* arg to "-t", if present */ + +/* useful things to have defined */ +struct inst { + char opcode; + char *address; + }; + +union ptr { + unsigned u; /* an int */ + unsigned *w; /* a word ptr */ + char *b; /* a byte ptr */ + struct inst *i; /* an instruction ptr */ + }; + + +/* Link control variables */ + +union ptr codend; /* last used byte of code buffer + 1 */ +union ptr exts; /* start of externals */ +union ptr acodend; /* actual code-end address */ +unsigned extspc; /* size of externals */ +unsigned origin; /* origin of code */ +unsigned buforg; /* origin of code buffer */ +unsigned jtsaved; /* bytes of jump table saved */ + +char *lspace; /* space to link in */ +char *lspcend; /* end of link area */ +char *lodstart; /* beginning of current file */ + + +/* i/o buffer */ +struct iobuf { + int fd; + int isect; /* currently buffered sector */ + int nextc; /* index of next char in buffer */ + char buff [128]; + } ibuf, obuf; + +FILE *symbuf; + +/* seek opcodes */ +#define ABSOLUTE 0 +#define RELATIVE 1 + +#define INPUT 0 + +#define TRUE (-1) +#define FALSE 0 +#define NULL 0 + +/* 8080 instructions */ +#define LHLD 0x2A +#define LXISP 0x31 +#define LXIH 0x21 +#define SPHL 0xF9 +#define JMP 0xC3 +#define CALL 0xCD + +#define PARMSIZE 400 +char parmtext[PARMSIZE]; /* "-i" command line args go here */ +int parmindex; /* first unused character in parmtext */ + +/* strcmp7 locals, made global for speed */ +char _c1, _c2, _end1, _end2; + +/**************** End of Globals ****************/ + + +main (argc, argv) + int argc; + char **argv; +{ + char *argvv[40]; + + puts (TITLE); + inc_proc(&argc, argv, &argvv); + setup (argc, argvv); + linkprog(); + linklibs(); + if (phase == DISK1) rescan(); + else wrtcom(); +#if !SHORTL2 + if (symsp) wrtsyms(); +#endif + } + + +inc_proc(count, argv, argvv) int *count; char **argv, **argvv; { + /* process the "-i" argument by building a new argv vector + * in argvv. + */ + + int i; + + for (i=0; i<*count; i++) argvv[i] = argv[i]; + + while (!strcmp(argvv[*count-1],"-I")) + buildvec(count, argvv); +} + +buildvec (count, argvv) int *count; char **argvv; { + char line[MAXLINE], *p; + + puts("Enter continuation\n*"); + gets(line); + + for (p=line, --*count; ;) { + while (isspace(*p)) p++; + if (!*p) break; + argvv[(*count)++] = &parmtext[parmindex]; + while (*p && !isspace(parmtext[parmindex] = toupper(*p++)) ) + parmindex++; + parmtext[parmindex++] = 0; + } +} + +setup (argc, argv) /* initialize function table, etc. */ + int argc; + char **argv; +{ + unsigned i; + + symsp = appstatsp = sepstatsp = FALSE; /* default options */ + ovlp = FALSE; + nprogs = 0; + nlibs = 0; + strcpy (&mainfunct, "MAIN"); /* default top-level function */ + origin = 0x100; /* default origin */ + maxfuncts = 200; /* default function table size */ + Tflag = Nflag = FALSE; /* no "-t" or "-n" given yet */ + SysNum = -1; + SysStat = FALSE; + Dflag = FALSE; + cmdline (argc, argv); + + ftab = alloc(maxfuncts * sizeof(*ftab)); + + for (i = 40000; i > 3000; i -= 100) + { + if (!(lspace = alloc(i))) + continue; + free(lspace); + lspace = alloc(i - (NSECTS * SECSIZ + 1100)); + lspcend = alloc(0); + break; + } + if (i < 3000) + Fatal ("Sorry, not enough memory for L2\n"); + + loadccc(); + nfuncts = 0; +#if OVERLAYS + if (ovlp) loadsyms(); +#endif + intern (&mainfunct); + phase = INMEM; + buforg = origin; + jtsaved = 0; + } + +cmdline (argc, argv) /* process command line */ + int argc; + char **argv; +{ + int i, progp; + + if (argc == 1) { + puts ("Usage is:\n"); + puts (" l2 {program files} [-l {library files} ] "); + puts ("[-s {library files} ]\n"); + puts ("\t[-m ] [-f ] [-org ]"); + puts (" [-t ] [-n]\n"); + puts ("\t[-d] [-w | -wa | -ws]\n"); +#if OVERLAYS + puts ("\t[-ovl ]"); +#endif + puts ("\t[-i]"); + lexit (1); + } + progp = TRUE; + for (i=1; i < argc; ++i) { + if (argv[i][0] == '-') { + if (!strcmp (argv[i], "-F")) { + if (++i>=argc) Fatal ("-f argument missing.\n"); + sscanf (argv[i], "%d", &maxfuncts); + } + else if (!strcmp (argv[i], "-L")) progp = FALSE; + else if (!strcmp (argv[i], "-S")) { + progp = FALSE; + SysNum = nlibs; + } + else if (!strcmp (argv[i], "-M")) { + if (++i>=argc) Fatal ("-m argument missing.\n"); + strcpy (&mainfunct, argv[i]); + } + else if (!strcmp (argv[i], "-ORG")) { + if (++i>=argc) Fatal ("-org argument missing.\n"); + sscanf (argv[i], "%x", &origin); + } + else if (!strcmp (argv[i], "-N")) Nflag = TRUE; + else if (!strcmp (argv[i], "-T")) { + if (++i >= argc) + Fatal ("-t argument missing.\n"); + Tflag = TRUE; + sscanf (argv[i], "%x", &Tval); + } +#if OVERLAYS + else if (!strcmp (argv[i], "-OVL")) { + ovlp = TRUE; + if (i + 2 >= argc) + Fatal ("-ovl argument missing.\n"); + strcpy (&symsfile, argv[++i]); + sscanf (argv[++i], "%x", &origin); + } +#endif + else if (!strcmp (argv[i], "-D")) + Dflag = TRUE; +#if !SHORTL2 + else if (!strcmp (argv[i], "-W")) + symsp = TRUE; + else if (!strcmp (argv[i], "-WA")) + symsp = appstatsp = TRUE; + else if (!strcmp (argv[i], "-WS")) + symsp = sepstatsp = TRUE; +#endif + else if (!strcmp (argv[i], "-I")) + printf("-I ignored, must be last on line\n"); + else printf ("Unknown option: '%s'\n", argv[i]); + } + else { + if (progp) strcpy (&progfiles[nprogs++], argv[i]); + else strcpy (&libfiles[nlibs++], argv[i]); + } + } + if (ovlp) + strcpy(&mainfunct, &progfiles[0][2*(progfiles[0][1]==':')] ); + if (Dflag || SysNum!=-1) + Dflag = symsp = TRUE; + + deflibindex = nlibs; + strcpy(&libfiles[nlibs++], DEF_DRIVE(DEFF) ); + strcpy(&libfiles[nlibs++], DEF_DRIVE(DEFF2) ); + strcpy(&libfiles[nlibs++], DEF_DRIVE(DEFF3) ); + } + + +loadccc() /* load C.CCC (runtime library) */ +{ + union ptr temp; + unsigned len; + + codend.b = lspace; + if (!ovlp) { + if (copen (&ibuf, DEF_DRIVE(C.CCC) ) < 0) + Fatal ("Can't open %s\n", DEF_DRIVE(C.CCC) ); + if (cread (&ibuf, lspace, 128) < 128) /* read a sector */ + Fatal ("C.CCC: read error!\n"); + temp.b = lspace + 0x17; + len = *temp.w; /* how long is it? */ + cread (&ibuf, lspace + 128, len - 128); /* read rest */ + codend.b += len; + cclose (&ibuf); + } + else codend.i++->opcode = JMP; + } + + +linkprog() /* link in all program files */ +{ + int i; + union ptr dirtmp; + struct funct *fnct; + + for (i=0; iflinkedp) + linkmod (fnct, lodstart + *dirtmp.w - 0x205); + else if (phase != DISK2) { + puts ("Duplicate program function '"); + puts (&fnct->fname); + puts ("', not linked.\n"); + } + dirtmp.w++; + } /* intern & link it */ + cclose (&ibuf); + } + } + + +linklibs() /* link in library files */ +{ + int ifile; + + for (ifile=0; ifile= lspcend) { + if (phase == INMEM) { + puts("\n** Out of memory--switching to disk mode **\n"); + phase = DISK1; + } + if (phase == DISK2) { + if (cwrite (&obuf, lspace, codend.b - lspace) == -1) + Fatal ("Disk write error!\n"); + } + buforg += codend.b - lspace; + codend.b = lspace; + if (codend.b + len >= lspcend) + Fatal ("Module won't fit in memory at all!\n"); + } + lodstart = codend.b; + if (cread (&ibuf, lodstart, len) < len) Fatal ("-- read error!\n"); + } + + +scanlib (ifile) + int ifile; +{ + int i; + union ptr dirtmp; + + makeext (&libfiles[ifile], "CRL"); + if (copen (&ibuf, libfiles[ifile]) < 0) { + if (ifile != deflibindex + (NDEFF-1)) + printf ("Can't open %s\n", libfiles[ifile]); + return; + } + printf ("Scanning %s\n", &libfiles[ifile]); + if (cread (&ibuf, &fdir, 512) < 512) /* read directory */ + Fatal ("-- Read error!\n"); + for (i=0; iflinkedp = LINKED; + if (phase != DISK2) { + finalloc.b = codend.b - lspace + buforg; + if (phase == INMEM) chase (fnct->faddr, finalloc.b); + fnct->faddr = finalloc.b; + } + else finalloc.b = fnct->faddr; + body.b = modstart.b + strlen(modstart.b) + 3; /* loc. of fn body */ + jump.i = body.i + (*modstart.b ? 1 : 0); + for (temp.b = modstart.b; *temp.b; skip7(&temp)) { + jump.i->address = intern (temp.b); + ++jump.i; + } + ++temp.b; + flen = *temp.w; + code.b = jump.b; + temp.b = body.b + flen; /* loc. of reloc parameters */ + nrelocs = *temp.w++; + jtsiz = code.b - body.b; + if (Dflag && fnct->fdebug) { + if (phase!=DISK1) { + codend.i->opcode = (0307 + (8*RST_NUM)); + codend.i->address = 0; + finalloc.b += 3; + } + codend.b += 3; + } + offset = code.b - codend.b; + if (phase != DISK1) + while (nrelocs--) relocate (*temp.w++, body.b, jtsiz, + finalloc.b, offset, flen); + flen -= jtsiz; + if (phase != DISK2) jtsaved += jtsiz; + if (phase != DISK1) movmem (code.b, codend.b, flen); + codend.b += flen; + } + + +relocate (param, body, jtsiz, base, offset, flen) /* do a relocation!! */ + unsigned param, jtsiz, base, offset, flen; + union ptr body; +{ + union ptr instr, /* instruction involved */ + ref; /* jump table link */ + struct funct *fnct; + +/* if (param == 1) return; /* don't reloc jt skip */*/ + instr.b = body.b + param - 1; + if (instr.i->address >= jtsiz) + instr.i->address += base - jtsiz; /* vanilla case */ + else { + ref.b = instr.i->address + body.u; + if (instr.i->opcode == LHLD) { + instr.i->opcode = LXIH; + --ref.b; + } + fnct = ref.i->address; + instr.i->address = fnct->faddr; /* link in */ + if (!fnct->flinkedp && phase == INMEM) + fnct->faddr = instr.b + 1 - offset; /* new list head */ + } + } + + +intern (name) /* intern a function name in the table */ + char *name; +{ + struct funct *fptr; + + if (*name == 0x9D) name = "MAIN"; /* Why, Leor, WHY??? */ + for (fptr = &ftab[nfuncts-1]; fptr >= ftab; --fptr) + if (!strcmp7 (name, fptr->fname)) break; + if (fptr < ftab) { + if (nfuncts >= maxfuncts) + Fatal("Too many functions (limit is %d)!\n", maxfuncts); + fptr = &ftab[nfuncts]; + strcpy7 (fptr->fname, name); + str7tont (fptr->fname); + fptr->flinkedp = FALSE; + fptr->faddr = NULL; + fptr->fdebug = !SysStat; + ++nfuncts; + } + return (fptr); + } + + +dirsearch (name) /* search directory for a function */ + char *name; +{ + union ptr temp; + + for (temp.b = &fdir; *temp.b != 0x80; nextd (&temp)) + if (!strcmp7 (name, temp.b)) return (temp.b); + return (NULL); + } + + +nextd (ptrp) /* move this pointer to the next dir entry */ + union ptr *ptrp; +{ + skip7 (ptrp); + ++(*ptrp).w; + } + + +chase (head, loc) /* chase chain of refs to function */ + union ptr head; + unsigned loc; +{ + union ptr temp; + + while (head.w) { + temp.w = *head.w; + *head.w = loc; + head.u = temp.u; + } + } + + +wrtcom() /* write out com file (from in-mem link) */ +{ + hackccc(); + if (!ovlp) makeext (&progfiles[0], "COM"); + else makeext (&progfiles[0], "OVL"); + if (!ccreat (&obuf, &progfiles[0]) < 0 + || cwrite (&obuf, lspace, codend.b - lspace) == -1 + || cflush (&obuf) < 0) + Fatal ("Disk write error!\n"); + cclose (&obuf); + stats (STDOUT); + } + + +hackccc() /* store various goodies in C.CCC code */ +{ + union ptr temp; + struct funct *fptr; + + temp.b = lspace; + fptr = intern (&mainfunct); + if (!ovlp) { + if (Tflag) { + temp.i->opcode = LXISP; + temp.i->address = Tval; + } + else if (Nflag) { + temp.i->opcode = JMP; + temp.i->address = SNOBSP; + temp.b = lspace + 0x09; + temp.i->opcode = JMP; + temp.i->address = NOBRET; + } + else { + temp.i->opcode = LHLD; + temp.i->address = origin - 0x100 + 6; + (++temp.i)->opcode = SPHL; + } + + temp.b = lspace + 0xF; /* main function address */ + temp.i->address = fptr->faddr; + temp.b = lspace + 0x15; + *temp.w++ = exts.u; + ++temp.w; + *temp.w++ = acodend.u; + *temp.w++ = exts.u + extspc; + } + else temp.i->address = fptr->faddr; /* that's a JMP */ + } + + +#if !SHORTL2 +wrtsyms() /* write out symbol table */ +{ + int i, fd, compar(); + + qsort (ftab, nfuncts, sizeof(*ftab), &compar); + makeext (&progfiles[0], "SYM"); + if ((symbuf = fopen (&progfiles[0], "w")) < 0) + Fatal ("Can't create .SYM file\n"); + for (i=0; i < nfuncts; ++i) { + puthex (ftab[i].faddr, symbuf); + putc (' ', symbuf); + fputs (&ftab[i].fname, symbuf); + if (i % 4 == 3) fputs ("\n", symbuf); + else { + if (strlen (&ftab[i].fname) < 3) putc ('\t', symbuf); + putc ('\t', symbuf); + } + } + if (i % 4) fputs ("\n", symbuf); + if (appstatsp) stats (symbuf); + putc (CPMEOF, symbuf); + fclose (symbuf); + if (sepstatsp) { + makeext (&progfiles[0], "LNK"); + if ((symbuf = fopen (&progfiles[0], "w")) < 0) + Fatal ("Can't create .LNK file\n"); + stats (symbuf); + putc (CPMEOF, symbuf); + fclose (symbuf); + } + } +#endif + +compar (f1, f2) /* compare two symbol table entries by name */ + struct funct *f1, *f2; +{ +/* return (strcmp (&f1->fname, &f2->fname)); alphabetical order */ + return (f1->faddr > f2->faddr); /* memory order */ + } + + +#if OVERLAYS +loadsyms() /* load base symbol table (for overlay) */ +{ /* symbol table must be empty! */ + int nread; + FLAG done; + char *c; + + makeext (&symsfile, "SYM"); + if (fopen (&symsfile, &symbuf) < 0) + Fatal ("Can't open %s.\n", &symsfile); + done = FALSE; + while (!done) { + nread = + fscanf (&symbuf, "%x %s\t%x %s\t%x %s\t%x %s\n", + &(ftab[nfuncts].faddr), &(ftab[nfuncts].fname), + &(ftab[nfuncts+1].faddr), &(ftab[nfuncts+1].fname), + &(ftab[nfuncts+2].faddr), &(ftab[nfuncts+2].fname), + &(ftab[nfuncts+3].faddr), &(ftab[nfuncts+3].fname)); + nread /= 2; + if (nread < 4) done = TRUE; + while (nread-- > 0) ftab[nfuncts++].flinkedp = EXTERNAL; + } + fclose (&symbuf); + } +#endif + +stats (chan) /* print statistics on chan */ + int chan; +{ + unsigned temp, *tptr; + + tptr = 6; + fprintf (chan, "\n\nLink statistics:\n"); + fprintf (chan, " Number of functions: %d\n", nfuncts); + fprintf (chan, " Code ends at: 0x%x\n", acodend.u); + fprintf (chan, " Externals begin at: 0x%x\n", exts.u); + fprintf (chan, " Externals end at: 0x%x\n", exts.u + extspc); + fprintf (chan, " End of current TPA: 0x%x\n", *tptr); + fprintf (chan, " Jump table bytes saved: 0x%x\n", jtsaved); + temp = lspcend; + if (phase == INMEM) + fprintf (chan, + " Link space remaining: %dK\n", (temp - codend.u) / 1024); + } + + +makeext (fname, ext) /* force a file extension to ext */ + char *fname, *ext; +{ + while (*fname && (*fname != '.')) { + *fname = toupper (*fname); /* upcase as well */ + ++fname; + } + *fname++ = '.'; + strcpy (fname, ext); + } + + +strcmp7 (s1, s2) char *s1, *s2; { + + /* compare two strings, either bit-7-terminated or null-terminated */ + + for (; (_c1 = *s1) == *s2; s1++, s2++) + if ( (0x80 & _c1) || !_c1) return 0; + + if ((_c1 &= 0x7F) < (_c2 = 0x7F & *s2)) return -1; + if (_c1 > _c2) return 1; + + _end1 = (*s1 & 0x80) || !*(s1+1); + _end2 = (*s2 & 0x80) || !*(s2+1); + if (_end2 && !_end1) return 1; + if (_end1 && !_end2) return -1; + /* if (_end1 && _end2) */ return 0; +} + +strcpy7 (s1, s2) /* copy s2 into s1 */ + char *s1, *s2; +{ + do { + *s1 = *s2; + if (!*(s2+1)) { /* works even if */ + *s1 |= 0x80; /* s2 is null-term */ + break; + } + ++s1; + } while (!(*s2++ & 0x80)); + } + + +skip7 (ptr7) /* move this pointer past a string */ + char **ptr7; +{ + while (!(*(*ptr7)++ & 0x80)); + } + + +str7tont (s) /* add null at end */ + char *s; +{ + while (!(*s & 0x80)) { + if (!*s) return; /* already nul term! */ + s++; + } + *s = *s & 0x7F; + *++s = NUL; + } + + +puthex (n, obuf) /* output a hex word, with leading 0s */ + unsigned n; + char *obuf; +{ + int i, nyb; + + for (i = 3; i >= 0; --i) { + nyb = (n >> (i * 4)) & 0xF; + nyb += (nyb > 9) ? 'A' - 10 : '0'; + putc (nyb, obuf); + } + } + + +Fatal (arg1, arg2, arg3, arg4) /* lose, lose */ + char *arg1, *arg2, *arg3, *arg4; +{ + printf (arg1, arg2, arg3, arg4); + lexit (1); + } + + +lexit (status) /* exit the program */ + int status; +{ + if (status == 1) + unlink (SUB_FILE); + exit(); /* bye! */ + } + + + +/* END OF L2.C */ + \ No newline at end of file diff --git a/disks/images/c/LBREXT.COM b/disks/images/c/LBREXT.COM new file mode 100755 index 0000000..883c7c0 Binary files /dev/null and b/disks/images/c/LBREXT.COM differ diff --git a/disks/images/c/LDIR.COM b/disks/images/c/LDIR.COM new file mode 100755 index 0000000..763f2a8 Binary files /dev/null and b/disks/images/c/LDIR.COM differ diff --git a/disks/images/c/SOURCES.LBR b/disks/images/c/SOURCES.LBR new file mode 100644 index 0000000..ded72e7 Binary files /dev/null and b/disks/images/c/SOURCES.LBR differ diff --git a/disks/images/c/STDIO.H b/disks/images/c/STDIO.H new file mode 100644 index 0000000..d640947 --- /dev/null +++ b/disks/images/c/STDIO.H @@ -0,0 +1,54 @@ +/* stdio.h for BDS C v1.6 2/85 */ + +#define BDSC + +#define NULL 0 /* null pointer */ +#define EOF -1 /* Physical EOF returned by low level I/O functions */ +#define ERROR -1 /* General "on error" return value */ +#define OK 0 /* General purpose "no error" return value */ +#define JBUFSIZE 6 /* Length of setjump/longjump buffer */ +#define CPMEOF 0x1a /* CP/M End-of-text-file marker (sometimes!) */ +#define SECSIZ 128 /* Sector size for CP/M read/write calls */ +#define TRUE 1 /* logical true constant */ +#define FALSE 0 /* logical false constant */ +#define MAXLINE 150 /* For compatibility */ +#define VOID /* for functions that don't return anything */ + +#define NSECTS 8 /* Number of sectors to buffer up in ram */ + +struct _buf { + int _fd; + int _nleft; + char *_nextp; + char _buff[NSECTS * SECSIZ]; + char _flags; +}; + +#define FILE struct _buf /* Poor man's "typedef" */ + +#define _READ 1 /* only one of these two may be active at a time */ +#define _WRITE 2 + +#define _EOF 4 /* EOF has occurred on input */ +#define _TEXT 8 /* convert ^Z to EOF on input, write ^Z on output */ +#define _ERR 16 /* error occurred writing data out to a file */ + +#define stdin 0 +#define stdout 1 +#define stdlst 2 +#define stdrdr 3 +#define stdpun 3 +#define stderr 4 + +#define getc fgetc +#define putc fputc + +struct _header { /* Alloc/Free object structure */ + struct _header *_ptr; + unsigned _size; + }; + +struct _header _base; /* declare this external data to */ +struct _header *_allocp; /* be used by alloc() and free() */ + + \ No newline at end of file diff --git a/disks/images/c/STDLIB1.C b/disks/images/c/STDLIB1.C new file mode 100644 index 0000000..6883a65 --- /dev/null +++ b/disks/images/c/STDLIB1.C @@ -0,0 +1,391 @@ +/* + STDLIB1.C -- for BDS C v1.6 -- 1/86 + Copyright (c) 1982, 1986 by BD Software, Inc. + + The files STDLIB1.C, STDLIB2.C and STDLIB3.C contain the source + listings for all functions present in the DEFF.CRL library object + file. (Note: DEFF2.CRL contains the .CSM-coded portions of the + library.) + + STDLIB1.C contains the new K&R standard buffered file I/O functions: + + fopen fclose fflush + fgetc fputc getw putw ungetc + fread fwrite fgets fputs + feof ferror clearerr +*/ + +#include + + +/* + fopen(filename, mode) + + The "mode" parameter may be: + "r" or "rb" read, read binary + "w" or "wb" write, write binary + "a" or "ab" append, append binary + (If no "b" is appended, text mode assumed by default) +*/ + +char *fopen(name,mode) +char *mode, *name; +{ + int i; + FILE *fp; + + if ((fp = alloc(sizeof(*fp))) == NULL) + return NULL; + fp->_nextp = fp->_buff; + fp->_nleft = (NSECTS * SECSIZ); + fp->_flags = _WRITE; + + switch(*mode){ + case 'r': + if ((fp->_fd = open(name, 0)) == ERROR) + goto error; + fp->_nleft = 0; + fp->_flags = _READ; + break; + case 'a': + if ((fp->_fd = open(name, 2)) == ERROR) + goto create; + if (!cfsize(fp->_fd)) /* if empty file, just like 'w' */ + break; + if (seek(fp->_fd, -1, 2) == ERROR || + read(fp->_fd, fp->_buff, 1) < 1) + { + close(fp->_fd); + goto error; + } + if (mode[1] != 'b') + for (i=0; i_buff[i] == CPMEOF) + { + seek(fp->_fd, -1, 1); + fp->_nextp += i; + fp->_nleft -= i; + break; + } + break; + case 'w':; + create: if ((fp->_fd = creat(name)) == ERROR) + goto error; + break; + default: + goto error; /* illegal mode */ + } + + if (mode[1] != 'b') /* text mode by default */ + fp->_flags |= _TEXT; + return fp; + + error: + free(fp); + return NULL; +} + + +int fclose(fp) +FILE *fp; +{ + if (fp <= 4) + return OK; + if (fp->_flags & _WRITE) + { + if (fp->_flags & _TEXT) + fputc(CPMEOF, fp); + if (fflush(fp) == ERROR) + return ERROR; + } + free(fp); + return close(fp->_fd); +} + + +int fflush(fp) +FILE *fp; +{ + int i; char *p; + + if (fp <= 4) + return OK; + if (!(fp->_flags & _WRITE)) + return ERROR; + + if (fp->_nleft == (NSECTS * SECSIZ)) + return OK; + + i = NSECTS - (fp->_nleft / SECSIZ); + if (write(fp->_fd, fp->_buff, i) != i) + { + fp->_flags |= _ERR; + return ERROR; + } + i = (i-1) * SECSIZ; + if (fp->_nleft % SECSIZ) { + movmem(fp->_buff + i, fp->_buff, SECSIZ); + fp->_nleft += i; + fp->_nextp -= i; + return seek(fp->_fd, -1, 1); + } + + fp->_nleft = (NSECTS * SECSIZ); + fp->_nextp = fp->_buff; + return OK; +} + +int fgetc(fp) +FILE *fp; +{ + int nsecs; + char c; + + switch(fp) + { + case stdin: return getchar(); + case stdrdr: return bdos(3); + } + +top: if (!fp->_nleft--) /* if buffer empty, fill it up first */ + { + if ((fp->_flags & _EOF) || + (nsecs = read(fp->_fd, fp->_buff, NSECTS)) <= 0) + { + eof: fp->_nleft = 0; + fp->_flags |= _EOF; + return EOF; + } + fp->_nleft = nsecs * SECSIZ - 1; + fp->_nextp = fp->_buff; + } + c = *fp -> _nextp++; + if (fp->_flags & _TEXT) + if (c == CPMEOF) + goto eof; + else if (c == '\r') + goto top; /* Ignore CR's in text files */ + return c; +} + + +int fputc(c,fp) +char c; +FILE *fp; +{ + switch (fp) + { + case stdout: return putchar(c); /* std output */ + case stdlst: return bdos(5,c); /* list dev. */ + case stdpun: return bdos(4,c); /* to punch */ + case stderr: if (c == '\n') + bdos(2,'\r'); + return bdos(2,c); + case stdin: return ERROR; + } + + if (!(fp->_flags & _TEXT)) /* If binary mode, just write it */ + return _putc(c, fp); + + if (c == '\r') /* Else must be Text mode: */ + return c; /*Ignore CR's */ + + if (c != '\n') /* If not newline, just write it */ + return _putc(c,fp); + + if (_putc('\r',fp) == ERROR) /* Write CR-LF combination */ + return ERROR; + return _putc('\n',fp); +} + +_putc(c,fp) +FILE *fp; +{ + if (fp->_flags & _ERR) + return ERROR; + + if (!fp->_nleft--) /* if buffer full, flush it */ + { + if ((write(fp->_fd, fp->_buff, NSECTS)) != NSECTS) + { + fp->_flags |= _ERR; + return ERROR; + } + fp->_nleft = (NSECTS * SECSIZ - 1); + fp->_nextp = fp->_buff; + } + + return *fp->_nextp++ = c; +} + + +int ungetc(c, fp) +FILE *fp; +char c; +{ + if (fp == stdin) return ungetch(c); + if ((fp < 7) || fp -> _nleft == (NSECTS * SECSIZ)) + return ERROR; + *--fp -> _nextp = c; + fp -> _nleft++; + return OK; +} + +int getw(fp) +FILE *fp; +{ + int a,b; + if (((a = fgetc(fp)) >= 0) && ((b = fgetc(fp)) >=0)) + return (b << 8) + a; + return ERROR; +} + +int putw(w,fp) +unsigned w; +FILE *fp; +{ + if ((fputc(w & 0xff, fp) >=0 ) && (fputc(w / 256,fp) >= 0)) + return w; + return ERROR; +} + +int fread(buf, size, count, fp) +char *buf; +unsigned size, count; +FILE *fp; +{ + int n_read, n_togo, cnt, i; + + n_togo = size * count; + n_read = 0; + if (fp->_flags & _EOF) + return NULL; + + while (n_togo) + { + cnt = (n_togo <= fp->_nleft) ? n_togo : fp->_nleft; + movmem(fp->_nextp, buf, cnt); + fp->_nextp += cnt; + buf += cnt; + fp->_nleft -= cnt; + n_togo -= cnt; + n_read += cnt; + if (n_togo) + { + if ((cnt = read(fp->_fd, fp->_buff, NSECTS)) <=0) + { + fp->_flags |= _EOF; + goto text_test; + } + fp->_nleft = cnt * SECSIZ; + fp->_nextp = fp->_buff; + } + } + text_test: + if (fp->_flags & _TEXT) + { + i = min(n_read, SECSIZ); + while (i--) + if (*(buf-i) == CPMEOF) + { + fp->_flags |= _EOF; + return (n_read - i); + } + } + return (n_read/size); +} + +int fwrite(buf, size, count, fp) +char *buf; +unsigned size, count; +FILE *fp; +{ + int n_done, n_togo, cnt; + + n_togo = size * count; + n_done = 0; + + if (fp->_flags & _ERR) + return NULL; + + while (n_togo) + { + cnt = (n_togo <= fp->_nleft) ? n_togo : fp->_nleft; + movmem(buf, fp->_nextp, cnt); + fp->_nextp += cnt; + buf += cnt; + fp->_nleft -= cnt; + n_togo -= cnt; + n_done += cnt; + if (n_togo) + { + if ((cnt = write(fp->_fd, fp->_buff, NSECTS)) <= 0) + { + fp->_flags |= _ERR; + return ERROR; + } + fp->_nleft = (NSECTS * SECSIZ); + fp->_nextp = fp->_buff; + } + } + return (n_done/size); +} + + +/* Get a line of text from a buffered input file: */ + +char *fgets(s,n,fp) +char *s; +int n; +FILE *fp; +{ + int c; + char *cs; + + cs = s; + while (--n > 0) + { + if ((c = fgetc(fp)) == EOF) + { + *cs = '\0'; + return (cs == s) ? NULL : s; + } + if ((*cs++ = c) == '\n') break; + } + *cs = '\0'; + return s; +} + + +/* Write a line of text out to a buffered file: */ + +fputs(s,fp) +char *s; +FILE *fp; +{ + char c; + while (c = *s++) { + if (fputc(c,fp) == ERROR) + return ERROR; + } + return OK; +} + +VOID clearerr(fp) +FILE *fp; +{ + fp->_flags &= (~_ERR); +} + +int feof(fp) +FILE *fp; +{ + return fp->_flags & _EOF; +} + +int ferror(fp) +FILE *fp; +{ + return fp->_flags & _ERR; +} + \ No newline at end of file diff --git a/disks/images/c/STDLIB2.C b/disks/images/c/STDLIB2.C new file mode 100644 index 0000000..0b059fe --- /dev/null +++ b/disks/images/c/STDLIB2.C @@ -0,0 +1,419 @@ +/* + STDLIB2.C -- for BDS C v1.6 -- 1/86 + Copyright (c) 1982, 1986 by BD Software, Inc. + + The files STDLIB1.C, STDLIB2.C and STDLIB3.C contain the source + listings for all functions present in the DEFF.CRL library object + file. (Note: DEFF2.CRL contains the .CSM-coded portions of the + library.) + + STDLIB2.C contains mainly formatted text I/O functions: + + printf fprintf sprintf lprintf _spr + scanf fscanf sscanf _scn + getline puts + putdec + +*/ + +#include + +#define iseof(x) (x==CPMEOF || x==EOF || x==0) + +char toupper(), isdigit(); + +printf(format) +char *format; +{ + int putchar(); + return _spr(&format, &putchar); +} + +int fprintf(fp, format) +char *format; +FILE *fp; +{ + int _fputc(); + return _spr(&format, &_fputc, fp); +} + +sprintf(buffer, format) +char *buffer, *format; +{ + int _sspr(); + _spr(&format, &_sspr, &buffer); + *buffer = '\0'; +} + +_sspr(c,strptr) +char **strptr; +{ + *(*strptr)++ = c; +} + +int lprintf(format) +char *format; +{ + int _fputc(); + return _spr(&format, &_fputc, stdlst); +} + +int _fputc(c,fp) +FILE *fp; +{ + if (c == '\n') + if (fputc('\r', fp) == ERROR) + return ERROR; + if (fputc(c, fp) == ERROR) + return ERROR; + return OK; +} + +int scanf(format) +char *format; +{ + int getchar(),ungetch(); + return _scn(&format, getchar, ungetch); +} + +int fscanf(fp,format) +char *format; +FILE *fp; +{ + int fgetc(),ungetc(); + return _scn(&format, fgetc, ungetc, fp); +} + +int sscanf(line,format) +char *line, *format; +{ + int _sgetc(), _sungetc(); + return _scn(&format, &_sgetc, &_sungetc, &line); +} + + +/* + Internal routine used by "_spr" to perform ascii- + to-decimal conversion and update an associated pointer: +*/ + +int _gv2(sptr) +char **sptr; +{ + int n; + n = 0; + while (isdigit(**sptr)) n = 10 * n + *(*sptr)++ - '0'; + return n; +} + +char _uspr(string, n, base) +char **string; +unsigned n; +{ + char length; + if (n b-1) + return ERROR; + else + return c; +} + +_spr(fmt,putcf,arg1) +int (*putcf)(); +char **fmt; +{ + char _uspr(), c, base, *format, ljflag, prefill, *wptr; + char wbuf[20]; /* 20 is enough for all but %s */ + int length, *args, width, precision; + format = *fmt++; /* fmt first points to the format string */ + args = fmt; /* now fmt points to the first arg value */ + + while (c = *format++) + if (c == '%') { + wptr = wbuf; + precision = 32767; + width = ljflag = 0; + prefill = ' '; + + if (*format == '-') { + format++; + ljflag=1; + } + + if (*format == '0') prefill = '0'; + + if (isdigit(*format)) width = _gv2(&format); + + if (*format == '.') { + format++; + precision = _gv2(&format); + } + + if (*format == 'l') format++; /* no longs here */ + + switch(c = *format++) { + case 'd': if (*args < 0) { + *wptr++ = '-'; + *args = -*args; + width--; + } + case 'u': base = 10; goto val; + case 'b': base = 2; goto val; + case 'x': base = 16; goto val; + case 'o': base = 8; + + val: width -= _uspr(&wptr,*args++,base); + goto pad; + + case 'c': *wptr++ = *args++; + width--; + goto pad; + + pad: *wptr = '\0'; + length = strlen(wptr = wbuf); + pad7: /* don't modify the string at wptr */ + if (!ljflag) + while (width-- > 0) + if ((*putcf)(prefill,arg1) == ERROR) + return ERROR;; + while (length--) + if ((*putcf)(*wptr++,arg1) == ERROR) + return ERROR; + if (ljflag) + while (width-- > 0) + if ((*putcf)(' ',arg1) == ERROR) + return ERROR; + break; + + case 's': + wptr = *args++; + length = strlen(wptr); + if (precision < length) length=precision; + width -= length; + goto pad7; + + case NULL: + return OK; + + default: if ((*putcf)(c,arg1) == ERROR) return ERROR; + } + } + else if ((*putcf)(c,arg1) == ERROR) return ERROR; + return OK; +} + +_sgetc(sp) +char **sp; +{ + return *(*sp)++; +} + +_sungetc(ch,sp) +char **sp,ch; +{ + --*sp; +} + +union { + char byte; + int word; +}; + +int _scn(arglist,get,unget,ioarg) +int (*get)(), (*unget)(); +int **arglist; +{ + char assign, c, base, n, *sptr, *format, matchit; + char shortf; + int sign, val, width, peek; + + format = *arglist++; /* format points to the format string */ + + n = 0; + while (1) + { + if (!(c = *format++)) goto alldone; + if (isspace(c)) continue; /* skip white space in format string */ + if (c!='%') + { + if(_GetNonWh(get,ioarg,&peek)) goto eofdone; + if(c!=peek) goto undone; + } + else /* process conversion */ + { + sign = 1; shortf=FALSE; + if ('*'==*format) { + format++; + assign = FALSE;} + else assign = TRUE; + if (isdigit(*format)) width = _gv2(&format); + else width = 32767; + if ('l'==*format) format++; /* no longs */ + switch (c=*format++) { + case 'x': base = 16; goto doval; + case 'o': base = 8; goto doval; + case 'b': base = 2; goto doval; + case 'h': shortf = TRUE; /* short is char */ + case 'd': + case 'u': base = 10; + doval: + if (_GetNonWh(get,ioarg,&peek)) + goto eofdone; + width--; + if (peek=='-') { + sign = -1; + peek=(*get)(ioarg); + if (!width--) + continue; + } + if ((val=_bc(peek,base)) == ERROR) + goto undone; + while (1) { + peek = (*get)(ioarg); + if (iseof(peek) || !width--) + break; + if (peek=='x' && c=='x') + continue; + if ((c = _bc(peek,base)) == 255) + break; + val = val * base + c; + } + if (assign) { + val *= sign; + if (shortf) + (*arglist++)->byte = val; + else + (*arglist++)->word = val; + n++;} + if (iseof(peek)) + goto eofdone; + (*unget)(peek,ioarg); + continue; + + case 's': + if (_GetNonWh(get,ioarg,&peek)) goto eofdone; + matchit = ('%'==*format) ? ' ' : *format; + sptr = *arglist; + while (1) { + if (isspace(peek)) + break; + if (peek == matchit) { + format++; + break; + } + if (assign) *sptr++ = peek; + if (!--width) + break; + peek=(*get)(ioarg); + if (iseof(peek)) + break; + } + if (assign) { + n++; + *sptr = '\0'; + arglist++; + } + if (iseof(peek)) + goto eofdone; + continue; + + case 'c': peek=(*get)(ioarg); + if (iseof(peek)) + goto eofdone; + if (assign) { + (*arglist++)->byte = peek; + n++; + } + continue; + + case '%': /* allow % to be read with "%%" */ + if (_GetNonWh(get,ioarg,&peek)) + goto eofdone; + if ('%' != peek) + goto undone; + continue; + + default: goto alldone; + } + } + } + eofdone: (*unget)(CPMEOF,ioarg); + return n ? n : EOF; + undone: (*unget)(peek,ioarg); + alldone: return n; +} + +int _GetNonWh(get,ioarg,apeek) /* get next non white character */ +int (*get)(); /* return TRUE if EOF */ +int *apeek; +{ + int c; + while (isspace(c = (*get)(ioarg))) + ; + *apeek = c; + return iseof(c); +} + +getline(s,lim) +char s[]; +int lim; +{ + int c,i; + i=0; + while (--lim>0) { + c=getchar(); + if (c==EOF) break; + if (c==CPMEOF) { + ungetch(CPMEOF); /* don't pass ^Z */ + break; + } + s[i++] = c; + if (c == '\n') break; + } + s[i] = '\0'; + return i; +} + +puts(s) +char *s; +{ + while (*s) putchar(*s++); +} + +/* Print out a decimal number: */ + +putdec(n) +int n; +{ + if (n < 0) + { + putchar('-'); + putdec(-n); + return; + } + + if (n > 9) + putdec(n/10); + + putchar(n - n/10*10 + '0'); +} + \ No newline at end of file diff --git a/disks/images/c/STDLIB3.C b/disks/images/c/STDLIB3.C new file mode 100644 index 0000000..20c2786 --- /dev/null +++ b/disks/images/c/STDLIB3.C @@ -0,0 +1,320 @@ +/* + STDLIB3.C -- for BDS C v1.6 -- 1/86 + Copyright (c) 1982, 1986 by BD Software, Inc. + + The files STDLIB1.C, STDLIB2.C and STDLIB3.C contain the source + listings for all functions present in the DEFF.CRL library object + file. (Note: DEFF2.CRL contains the .CSM-coded portions of the + library.) + + STDLIB3.C contains mainly string, character, and storage allocation + functions: + + strcat strcmp strcpy strlen + isalpha isupper islower isdigit isspace toupper tolower + atoi + qsort + initw initb initptr getval + alloc free + swapin + abs max min +*/ + + +#include + +#define MAX_QSORT_WIDTH 513 /* Largest sized object "qsort" can sort */ + +/* + String functions: +*/ + +char *strcat(s1,s2) +char *s1, *s2; +{ + char *temp; temp=s1; + while(*s1) s1++; + do *s1++ = *s2; while (*s2++); + return temp; +} + + +int strcmp(s1, s2) +char *s1, *s2; +{ + while (*s1 == *s2++) + if (*s1++ == '\0') + return 0; + return (*s1 - *--s2); +} + + +char *strcpy(s1,s2) +char *s1, *s2; +{ + char *temp; temp=s1; + while (*s1++ = *s2++); + return temp; +} + + +int strlen(s) +char *s; +{ + int len; + len=0; + while (*s++) len++; + return len; +} + + +/* + Character diddling functions: +*/ + +int isalpha(c) +char c; +{ + return isupper(c) || islower(c); +} + + +int isupper(c) +char c; +{ + return c>='A' && c<='Z'; +} + + +int islower(c) +char c; +{ + return c>='a' && c<='z'; +} + + +int isdigit(c) +char c; +{ + return c>='0' && c<='9'; +} + + +int isspace(c) +char c; +{ + return c==' ' || c=='\t' || c=='\n'; +} + + +char toupper(c) +char c; +{ + return islower(c) ? c-32 : c; +} + + +char tolower(c) +char c; +{ + return isupper(c) ? c+32 : c; +} + + +int atoi(n) +char *n; +{ + int val; + char c; + int sign; + val=0; + sign=1; + while ((c = *n) == '\t' || c== ' ') ++n; + if (c== '-') {sign = -1; n++;} + while ( isdigit(c = *n++)) val = val * 10 + c - '0'; + return sign*val; +} + +/* + Generalized Sort function: +*/ + +qsort(base, nel, width, compar) +char *base; int (*compar)(); +unsigned width,nel; +{ int i, j; + unsigned gap, ngap, t1; + int jd, t2; + + t1 = nel * width; + for (ngap = nel / 2; ngap > 0; ngap /= 2) { + gap = ngap * width; + t2 = gap + width; + jd = base + gap; + for (i = t2; i <= t1; i += width) + for (j = i - t2; j >= 0; j -= gap) { + if ((*compar)(base+j, jd+j) <=0) break; + _swp(width, base+j, jd+j); + } + } +} + +_swp(w,a,b) +char *a,*b; +unsigned w; +{ + char swapbuf[MAX_QSORT_WIDTH]; + movmem(a,swapbuf,w); + movmem(b,a,w); + movmem(swapbuf,b,w); +} + + +/* + Initialization functions +*/ + + +initw(int_ptr,string) +int *int_ptr; +char *string; +{ + int n; + while ((n = getval(&string)) != -32760) + *int_ptr++ = n; +} + +initb(char_ptr, string) +char *char_ptr, *string; +{ + int n; + while ((n = getval(&string)) != -32760) *char_ptr++ = n; +} + +initptr(str_ptr, first_arg) +char **str_ptr, **first_arg; +{ + char **arg_ptr; + + for (arg_ptr = &first_arg; *arg_ptr; arg_ptr++) + *str_ptr++ = *arg_ptr; +} + + +int getval(strptr) +char **strptr; +{ + int n; + if (!**strptr) return -32760; + n = atoi(*strptr); + while (**strptr && *(*strptr)++ != ','); + return n; +} + + +/* + Storage allocation functions: +*/ + +char *alloc(nbytes) +unsigned nbytes; +{ + struct _header *p, *q, *cp; + int nunits; + nunits = 1 + (nbytes + (sizeof (_base) - 1)) / sizeof (_base); + if ((q = _allocp) == NULL) { + _base._ptr = _allocp = q = &_base; + _base._size = 0; + } + for (p = q -> _ptr; ; q = p, p = p -> _ptr) { + if (p -> _size >= nunits) { + _allocp = q; + if (p -> _size == nunits) + _allocp->_ptr = p->_ptr; + else { + q = _allocp->_ptr = p + nunits; + q->_ptr = p->_ptr; + q->_size = p->_size - nunits; + p -> _size = nunits; + } + return p + 1; + } + if (p == _allocp) { + if ((cp = sbrk(nunits * sizeof (_base))) == ERROR) + return NULL; + cp -> _size = nunits; + free(cp+1); /* remember: pointer arithmetic! */ + p = _allocp; + } + } +} + + +free(ap) +struct _header *ap; +{ + struct _header *p, *q; + + p = ap - 1; /* No need for the cast when "ap" is a struct ptr */ + + for (q = &_base; q->_ptr != &_base; q = q -> _ptr) + if (p > q && p < q -> _ptr) + break; + + if (p + p -> _size == q -> _ptr) { + p -> _size += q -> _ptr -> _size; + p -> _ptr = q -> _ptr -> _ptr; + } + else p -> _ptr = q -> _ptr; + + if (q + q -> _size == p) { + q -> _size += p -> _size; + q -> _ptr = p -> _ptr; + } + else q -> _ptr = p; + + _allocp = q; +} + + +/* Load a disk file into memory (typically an overlay segment): */ + +swapin(name,addr) +char *name; +{ + int fd; + if (( fd = open(name,0)) == ERROR) + return ERROR; + + if ((read(fd,addr,512)) < 0) { + close(fd); + return ERROR; + } + + bdos(26, 0x80); /* reset DMA address for benefit of certain systems */ + + close(fd); + return OK; +} + + +/* + Now some really hairy functions to wrap things up: +*/ + +int abs(n) +{ + return (n<0) ? -n : n; +} + +int max(a,b) +{ + return (a > b) ? a : b; +} + +int min(a,b) +{ + return (a <= b) ? a : b; +} + + \ No newline at end of file diff --git a/disks/images/c/UNCRUNCH.COM b/disks/images/c/UNCRUNCH.COM new file mode 100755 index 0000000..a95b80b Binary files /dev/null and b/disks/images/c/UNCRUNCH.COM differ diff --git a/disks/images/c/ZCASM.LBR b/disks/images/c/ZCASM.LBR new file mode 100644 index 0000000..bf9412a Binary files /dev/null and b/disks/images/c/ZCASM.LBR differ diff --git a/disks/images/d/CCOPT.COM b/disks/images/d/CCOPT.COM new file mode 100644 index 0000000..1566fe5 Binary files /dev/null and b/disks/images/d/CCOPT.COM differ diff --git a/disks/images/d/CCOPT.H b/disks/images/d/CCOPT.H new file mode 100644 index 0000000..1f9381f --- /dev/null +++ b/disks/images/d/CCOPT.H @@ -0,0 +1,1148 @@ +/* Include file for CCOPT, the MESCC optimizer */ + +#asm +rule0 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 1 + DEFB ' LD HL,@=1+2', 0 + DEFB 6 + +rule1 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 1 + DEFB ' LD HL,@=1-2', 0 + DEFB 8 + +rule2 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccmul', 0 + DEFB 1 + DEFB ' LD HL,@=1*2', 0 + DEFB 8 + +rule3 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccdiv', 0 + DEFB 1 + DEFB ' LD HL,@=1/2', 0 + DEFB 8 + +rule4 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccmod', 0 + DEFB 1 + DEFB ' LD HL,@=1%2', 0 + DEFB 8 + +rule5 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccor', 0 + DEFB 1 + DEFB ' LD HL,@=1|2', 0 + DEFB 8 + +rule6 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccand', 0 + DEFB 1 + DEFB ' LD HL,@=1&2', 0 + DEFB 8 + +rule7 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccxor', 0 + DEFB 1 + DEFB ' LD HL,@=1^2', 0 + DEFB 8 + +rule8 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccasr', 0 + DEFB 1 + DEFB ' LD HL,@=1>>2', 0 + DEFB 8 + +rule9 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccasl', 0 + DEFB 1 + DEFB ' LD HL,@=1<<2', 0 + DEFB 8 + +rule10 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclgor', 0 + DEFB 1 + DEFB ' LD HL,@=1||2', 0 + DEFB 8 + +rule11 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccland', 0 + DEFB 1 + DEFB ' LD HL,@=1&&2', 0 + DEFB 8 + +rule12 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cceq', 0 + DEFB 1 + DEFB ' LD HL,@=1==2', 0 + DEFB 8 + +rule13 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccne', 0 + DEFB 1 + DEFB ' LD HL,@=1!=2', 0 + DEFB 8 + +rule14 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccgt', 0 + DEFB 1 + DEFB ' LD HL,@=1>2', 0 + DEFB 8 + +rule15 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclt', 0 + DEFB 1 + DEFB ' LD HL,@=1<2', 0 + DEFB 8 + +rule16 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccge', 0 + DEFB 1 + DEFB ' LD HL,@=1>=2', 0 + DEFB 8 + +rule17 + DEFB 5 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccle', 0 + DEFB 1 + DEFB ' LD HL,@=1<=2', 0 + DEFB 8 + +rule18 + DEFB 2 + DEFB ' LD HL,@1', 0 + DEFB ' ADD HL,HL', 0 + DEFB 1 + DEFB ' LD HL,@=1+1', 0 + DEFB 1 + +rule19 + DEFB 2 + DEFB ' LD HL,@1', 0 + DEFB ' CALL cclgnot', 0 + DEFB 1 + DEFB ' LD HL,@=!1', 0 + DEFB 3 + +rule20 + DEFB 2 + DEFB ' LD HL,@1', 0 + DEFB ' CALL ccneg', 0 + DEFB 1 + DEFB ' LD HL,@=-1', 0 + DEFB 3 + +rule21 + DEFB 2 + DEFB ' LD HL,@1', 0 + DEFB ' CALL cccom', 0 + DEFB 1 + DEFB ' LD HL,@=~1', 0 + DEFB 3 + +rule22 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,0', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 0 + DEFB 6 + +rule23 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,1', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 1 + DEFB ' INC HL', 0 + DEFB 5 + +rule24 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,2', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB 4 + +rule25 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,3', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 3 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB 3 + +rule26 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,4', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 4 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB 2 + +rule27 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,5', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 5 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB ' INC HL', 0 + DEFB 1 + +rule28 + DEFB 5 + DEFB ' LD HL,@a', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 1 + DEFB ' LD HL,@a+@1', 0 + DEFB 6 + +rule29 + DEFB 5 + DEFB ' LD HL,@a', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 1 + DEFB ' LD HL,@a-@1', 0 + DEFB 8 + +rule30 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,0', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 0 + DEFB 8 + +rule31 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 1 + DEFB ' DEC HL', 0 + DEFB 7 + +rule32 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,2', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 2 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB 6 + +rule33 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,3', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 3 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB 5 + +rule34 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,4', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 4 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB 4 + +rule35 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,5', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 5 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB 3 + +rule36 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,6', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 6 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB 2 + +rule37 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,7', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 7 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB ' DEC HL', 0 + DEFB 1 + +rule38 + DEFB 5 + DEFB ' LD HL,@a', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@b', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 1 + DEFB ' LD HL,@a+@b', 0 + DEFB 6 + +rule39 + DEFB 5 + DEFB ' LD HL,@a', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@b', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccsub', 0 + DEFB 1 + DEFB ' LD HL,@a-@b', 0 + DEFB 8 + +rule40 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + +rule41 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccmul', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL ccmul', 0 + DEFB 2 + +rule42 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccumul', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL ccumul', 0 + DEFB 2 + +rule43 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccor', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL ccor', 0 + DEFB 2 + +rule44 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccand', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL ccand', 0 + DEFB 2 + +rule45 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccxor', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL ccxor', 0 + DEFB 2 + +rule46 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cceq', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL cceq', 0 + DEFB 2 + +rule47 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccneq', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL ccneq', 0 + DEFB 2 + +rule48 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclgor', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL cclgor', 0 + DEFB 2 + +rule49 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclgand', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' CALL cclgand', 0 + DEFB 2 + +rule50 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + +rule51 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccmul', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL ccmul', 0 + DEFB 2 + +rule52 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccumul', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL ccumul', 0 + DEFB 2 + +rule53 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccor', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL ccor', 0 + DEFB 2 + +rule54 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccand', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL ccand', 0 + DEFB 2 + +rule55 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccxor', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL ccxor', 0 + DEFB 2 + +rule56 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cceq', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL cceq', 0 + DEFB 2 + +rule57 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccneq', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL ccneq', 0 + DEFB 2 + +rule58 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclgor', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL cclgor', 0 + DEFB 2 + +rule59 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclgand', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' CALL cclgand', 0 + DEFB 2 + +rule60 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + +rule61 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccmul', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL ccmul', 0 + DEFB 2 + +rule62 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccumul', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL ccumul', 0 + DEFB 2 + +rule63 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccor', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL ccor', 0 + DEFB 2 + +rule64 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccand', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL ccand', 0 + DEFB 2 + +rule65 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccxor', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL ccxor', 0 + DEFB 2 + +rule66 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cceq', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL cceq', 0 + DEFB 2 + +rule67 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL ccneq', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL ccneq', 0 + DEFB 2 + +rule68 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclgor', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL cclgor', 0 + DEFB 2 + +rule69 + DEFB 4 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB ' CALL cclgand', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' CALL cclgand', 0 + DEFB 2 + +rule70 + DEFB 3 + DEFB ' CALL ccne', 0 + DEFB ' LD A,H', 0 + DEFB ' OR L', 0 + DEFB 1 + DEFB ' CALL ccne', 0 + DEFB 2 + +rule71 + DEFB 4 + DEFB ' LD HL,@1', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@2', 0 + DEFB ' POP DE', 0 + DEFB 2 + DEFB ' LD DE,@1', 0 + DEFB ' LD HL,@2', 0 + DEFB 2 + +rule72 + DEFB 4 + DEFB ' LD HL,@a', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@b', 0 + DEFB ' POP DE', 0 + DEFB 2 + DEFB ' LD DE,@a', 0 + DEFB ' LD HL,@b', 0 + DEFB 2 + +rule73 + DEFB 4 + DEFB ' LD HL,(@a)', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@b)', 0 + DEFB ' POP DE', 0 + DEFB 2 + DEFB ' LD DE,(@a)', 0 + DEFB ' LD HL,(@b)', 0 + DEFB 2 + +rule74 + DEFB 3 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@1', 0 + DEFB ' POP DE', 0 + DEFB 2 + DEFB ' EX DE,HL', 0 + DEFB ' LD HL,@1', 0 + DEFB 1 + +rule75 + DEFB 3 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,@a', 0 + DEFB ' POP DE', 0 + DEFB 2 + DEFB ' EX DE,HL', 0 + DEFB ' LD HL,@a', 0 + DEFB 1 + +rule76 + DEFB 3 + DEFB ' PUSH HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB ' POP DE', 0 + DEFB 2 + DEFB ' EX DE,HL', 0 + DEFB ' LD HL,(@a)', 0 + DEFB 1 + +rule77 + DEFB 3 + DEFB ' LD HL,0', 0 + DEFB ' ADD HL,SP', 0 + DEFB ' CALL ccgw', 0 + DEFB 2 + DEFB ' POP HL', 0 + DEFB ' PUSH HL', 0 + DEFB 5 + +rule78 + DEFB 3 + DEFB ' LD HL,1', 0 + DEFB ' ADD HL,SP', 0 + DEFB ' CALL ccgw', 0 + DEFB 6 + DEFB ' POP HL', 0 + DEFB ' POP BC', 0 + DEFB ' PUSH BC', 0 + DEFB ' PUSH HL', 0 + DEFB ' LD L,H', 0 + DEFB ' LD H,C', 0 + DEFB 1 + +rule79 + DEFB 3 + DEFB ' LD HL,2', 0 + DEFB ' ADD HL,SP', 0 + DEFB ' CALL ccgw', 0 + DEFB 4 + DEFB ' POP BC', 0 + DEFB ' POP HL', 0 + DEFB ' PUSH HL', 0 + DEFB ' PUSH BC', 0 + DEFB 3 + +rule80 + DEFB 3 + DEFB ' LD HL,4', 0 + DEFB ' ADD HL,SP', 0 + DEFB ' CALL ccgw', 0 + DEFB 6 + DEFB ' POP BC', 0 + DEFB ' POP DE', 0 + DEFB ' POP HL', 0 + DEFB ' PUSH HL', 0 + DEFB ' PUSH DE', 0 + DEFB ' PUSH BC', 0 + DEFB 1 + +rule81 + DEFB 4 + DEFB ' LD HL,@1', 0 + DEFB ' ADD HL,SP', 0 + DEFB ' LD DE,@2', 0 + DEFB ' ADD HL,DE', 0 + DEFB 2 + DEFB ' LD HL,@=1+2', 0 + DEFB ' ADD HL,SP', 0 + DEFB 4 + +rule82 + DEFB 2 + DEFB ' PUSH @a', 0 + DEFB ' POP @a', 0 + DEFB 0 + DEFB 2 + +rule83 + DEFB 5 + DEFB ' PUSH HL', 0 + DEFB ' POP BC', 0 + DEFB ' POP HL', 0 + DEFB ' PUSH HL', 0 + DEFB ' PUSH BC', 0 + DEFB 4 + DEFB ' EX DE,HL', 0 + DEFB ' POP HL', 0 + DEFB ' PUSH HL', 0 + DEFB ' PUSH DE', 0 + DEFB 1 + +rule84 + DEFB 1 + DEFB ' CALL ccne', 0 + DEFB 2 + DEFB ' OR A', 0 + DEFB ' SBC HL,DE', 0 + DEFB 0 + +rule85 + DEFB 2 + DEFB ' CALL @a', 0 + DEFB ' RET', 0 + DEFB 1 + DEFB ' JP @a', 0 + DEFB 1 + +rule86 + DEFB 3 + DEFB ' RET', 0 + DEFB '@a', 0 + DEFB ' RET', 0 + DEFB 2 + DEFB '@a', 0 + DEFB ' RET', 0 + DEFB 1 + +rule87 + DEFB 2 + DEFB ' JP @a', 0 + DEFB ' JP @b', 0 + DEFB 1 + DEFB ' JP @a', 0 + DEFB 3 + +rule88 + DEFB 2 + DEFB ' JP @a', 0 + DEFB ' JP Z,@b', 0 + DEFB 1 + DEFB ' JP @a', 0 + DEFB 3 + +rule89 + DEFB 2 + DEFB ' JP @a', 0 + DEFB ' JP NZ,@b', 0 + DEFB 1 + DEFB ' JP @a', 0 + DEFB 3 + +rule90 + DEFB 3 + DEFB ' JP Z,@a', 0 + DEFB ' JP @b', 0 + DEFB '@a', 0 + DEFB 2 + DEFB ' JP NZ,@b', 0 + DEFB '@a', 0 + DEFB 3 + +rule91 + DEFB 3 + DEFB ' JP Z,@a', 0 + DEFB '@b', 0 + DEFB ' JP @a', 0 + DEFB 2 + DEFB '@b', 0 + DEFB ' JP @a', 0 + DEFB 3 + +rule92 + DEFB 3 + DEFB ' JP NZ,@a', 0 + DEFB '@b', 0 + DEFB ' JP @a', 0 + DEFB 2 + DEFB '@b', 0 + DEFB ' JP @a', 0 + DEFB 3 + +rule93 + DEFB 2 + DEFB ' JP @a', 0 + DEFB '@a', 0 + DEFB 1 + DEFB '@a', 0 + DEFB 3 + +rule94 + DEFB 2 + DEFB ' JP Z,@a', 0 + DEFB '@a', 0 + DEFB 1 + DEFB '@a', 0 + DEFB 3 + +rule95 + DEFB 2 + DEFB ' JP NZ,@a', 0 + DEFB '@a', 0 + DEFB 1 + DEFB '@a', 0 + DEFB 3 + +rule96 + DEFB 2 + DEFB ' LD HL,@a', 0 + DEFB ' CALL ccgw', 0 + DEFB 1 + DEFB ' LD HL,(@a)', 0 + DEFB 3 + +rules + DEFW rule0 + DEFW rule1 + DEFW rule2 + DEFW rule3 + DEFW rule4 + DEFW rule5 + DEFW rule6 + DEFW rule7 + DEFW rule8 + DEFW rule9 + DEFW rule10 + DEFW rule11 + DEFW rule12 + DEFW rule13 + DEFW rule14 + DEFW rule15 + DEFW rule16 + DEFW rule17 + DEFW rule18 + DEFW rule19 + DEFW rule20 + DEFW rule21 + DEFW rule22 + DEFW rule23 + DEFW rule24 + DEFW rule25 + DEFW rule26 + DEFW rule27 + DEFW rule28 + DEFW rule29 + DEFW rule30 + DEFW rule31 + DEFW rule32 + DEFW rule33 + DEFW rule34 + DEFW rule35 + DEFW rule36 + DEFW rule37 + DEFW rule38 + DEFW rule39 + DEFW rule40 + DEFW rule41 + DEFW rule42 + DEFW rule43 + DEFW rule44 + DEFW rule45 + DEFW rule46 + DEFW rule47 + DEFW rule48 + DEFW rule49 + DEFW rule50 + DEFW rule51 + DEFW rule52 + DEFW rule53 + DEFW rule54 + DEFW rule55 + DEFW rule56 + DEFW rule57 + DEFW rule58 + DEFW rule59 + DEFW rule60 + DEFW rule61 + DEFW rule62 + DEFW rule63 + DEFW rule64 + DEFW rule65 + DEFW rule66 + DEFW rule67 + DEFW rule68 + DEFW rule69 + DEFW rule70 + DEFW rule71 + DEFW rule72 + DEFW rule73 + DEFW rule74 + DEFW rule75 + DEFW rule76 + DEFW rule77 + DEFW rule78 + DEFW rule79 + DEFW rule80 + DEFW rule81 + DEFW rule82 + DEFW rule83 + DEFW rule84 + DEFW rule85 + DEFW rule86 + DEFW rule87 + DEFW rule88 + DEFW rule89 + DEFW rule90 + DEFW rule91 + DEFW rule92 + DEFW rule93 + DEFW rule94 + DEFW rule95 + DEFW rule96 + +rules_max + DEFW 97 + +rules_saved + DEFS 194 +#endasm + \ No newline at end of file diff --git a/disks/images/d/HEXTOCOM.COM b/disks/images/d/HEXTOCOM.COM new file mode 100644 index 0000000..202be89 Binary files /dev/null and b/disks/images/d/HEXTOCOM.COM differ diff --git a/disks/images/d/ZSM.COM b/disks/images/d/ZSM.COM new file mode 100644 index 0000000..5ce1976 Binary files /dev/null and b/disks/images/d/ZSM.COM differ diff --git a/disks/images/d/alloc.h b/disks/images/d/alloc.h new file mode 100644 index 0000000..fbabc99 --- /dev/null +++ b/disks/images/d/alloc.h @@ -0,0 +1,214 @@ +/** + * @file alloc.h + * @brief Dynamic memory allocation. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Dynamic memory allocation functions, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Format of each memory block: + * - WORD size; size of data + * - BYTE used; 0 = no, 1 = yes + * - BYTE data[size]; data + * + * Revisions: + * - 13 Dec 2000 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 26 Aug 2012 : Changed some things for more speed. + * - 19 Feb 2015 : Now free() checks if pointer is NULL. + * - 15 Aug 2016 : Optimized and documented. GPL v3. + * - 21 Aug 2018 : Optimized a bit. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef ALLOC_H + +#define ALLOC_H + +//#define XM_DEBUG + +#define XM_HDR_SIZE 3 // Header size of block in bytes +#define XM_INI_SIZE 6 // Size in bytes needed for setup + +extern BYTE *ccfreefirst; +extern WORD ccfreebytes; + +BYTE *xm_top, // First block + *xm_end; // Last block + +/** + * @fn void *malloc(unsigned int size) + * @brief Allocate memory. + * + * This function tries to allocated a memory block of requested + * size in bytes. + * + * The contents of the allocated memory block is undefined. + * + * @param size - needed size in bytes + * @return pointer to allocated memory, or null pointer on failure + */ +malloc(size) +unsigned int size; +{ + BYTE *mptr; + unsigned int msize; + WORD *pw; + + // Setup library if needed + + if(!xm_top) + { + if(ccfreebytes > XM_INI_SIZE) + { + xm_top = ccfreefirst; + xm_end = xm_top + ccfreebytes - XM_HDR_SIZE; + + // First block has all free memory + *(pw = xm_top) = ccfreebytes - XM_INI_SIZE; + xm_top[2] = 0; + + // Last block uses 0 bytes + *(pw = xm_end) = 0; + xm_end[2] = 1; + } + } + + // Search a free block + + for(mptr = xm_top; mptr != xm_end; mptr += msize + XM_HDR_SIZE) + { + msize = *(pw = mptr); + + if(!mptr[2]) + { + if(msize >= size) + { + mptr[2] = 1; + + if(msize >= size + XM_HDR_SIZE) + { + *(pw = mptr) = size; + *(pw = mptr + size + XM_HDR_SIZE) = msize - size - XM_HDR_SIZE; + *(mptr + size + 5) = 0; + } + +#ifdef XM_DEBUG + alloc_dbg("malloc", size); +#endif + return mptr + XM_HDR_SIZE; + } + } + } + +#ifdef XM_DEBUG + alloc_dbg("malloc", size); +#endif + + return NULL; +} + +/** + * @fn void free(void *ptr) + * @brief Deallocate memory. + * + * This function deallocates memory, previously allocated with malloc. + * + * If ptr is a null pointer, the function does nothing. + * + * @param ptr - memory block to deallocate + */ +free(ptr) +BYTE *ptr; +{ + BYTE *mptr; + unsigned int msize; + WORD *pw; + + // Do nothing on null pointer + + if(!ptr) + return; + + // Make free + + *(ptr - 1) = 0; + + // Join to another free memory blocks if possible + + for(mptr = xm_top; mptr != xm_end; mptr += msize + XM_HDR_SIZE) + { + msize = *(pw = mptr); + + if(!mptr[2]) + { + if(!(*(mptr + msize + 5))) + { + msize += *(pw = mptr + msize + XM_HDR_SIZE) + XM_HDR_SIZE; + + if(!(*(mptr + msize + 5))) + msize += *(pw = mptr + msize + XM_HDR_SIZE) + XM_HDR_SIZE; + + *(pw = mptr) = msize; + + break; + } + } + } + +#ifdef XM_DEBUG + alloc_dbg("free", ptr); +#endif +} + +#ifdef XM_DEBUG + +// void alloc_dbg(char *fn, WORD wrd) : Quick and dirty debug. + +alloc_dbg(fn, wrd) +char *fn; WORD wrd; +{ + BYTE *pb, data[4]; + WORD size, *pw; + int use; + + printf("SP = %04x (%s %04x)\n", alloc_sp(), fn, wrd); + + printf("Addr Size Next Use Data\n"); + + for(pb = xm_top; pb != xm_end; pb += size + XM_HDR_SIZE) + { + pw = pb; + size = *pw; + use = pb[2]; + memcpy(data, pb + XM_HDR_SIZE, 4); + + printf("%04x %04x %5u %04x %s \n", pb, size, size, pb + XM_HDR_SIZE + size, use ? "Used" : "Free"); + } + + getch(); +} + +#asm +alloc_sp + LD HL,0 + ADD HL,SP + RET +#endasm + +#endif + +// Cleaning + +#undef XM_DEBUG +#undef XM_HDR_SIZE +#undef XM_INI_SIZE + +#endif + + \ No newline at end of file diff --git a/disks/images/d/atexit.h b/disks/images/d/atexit.h new file mode 100644 index 0000000..0f97cda --- /dev/null +++ b/disks/images/d/atexit.h @@ -0,0 +1,77 @@ +/** + * @file atexit.h + * @brief Library for the atexit() function. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Support library for the atexit() function, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 30 Nov 2015 : First version. + * - 02 Dec 2016 : Prefix private names with '_' as supported in ZSM v3.1. + * - 07 Dec 2016 : GPL v3. + * + * Copyright (c) 2015-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef ATEXIT_H + +#define ATEXIT_H + +#define ATEXIT_MAX 3 // Max. # of allowed functions + +int _atexit_now; // Counter for # of stored functions +WORD _atexit_arr[ATEXIT_MAX]; // Array for stored functions + +/** + * @fn int atexit(void (*func)(void)) + * @brief Register function to be called when the program terminates normally. + * + * This function registers a function to be called when the program + * terminates normally (either with exit(), or an implicit or + * explicit return in the main() function. + * + * The registered functions will be called in reverse order (last + * registered function first). + * + * @param func - function to call + * @return 0 on sucess, other values on failure + */ +int atexit(func) +WORD func; +{ + // Patch exit() + +#asm + LD A,0CDH + LD (exit),A + LD HL,_exit_patch + LD (exit + 1),HL +#endasm + + if(_atexit_now < ATEXIT_MAX) { + _atexit_arr[_atexit_now++] = func; return 0; + } + + return -1; +} + +// void _exit_patch(void) : call registered functions in reverse order. + +_exit_patch() +{ + while(_atexit_now) + _atexit_arr[--_atexit_now](); +} + +// Cleaning + +#undef ATEXIT_MAX + +#endif + + \ No newline at end of file diff --git a/disks/images/d/bsearch.h b/disks/images/d/bsearch.h new file mode 100644 index 0000000..5d18bd8 --- /dev/null +++ b/disks/images/d/bsearch.h @@ -0,0 +1,71 @@ +/** + * @file bsearch.h + * @brief Binary search. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * This library implements a binary search function of general use, + * for MESCC (Mike's Enhanced Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 30 Nov 2015 : First version. + * - 15 Aug 2016 : Bug solved. Documented. GPL v3. + * + * Copyright (c) 2015-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef BSEARCH_H + +#define BSEARCH_H + +/** + * @fn void *bsearch(const void *key, const void *base, size_t items, size_t size, int (*comp)(const void *, const void *)) + * @brief Binary search. + * + * Search an element in an array, which must be in ascending order. + * + * The comparison function must return: + * - <0 on key < base[x] + * - =0 on key == base[x] + * - >0 on key > base[x] + * + * @param key - element to search + * @param base - address of first element + * @param items - number of elements in the array + * @param size - size in bytes of each element + * @param comp - comparison function + * @return pointer to matching element, or null pointer on failure + */ +BYTE *bsearch(key, base, items, size, comp) +BYTE *key, *base; int items, size; WORD comp; +{ + int a, b, c, dir; + BYTE *p; + + a = 0; + b = items - 1; + + while (a <= b) { + + c = (a + b) >> 1; // c = (a + b) / 2; + p = (base + (c * size)); + + if (dir = comp(p, key)) { + if (dir > 0) + b = c - 1; + else + a = c + 1; + } + else + return p; + } + + return NULL; +} + +#endif + + \ No newline at end of file diff --git a/disks/images/d/cc.com b/disks/images/d/cc.com new file mode 100644 index 0000000..afdf100 Binary files /dev/null and b/disks/images/d/cc.com differ diff --git a/disks/images/d/ccopt.rul b/disks/images/d/ccopt.rul new file mode 100644 index 0000000..266a3eb --- /dev/null +++ b/disks/images/d/ccopt.rul @@ -0,0 +1,1196 @@ +# --------------------------------------- +# RULES for MESCC source code optimizator +# --------------------------------------- +# +# The order is important. +# +# See CAUTION notes. +# +# See FIXME notes. +# +# ------------------------------ +# CONSTANT ARITHMETIC OPERATIONS +# ------------------------------ +# +# In MESCC, all constant arithmetic operations are signed (int). +# +# (int) const + const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + ADD HL,DE + + LD HL,@=1+2 + +6 +# +# (int) const - const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccsub + + LD HL,@=1-2 + +8 +# +# (int) const * const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccmul + + LD HL,@=1*2 + +8 +# +# (int) const / const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccdiv + + LD HL,@=1/2 + +8 +# +# (int) const % const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccmod + + LD HL,@=1%2 + +8 +# +# (int) const | const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccor + + LD HL,@=1|2 + +8 +# +# (int) const & const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccand + + LD HL,@=1&2 + +8 +# +# (int) const ^ const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccxor + + LD HL,@=1^2 + +8 +# +# (int) const >> const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccasr + + LD HL,@=1>>2 + +8 +# +# (int) const << const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccasl + + LD HL,@=1<<2 + +8 +# +# (int) const || const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL cclgor + + LD HL,@=1||2 + +8 +# +# (int) const && const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccland + + LD HL,@=1&&2 + +8 +# +# (int) const == const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL cceq + + LD HL,@=1==2 + +8 +# +# (int) const != const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccne + + LD HL,@=1!=2 + +8 +# +# (int) const > const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccgt + + LD HL,@=1>2 + +8 +# +# (int) const < const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL cclt + + LD HL,@=1<2 + +8 +# +# (int) const >= const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccge + + LD HL,@=1>=2 + +8 +# +# (int) const <= const +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + CALL ccle + + LD HL,@=1<=2 + +8 +# +# (int) double a const +# + LD HL,@1 + ADD HL,HL + + LD HL,@=1+1 + +1 +# +# (int) !const (logical not) +# + LD HL,@1 + CALL cclgnot + + LD HL,@=!1 + +3 +# +# (int) -const (2 complement or negate) +# + LD HL,@1 + CALL ccneg + + LD HL,@=-1 + +3 +# +# (int) ~const (1 complement) +# + LD HL,@1 + CALL cccom + + LD HL,@=~1 + +3 +# ----------------- +# SOMETHING + CONST +# ----------------- +# +# HL + 0 +# + PUSH HL + LD HL,0 + POP DE + ADD HL,DE + + +6 +# +# HL + 1 +# + PUSH HL + LD HL,1 + POP DE + ADD HL,DE + + INC HL + +5 +# +# HL + 2 +# + PUSH HL + LD HL,2 + POP DE + ADD HL,DE + + INC HL + INC HL + +4 +# +# HL + 3 +# + PUSH HL + LD HL,3 + POP DE + ADD HL,DE + + INC HL + INC HL + INC HL + +3 +# +# HL + 4 +# + PUSH HL + LD HL,4 + POP DE + ADD HL,DE + + INC HL + INC HL + INC HL + INC HL + +2 +# +# HL + 5 +# + PUSH HL + LD HL,5 + POP DE + ADD HL,DE + + INC HL + INC HL + INC HL + INC HL + INC HL + +1 +# ---------------------- +# SYMBOL ADDRESS + CONST +# ---------------------- +# + LD HL,@a + PUSH HL + LD HL,@1 + POP DE + ADD HL,DE + + LD HL,@a+@1 + +6 +# ---------------------- +# SYMBOL ADDRESS - CONST +# ---------------------- +# + LD HL,@a + PUSH HL + LD HL,@1 + POP DE + CALL ccsub + + LD HL,@a-@1 + +8 +# ----------------- +# SOMETHING - CONST +# ----------------- +# +# HL - 0 +# + PUSH HL + LD HL,0 + POP DE + CALL ccsub + + +8 +# +# HL - 1 +# + PUSH HL + LD HL,1 + POP DE + CALL ccsub + + DEC HL + +7 +# +# HL - 2 +# + PUSH HL + LD HL,2 + POP DE + CALL ccsub + + DEC HL + DEC HL + +6 +# +# HL - 3 +# + PUSH HL + LD HL,3 + POP DE + CALL ccsub + + DEC HL + DEC HL + DEC HL + +5 +# +# HL - 4 +# + PUSH HL + LD HL,4 + POP DE + CALL ccsub + + DEC HL + DEC HL + DEC HL + DEC HL + +4 +# +# HL - 5 +# + PUSH HL + LD HL,5 + POP DE + CALL ccsub + + DEC HL + DEC HL + DEC HL + DEC HL + DEC HL + +3 +# +# HL - 6 +# + PUSH HL + LD HL,6 + POP DE + CALL ccsub + + DEC HL + DEC HL + DEC HL + DEC HL + DEC HL + DEC HL + +2 +# +# HL - 7 +# + PUSH HL + LD HL,7 + POP DE + CALL ccsub + + DEC HL + DEC HL + DEC HL + DEC HL + DEC HL + DEC HL + DEC HL + +1 +# +# ------------------------------- +# SYMBOL ADDRESS + SYMBOL ADDRESS +# ------------------------------- +# + LD HL,@a + PUSH HL + LD HL,@b + POP DE + ADD HL,DE + + LD HL,@a+@b + +6 +# ------------------------------- +# SYMBOL ADDRESS - SYMBOL ADDRESS +# ------------------------------- +# + LD HL,@a + PUSH HL + LD HL,@b + POP DE + CALL ccsub + + LD HL,@a-@b + +8 +# ------------------ +# SOMETHING OP CONST +# ------------------ +# +# (int, uint) something + const +# + PUSH HL + LD HL,@1 + POP DE + ADD HL,DE + + LD DE,@1 + ADD HL,DE + +2 +# +# (int) something * const +# + PUSH HL + LD HL,@1 + POP DE + CALL ccmul + + LD DE,@1 + CALL ccmul + +2 +# +# (uint) something * const +# + PUSH HL + LD HL,@1 + POP DE + CALL ccumul + + LD DE,@1 + CALL ccumul + +2 +# +# (int, uint) something | const +# + PUSH HL + LD HL,@1 + POP DE + CALL ccor + + LD DE,@1 + CALL ccor + +2 +# +# (int, uint) something & const +# + PUSH HL + LD HL,@1 + POP DE + CALL ccand + + LD DE,@1 + CALL ccand + +2 +# +# (int, uint) something ^ const +# + PUSH HL + LD HL,@1 + POP DE + CALL ccxor + + LD DE,@1 + CALL ccxor + +2 +# +# (int, uint) something == const +# + PUSH HL + LD HL,@1 + POP DE + CALL cceq + + LD DE,@1 + CALL cceq + +2 +# +# (int, uint) something != const +# + PUSH HL + LD HL,@1 + POP DE + CALL ccneq + + LD DE,@1 + CALL ccneq + +2 +# +# (int, uint) something || const +# + PUSH HL + LD HL,@1 + POP DE + CALL cclgor + + LD DE,@1 + CALL cclgor + +2 +# +# (int, uint) something && const +# + PUSH HL + LD HL,@1 + POP DE + CALL cclgand + + LD DE,@1 + CALL cclgand + +2 +# ------------------- +# SOMETHING OP SYMBOL +# ------------------- +# +# (int, uint) something + symbol +# + PUSH HL + LD HL,@a + POP DE + ADD HL,DE + + LD DE,@a + ADD HL,DE + +2 +# +# (int) something * symbol +# + PUSH HL + LD HL,@a + POP DE + CALL ccmul + + LD DE,@a + CALL ccmul + +2 +# +# (uint) something * symbol +# + PUSH HL + LD HL,@a + POP DE + CALL ccumul + + LD DE,@a + CALL ccumul + +2 +# +# (int, uint) something | symbol +# + PUSH HL + LD HL,@a + POP DE + CALL ccor + + LD DE,@a + CALL ccor + +2 +# +# (int, uint) something & symbol +# + PUSH HL + LD HL,@a + POP DE + CALL ccand + + LD DE,@a + CALL ccand + +2 +# +# (int, uint) something ^ symbol +# + PUSH HL + LD HL,@a + POP DE + CALL ccxor + + LD DE,@a + CALL ccxor + +2 +# +# (int, uint) something == symbol +# + PUSH HL + LD HL,@a + POP DE + CALL cceq + + LD DE,@a + CALL cceq + +2 +# +# (int, uint) something != symbol +# + PUSH HL + LD HL,@a + POP DE + CALL ccneq + + LD DE,@a + CALL ccneq + +2 +# +# (int, uint) something || symbol +# + PUSH HL + LD HL,@a + POP DE + CALL cclgor + + LD DE,@a + CALL cclgor + +2 +# +# (int, uint) something && symbol +# + PUSH HL + LD HL,@a + POP DE + CALL cclgand + + LD DE,@a + CALL cclgand + +2 +# --------------------- +# SOMETHING OP (SYMBOL) +# --------------------- +# +# (int, uint) something + (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + ADD HL,DE + + LD DE,(@a) + ADD HL,DE + +2 +# +# (int) something * (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL ccmul + + LD DE,(@a) + CALL ccmul + +2 +# +# (uint) something * (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL ccumul + + LD DE,(@a) + CALL ccumul + +2 +# +# (int, uint) something | (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL ccor + + LD DE,(@a) + CALL ccor + +2 +# +# (int, uint) something & (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL ccand + + LD DE,(@a) + CALL ccand + +2 +# +# (int, uint) something ^ (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL ccxor + + LD DE,(@a) + CALL ccxor + +2 +# +# (int, uint) something == (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL cceq + + LD DE,(@a) + CALL cceq + +2 +# +# (int, uint) something != (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL ccneq + + LD DE,(@a) + CALL ccneq + +2 +# +# (int, uint) something || (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL cclgor + + LD DE,(@a) + CALL cclgor + +2 +# +# (int, uint) something && (symbol) +# + PUSH HL + LD HL,(@a) + POP DE + CALL cclgand + + LD DE,(@a) + CALL cclgand + +2 +# ------------------------------------------------- +# CAUTION: This depends on value returned from cceq +# ------------------------------------------------- +# +# CALL cceq -- MUST TO BE REVISED. Also cclgnot. +# LD A,H +# OR L +# +# CALL cceq +# +#2 +# ------------------------------------------------- +# CAUTION: This depends on value returned from ccne +# ------------------------------------------------- +# + CALL ccne + LD A,H + OR L + + CALL ccne + +2 +# ------- +# +# ------- +# +# ? +# + LD HL,@1 + PUSH HL + LD HL,@2 + POP DE + + LD DE,@1 + LD HL,@2 + +2 +# +# ? +# + LD HL,@a + PUSH HL + LD HL,@b + POP DE + + LD DE,@a + LD HL,@b + +2 +# +# ? +# + LD HL,(@a) + PUSH HL + LD HL,(@b) + POP DE + + LD DE,(@a) + LD HL,(@b) + +2 +# +# ? +# + PUSH HL + LD HL,@1 + POP DE + + EX DE,HL + LD HL,@1 + +1 +# +# ? +# + PUSH HL + LD HL,@a + POP DE + + EX DE,HL + LD HL,@a + +1 +# +# ? +# + PUSH HL + LD HL,(@a) + POP DE + + EX DE,HL + LD HL,(@a) + +1 +# --------------- +# ACCESS TO STACK +# --------------- +# +# ? +# + LD HL,0 + ADD HL,SP + CALL ccgw + + POP HL + PUSH HL + +5 +# +# ? +# + LD HL,1 + ADD HL,SP + CALL ccgw + + POP HL + POP BC + PUSH BC + PUSH HL + LD L,H + LD H,C + +1 +# +# ? +# + LD HL,2 + ADD HL,SP + CALL ccgw + + POP BC + POP HL + PUSH HL + PUSH BC + +3 +# +# ? +# + LD HL,4 + ADD HL,SP + CALL ccgw + + POP BC + POP DE + POP HL + PUSH HL + PUSH DE + PUSH BC + +1 +# +# ? +# + LD HL,@1 + ADD HL,SP + LD DE,@2 + ADD HL,DE + + LD HL,@=1+2 + ADD HL,SP + +4 +# +# ? +# + PUSH @a + POP @a + + +2 +# +# ? +# + PUSH HL + POP BC + POP HL + PUSH HL + PUSH BC + + EX DE,HL + POP HL + PUSH HL + PUSH DE + +1 +# ---------------- +# EXPAND NOT EQUAL +# ---------------- +# + CALL ccne + + OR A + SBC HL,DE + +0 +# ----------------- +# CALL, RET & JUMPS +# ----------------- +# +# ? +# + CALL @a + RET + + JP @a + +1 +# +# ? +# + RET +@a + RET + +@a + RET + +1 +# +# ? +# + JP @a + JP @b + + JP @a + +3 +# +# ? +# + JP @a + JP Z,@b + + JP @a + +3 +# +# ? +# + JP @a + JP NZ,@b + + JP @a + +3 +# +# ? +# + JP Z,@a + JP @b +@a + + JP NZ,@b +@a + +3 +# +# ? +# + JP Z,@a +@b + JP @a + +@b + JP @a + +3 +# +# ? +# + JP NZ,@a +@b + JP @a + +@b + JP @a + +3 +# +# ? +# + JP @a +@a + +@a + +3 +# +# ? +# + JP Z,@a +@a + +@a + +3 +# +# ? +# + JP NZ,@a +@a + +@a + +3 +# ------------ +# MISCELANEOUS +# ------------ +# +# ? +# + LD HL,@a + CALL ccgw + + LD HL,(@a) + +3 \ No newline at end of file diff --git a/disks/images/d/cpm.h b/disks/images/d/cpm.h new file mode 100644 index 0000000..83ee0c2 --- /dev/null +++ b/disks/images/d/cpm.h @@ -0,0 +1,604 @@ +/** + * @file cpm.h + * @brief CP/M functions. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * CP/M functions for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Supports following #defines: + * - CC_FCX To support FCX (user number in file names). + * - CC_FCX_DIR To support named directories in file names. + * + * When CC_FCX_DIR is defined, you must supply a function that + * translates a directory name (string in upper case, up to 8 + * characters in length + ZERO), into a drive & user number + * specification (string in upper case, up to 3 characters in + * length + ZERO): + * + * char *DirToDrvUsr(char *s) + * + * ie - DirToDrvUsr("ROOT") == "A0" + * + * It must to return NULL on unknown directory names. + * + * See UxGetDrvUsr() for an example. + * + * Definitions for BDOS functions: + * - BF_GETDRV 25 + * - BF_SETDRV 14 + * - BF_USER 32 + * - BF_DMA 26 + * - BF_FIND1ST 17 + * - BF_FINDNEXT 18 + * - BF_OSVER 12 + * - BF_CONST 11 + * - BF_FSIZE 35 + * - BF_OPEN 15 + * - BF_DELETE 19 + * - BF_CREATE 22 + * - BF_READSEQ 20 + * - BF_WRITESEQ 21 + * - BF_RENAME 23 + * - BF_CLOSE 16 + * - BF_ATTRIB 30 + * - BF_READRND 33 + * - BF_WRITERND 34 + * + * Revisions: + * - 19 Oct 2000 : Last revision. + * - 17 Apr 2004 : Added renfile function. + * - 16 Apr 2007 : GPL'd. + * - 12 Dec 2014 : Added FCX support. + * - 11 Feb 2015 : Added some BDOS #defines. + * - 03 Sep 2015 : Added FCX_DIR support (names for user areas, a sort of alias). + * - 08 Jan 2016 : Include ctype.h, mem.h libraries if CC_FCX is defined. + * - 18 Jul 2016 : Added #defines BF_READRND and BF_WRITERND. + * - 11 Dec 2016 : Documented. Optimized. GPL v3. + * + * Copyright (c) 1999-2021 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef CPM_H + +#define CPM_H + +// Dependencies +// ------------ + +#ifdef CC_FCX + +#ifndef CTYPE_H + #include +#endif + +#ifndef MEM_H + #include +#endif + +#endif + +// BDOS FUNCTIONS +// -------------- + +#define BF_GETDRV 25 +#define BF_SETDRV 14 +#define BF_USER 32 +#define BF_DMA 26 +#define BF_FIND1ST 17 +#define BF_FINDNEXT 18 +#define BF_OSVER 12 +#define BF_CONST 11 +#define BF_FSIZE 35 +#define BF_OPEN 15 +#define BF_DELETE 19 +#define BF_CREATE 22 +#define BF_READSEQ 20 +#define BF_WRITESEQ 21 +#define BF_RENAME 23 +#define BF_CLOSE 16 +#define BF_ATTRIB 30 +#define BF_READRND 33 +#define BF_WRITERND 34 + +/** + * @fn unsigned int bdos_hl(unsigned int bc, unsigned int de) + * @brief Call to BDOS. + * @param bc - bc register + * @param de - de register + * @return value of hl register + */ +#asm + +bdos_hl + POP HL + POP DE + POP BC + PUSH BC + PUSH DE + PUSH HL + JP 5 +#endasm + +/** + * @fn unsigned char bdos_a(unsigned int bc, unsigned int de) + * @brief Call to BDOS. + * @param bc - bc register + * @param de - de register + * @return value of a register + */ +#asm + +bdos_a + POP HL + POP DE + POP BC + PUSH BC + PUSH DE + PUSH HL + CALL 5 + LD H,0 + LD L,A + RET +#endasm + + +// FCX functions +// ------------- + +#ifdef CC_FCX + +#define UX_FCX_SIZ 37 +#define UX_FCX_USR 0 +#define UX_FCX_DRV 1 +#define UX_FCX_RRC 34 /* Random Record Number */ + +/** + * @fn unsigned char bdos_fcx_a(unsigned int bc, unsigned int de) + * @brief Call to BDOS with a FCX as parameter. + * + * This function is available if CC_FCX is defined. + * + * @param bc - bc register + * @param de - de register + * @return value of a register + */ +bdos_fcx_a(fun, fcx) +int fun; BYTE *fcx; +{ + int val, old_user; + + if(*fcx) + { + if((old_user = bdos_a(BF_USER, 0xFFFF)) != *fcx - 1) + { + bdos_a(BF_USER, *fcx - 1); /* Set user to FCX user */ + val = bdos_a(fun, fcx + 1); /* Call BDOS function */ + bdos_a(BF_USER, old_user); /* Set old user */ + + return val; + } + } + + return bdos_a(fun, fcx + 1); +} + +/* ----------------------------------------------------- + This is an example, you must define your own funcion. + ----------------------------------------------------- + + char *DirToDrvUsr(char *s) + + Translate a directory name in upper case, to a drive + and user name specification in upper case. + + Return NULL on unknown directory name. + +DirToDrvUsr(s) +char *s; +{ + if(!strcmp(s, "ROOT")) + return "A0"; + else if(!strcmp(s, "MESCC")) + return "A1"; + else if(!strcmp(s, "TEMP")) + return "M0"; + + return NULL; +} + ----------------------------------------------------- +*/ + +/** + * @fn int setfcx(char *fname, char *fcx) + * @brief Make FCX. + * + * This function is available if CC_FCX is defined. + * + * @param fname - filename + * @param fcx - destination FCX + * @return 0 on success, else != 0 + */ +setfcx(s, fcx) +char *s; BYTE *fcx; +{ + char f[9]; WORD path; BYTE drv, usr; + + memset(fcx, 0, UX_FCX_SIZ); + + s = UxField(s, f); + + if(*s == ':' && *f) + { + if((path = UxGetDrvUsr(f)) == -1) + return -1; + + drv = (path >> 8) & 0xFF; + usr = path & 0xFF; + + fcx[UX_FCX_DRV] = (drv == 0xDD ? 0 : drv + 1); + fcx[UX_FCX_USR] = (usr == 0xDD ? 0 : usr + 1); + + s = UxField(++s, f); + } + + if((!(*s) || *s=='.') && *f) + { + if(UxPad(f, fcx + 2, 8)) + return -1; + + if(*s) + s = UxField(++s, f); + else + *f = 0; + + if(UxPad(f, fcx + 10, 3)) + return -1; + } + + return *s || !fcx[2] ? -1 : 0; +} + +// unsigned int UxGetDrvUsr(char *s) : get drive + user specification, or -1 on error. + +UxGetDrvUsr(s) +char *s; +{ + int drv, usr; + +#ifdef CC_FCX_DIR + char *du; + + if((du = DirToDrvUsr(s))) + s = du; +#endif + + drv = usr = 0xDD; + + if(*s >= 'A' && *s <= 'P') + drv = *s++ -'A'; + + if(isdigit(*s)) + { + usr = 0; + + do + { + if((usr = usr * 10 + *s - '0') > 15) + break; + } while(isdigit(*++s)); + } + + if(*s) + return -1; + + return (drv << 8) | usr; +} + +// int UxPad(char *s, char *d, int n) : pad field with spaces -- return 0 on success, else -1. + +UxPad(s, d, n) +char *s, *d; int n; +{ + int i; char f; + + f = ' '; + + for(i = 0; i != n; ++i) + { + if(*s == '*') + { + f = '?'; ++s; break; + } + else if(*s) + *d++ = *s++; + else + break; + } + + if(*s) + return -1; + + while(i != n) + { + *d++ = f; ++i; + } + + return 0; +} + +// char *UxField(char *s, char *d) : get field -- return pointer to delimiter, else NULL. + +// Max. length of field is 8. +// Field can be empty (zero length). +// Delimiters: ':', '.', '\0'. + +UxField(s, d) +char *s, *d; +{ + char c; int i; + + for(i = 0; i != 8; ++i) + { + c = toupper(*s); + + if(isalpha(c) || isdigit(c) || c == '$' || c == '_' || c == '*' || c == '?') + { + *d++ = c; ++s; + } + else + break; + } + + *d = 0; c = *s; + + if(c == ':' || c == '.' || c == '\0') + return s; + + return NULL; +} + +/************************ +UxFcxIsAmb(fcx) +BYTE *fcx; +{ + int i; + + for(i = 0; i < 11; ++i) + { + if(*++fcx == '?') + return 1; + } + + return 0; +} +*******************/ + +// unsigned int UxGetPath(char *path) : get user + drive spec. from path, or -1 on error. + +// UxGetPath("A1:") --> 0x0001 +// UxGetPath("root:") --> ? + +UxGetPath(path) +char *path; +{ + char s[9]; + + path = UxField(path, s); + + if(*path == ':' && !path[1] && *s) + return UxGetDrvUsr(s); + + return -1; +} + +// unsigned int UxChdir(char *path) : change drive + user from path -- return drive + user, or -1 on error. + +// UxChdir("A1:") --> 0x0001 +// UxChdir("root:") --> ? + +UxChdir(path) +char *path; +{ + int du, drv, usr; + + if((du = UxGetPath(path)) != -1) + { + drv = (du >> 8) & 0xFF; + usr = du & 0xFF; + + if(drv != 0xDD && drv != bdos_a(BF_GETDRV, 0)) + bdos_hl(BF_SETDRV, drv); + + if(usr != 0xDD && usr != bdos_a(BF_USER, 0xFFFF)) + bdos_hl(BF_USER, usr); + + return du; + } + + return -1; +} + +#else + +/** + * @fn int setfcb(char *fname, char *fcb) + * @brief Make FCB. + * + * This function is available if CC_FCX is not defined. + * + * @param fname - filename + * @param fcb - destination FCB + * @return 0 on success, else != 0 + */ +#asm + +setfcb: + POP BC + POP DE + POP HL + PUSH HL ;HL = fname address + PUSH DE ;DE = fcb address + PUSH BC + + INC HL ;Check for optional A: ... P: drive + LD A,(HL) + DEC HL + CP ':' + JR NZ,sfcbdef + LD A,(HL) + CALL sfcbupp + CP 'A' + JR C,sfcberr + CP 'P' + 1 + JR NC,sfcberr + SUB 'A' - 1 + INC HL + INC HL + JR sfcbdrv + +sfcbdef + XOR A ;Default drive + +sfcbdrv + LD (DE),A ;Set drive in fcb + INC DE + +sfcbnam + LD C,'.' ;Set name in fcb + LD B,8 + CALL sfcbtok + LD A,B + CP 8 + JR Z,sfcberr + LD A,(HL) + OR A + JR Z,sfcbtyp + CP '.' + JR NZ,sfcberr + INC HL + +sfcbtyp + LD C,0 ;Set type in fcb + LD B,3 + CALL sfcbtok + LD A,(HL) + OR A + JR NZ,sfcberr + + LD A,0 ;Fill the rest of the fcb with zeroes + LD B,24 + CALL sfcbset + + LD HL,0 ;Success + RET + + ;Error entry for sfcbtok + +sfcbtke + POP HL ;Remove address from stack + +sfcberr + LD HL,1 ;Error + RET + + ;Set field (name or type) + ; + ;In: + ; C = delimiter ('.' for name, 0 for type) + ; B = Max. field length (8 for name, 3 for type) + ; + ;Out: + ; B = Remain length + +sfcbtok + LD A,(HL) ;End of string? + OR A + JR Z,sfcbspc + CP C ;Delimiter? + JR Z,sfcbspc + CP '*' ;Wildcard? + JR Z,sfcbamb + + ;Accept only valid characters + + CP '#' ;# $ % + JR C,sfcbtke + CP '%' + 1 + JR C,sfcbtks + CP '0' ;0 ... 9 + JR C,sfcbtke + CP '9' + 1 + JR C,sfcbtks + CALL sfcbupp ;? @ A ... Z + CP '?' + JR C,sfcbtke + CP 'Z' + 1 + JR C,sfcbtks + CP '_' ;_ + JR NZ,sfcbtke + +sfcbtks + LD (DE),A ;Set character in fcb + INC HL + INC DE + DJNZ sfcbtok ;Continue upto max. length + RET + + ;Fill the remain field length with spaces, + ;and return the remain length. + +sfcbspc + LD A,' ' + LD C,B + CALL sfcbset + LD B,C + RET + + ;Fill the remain field length with '?' + ;and set remain length to 0. + +sfcbamb + LD A,'?' + INC HL + + ;Fill memory + ; + ;In: + ; DE = address + ; B = length + ; A = value + +sfcbset + LD (DE),A + INC DE + DJNZ sfcbset + RET + + ;Convert character to uppercase + ; + ;In: + ; A = Character + ; + ;Out: + ; A = Character converted to uppercase if it was: a ... z + +sfcbupp + CP 'a' + RET C + CP 'z' + 1 + RET NC + SUB 32 + RET + +#endasm + +#endif + +#endif + + \ No newline at end of file diff --git a/disks/images/d/ctype.h b/disks/images/d/ctype.h new file mode 100644 index 0000000..bad2be9 --- /dev/null +++ b/disks/images/d/ctype.h @@ -0,0 +1,203 @@ +/** + * @file ctype.h + * @brief Character tests and conversion functions. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Character tests and conversion functions, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 19 Dec 2000 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 15 Aug 2016 : Documented. GPL v3. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef CTYPE_H + +#define CTYPE_H + +/** + * @fn int isalpha(char ch) + * @brief Test if ch is a letter. + * @param ch - character to test + * @return true or false + */ +#asm + +isalpha + ld a,l + ld hl,0 + cp 'A' + ret c + cp 'Z'+1 + jr c,isalpha1 + cp 'a' + ret c + cp 'z'+1 + ret nc +isalpha1 + inc l + ret + +#endasm + +/** + * @fn int isdigit(char ch) + * @brief Test if ch is a decimal digit. + * @param ch - character to test + * @return true or false + */ +#asm + +isdigit + ld a,l + ld hl,0 + cp '0' + ret c + cp '9'+1 + ret nc + inc l + ret + +#endasm + +/** + * @fn int isxdigit(char ch) + * @brief Test if ch is an hexadecimal digit. + * @param ch - character to test + * @return true or false + */ +#asm + +isxdigit + LD C,L + CALL isdigit + RET C + LD HL,0 + LD A,C + CP 'A' + RET C + CP 'G' + JR C,isxdigit1 + CP 'a' + RET C + CP 'g' + RET NC +isxdigit1 + INC L + RET + +#endasm + +/** + * @fn int isalnum(char ch) + * @brief Test if ch is a letter or a decimal digit. + * @param ch - character to test + * @return true or false + */ +#asm + +isalnum + LD C,L + CALL isdigit + RET C + LD L,C + JP isalpha + +#endasm + +/** + * @fn int isupper(char ch) + * @brief Test if ch is a letter in uppercase. + * @param ch - character to test + * @return true or false + */ +#asm + +isupper + ld a,l + ld hl,0 + cp 'A' + ret c + cp 'Z'+1 + ret nc + inc l + ret + +#endasm + +/** + * @fn int islower(char ch) + * @brief Test if ch is a letter in lowercase. + * @param ch - character to test + * @return true or false + */ +#asm + +islower + ld a,l + ld hl,0 + cp 'a' + ret c + cp 'z'+1 + ret nc + inc l + ret + +#endasm + +/** + * @fn int toupper(char ch) + * @brief Convert letter to uppercase. + * + * If ch is not a letter in lowercase, returns ch unchanged. + * + * @param ch - character to convert + * @return ch in uppercase + */ +#asm + +toupper + ld a,l + cp 'a' + ret c + cp 'z'+1 + ret nc + sub 20h + ld l,a + ret + +#endasm + +/** + * @fn int tolower(char ch) + * @brief Convert letter to lowercase. + * + * If ch is not a letter in uppercase, returns ch unchanged. + * + * @param ch - character to convert + * @return ch in lowercase + */ +#asm + +tolower + ld a,l + cp 'A' + ret c + cp 'Z'+1 + ret nc + add 20h + ld l,a + ret + +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/d/fileio.h b/disks/images/d/fileio.h new file mode 100644 index 0000000..4b4d1aa --- /dev/null +++ b/disks/images/d/fileio.h @@ -0,0 +1,829 @@ +/** + * @file fileio.h + * @brief File I/O. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * File I/O for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Support standard macros: + * - FILE + * - EOF + * - FILENAME_MAX + * + * Supports following macros: + * - #define CC_STDIO To support stdin, stdout & stderr. + * - #define CC_FCX To support FCX (user number in file names, see cpm.h). + * - #define CC_FCX_DIR To support named directories in file names (see cpm.h). + * - #define CC_FILEIO_SMALL To exclude fread(), fwrite() and fgets(). ===DEPRECATED=== + * - #define CC_FOPEN_A To include "a" and "ab" modes for fopen(). + * - #define CC_FREAD To include fread(). + * - #define CC_FWRITE To include fwrite(). + * - #define CC_FGETS To include fgets(). + * - #define CC_FPUTS To include fputs(). + * - #define CC_FSIZE To include fsize(). + * + * Revisions: + * - 19 Mar 2001 : Last revision. + * - 17 Apr 2004 : Added functions: fread, fwrite, remove, rename. + * - 16 Apr 2007 : GPL'd. + * - 20 Apr 2007 : Quit "rt" and "wt" modes. Now "r" and "w" are text modes. + * - 10 Nov 2013 : Solved bug related to DMA in fopen, rename, remove. + * - 19 Nov 2013 : Reworked for UX. + * - 11 Dec 2013 : Added function: fgets. + * - 08 Dec 2014 : Added stdin, stdout, stderr support if CC_STDIO is defined. + * - 09 Dec 2014 : Added support to FCX if CC_FCX defined. + * - 18 Dec 2014 : Modified #define EOF (-1) to -1. + * - 16 Jan 2015 : Solved related memory bug in rename. + * - 16 Jan 2015 : Added FILENAME_MAX ANSI C definition. + * - 17 Feb 2015 : Solved bug in rename. + * - 07 Mar 2015 : Modified FILENAME_MAX value (now includes ZERO according to ANSI). + * - 09 Apr 2015 : Test ambiguous file names in fopen(). + * - 03 May 2015 : Solved bug in fgets - last character was lost in long lines. + * - 17 Nov 2015 : Added FILENAME_MAX value when CC_FCX_DIR is defined. + * - 24 Dec 2015 : Added CC_FILEIO_SMALL define to exclude fread(), fwrite() and fgets(). + * - 04 Jan 2016 : Removed some code from fread() and fwrite(). + * - 08 Jan 2016 : Include mem.h library. + * - 19 Jul 2016 : Added "a" and "ab" modes. + * Added support for CC_FOPEN_A, CC_FREAD, CC_FWRITE and CC_FGETS defines. + * Removed CC_FILEIO_SMALL define. + * - 23 Jul 2016 : Added fputs() and support for CC_FPUTS define. + * - 10 Dec 2016 : Documented. Optimized. GPL v3. + * - 15 Dec 2016 : Optimize NULL comparisons, fgetc(), fputc(). + * - 18 Feb 2018 : Document public macros. Rename internal macros and include them in cleaning. Rework remove() and rename(). Added FOPEN_MAX. + * - 03 May 2018 : Make CC_FPUTS effective (use #ifdef instead of #if). + * - 27 Dec 2018 : Added fsize(). + * - 13 Sep 2021 : Bugfix in fopen "a" text mode when there are no 0x1A bytes in the last record. + * - 16 Sep 2021 : Bugfix in fsize() regarding CP/M v2 / v3 compatibility. + * + * Copyright (c) 1999-2021 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef FILEIO_H + +#define FILEIO_H + +/* Dependencies + ------------ +*/ +#ifndef CPM_H + #include +#endif + +#ifndef ALLOC_H + #include +#endif + +#ifndef MEM_H + #include +#endif + +#ifdef CC_STDIO +#ifndef CONIO_H + #include +#endif +#endif + +/* Public defines + -------------- +*/ +#define FILE unsigned char +#define EOF -1 +#define FOPEN_MAX 99 + +#ifdef CC_FCX +#ifdef CC_FCX_DIR +#define FILENAME_MAX 22 /* dusrname:filename.typ + ZERO */ +#else +#define FILENAME_MAX 17 /* duu:filename.typ + ZERO */ +#endif +#else +#define FILENAME_MAX 15 /* d:filename.typ + ZERO */ +#endif + +/* Private defines + --------------- +*/ +#define _XF_READ 1 /* Read mode */ +#define _XF_WRITE 2 /* Write mode */ +#define _XF_BIN 4 /* Binary mode */ +#define _XF_EOF 8 /* End of file */ +#define _XF_ERR 16 /* I/O error */ + +#define _XF_IMOD 0 /* Mode (1 byte) */ +#define _XF_IPOS 1 /* Position in buffer (1 byte) */ +#define _XF_IBUF 2 /* Buffer (128 bytes) */ +#define _XF_IFCX 130 /* FCX (37 bytes: USER (1) + FCB (36)) */ + +#ifdef CC_FCX + +#define _XF_ISIZ 167 /* Data block size */ +#define _XF_IRND 164 /* Random record # in FCX */ + +#define _FILEOP bdos_fcx_a +#define _MAKEFCB setfcx + +#define _FCB_SIZE 37 + +#else + +#define _XF_ISIZ 166 /* Data block size */ +#define _XF_IRND 163 /* Random record # in FCB */ + +#define _FILEOP bdos_a +#define _MAKEFCB setfcb + +#define _FCB_SIZE 36 + +#endif + +/** + * @fn FILE *fopen(char *fname, char *fmode) + * @brief Open file. + * + * Valid 'fmode' values are: + * - "rb" : Binary reading. + * - "r" : Text reading. + * - "wb" : Binary writing. + * - "w" : Text writing. + * - "a" : Append text writing. + * - "ab" : Append binary writing. + * + * In text mode, the following translations are performed: + * - Reading: '\r' is ignored, '\n' is end of line. + * - Writing: '\n' is converted to '\r' + '\n'. + * + * @param fname - filename + * @param fmode - file access mode + * @return Pointer to FILE on success, else NULL. + */ +fopen(fname,fmode) +char *fname, *fmode; +{ + int mode; + FILE *fp; + +#ifdef CC_FOPEN_A + int i; + unsigned int *wp; +#endif + + // Mode + if(*fmode == 'r') + mode = _XF_READ; + else if(*fmode=='w') + mode = _XF_WRITE; +#ifdef CC_FOPEN_A + else if(*fmode == 'a') + mode = _XF_WRITE; +#endif + else + return NULL; + + if(*(fmode + 1) == 'b') + mode |= _XF_BIN; + else if(*(fmode + 1)) + return NULL; + + // Filename can't be ambiguous + if(xfnamb(fname)) + return NULL; + + // Get memory + if(!(fp = malloc(_XF_ISIZ))) + return NULL; + + // Make FCB + if(_MAKEFCB(fname, fp + _XF_IFCX)) + { + free(fp); + return NULL; + } + + // Open file + bdos_hl(BF_DMA, fp+_XF_IBUF); + + if(mode & _XF_READ) + { + if(_FILEOP(BF_OPEN, fp + _XF_IFCX) == 255) + { + free(fp); + return NULL; + } + + fp[_XF_IPOS] = 128; // No data in buffer + } +#ifdef CC_FOPEN_A + else if(*fmode == 'a') + { + fp[_XF_IPOS] = 0; // No data in buffer + + if(_FILEOP(BF_OPEN, fp + _XF_IFCX) != 255) + { + _FILEOP(BF_FSIZE, fp + _XF_IFCX); + + wp = fp + _XF_IRND; + + if(*(fmode + 1) != 'b' && *wp) + { + --(*wp); + + _FILEOP(BF_READRND, fp + _XF_IFCX); + + for(i = 0; i < 128; ++i) + { + if(*(fp + _XF_IBUF + i) == 0x1A) + { + fp[_XF_IPOS] = i; + break; + } + } + + if(i == 128) + ++(*wp); + } + } + else if(_FILEOP(BF_CREATE, fp + _XF_IFCX) == 255) + { + free(fp); + return NULL; + } + } +#endif + else + { + if(_FILEOP(BF_FIND1ST, fp + _XF_IFCX) != 255) + { + if(_FILEOP(BF_DELETE, fp + _XF_IFCX) == 255) + { + free(fp); + return NULL; + } + } + + if(_FILEOP(BF_CREATE, fp + _XF_IFCX) == 255) + { + free(fp); + return NULL; + } + + fp[_XF_IPOS] = 0; // No data in buffer + } + + // Set file mode + fp[_XF_IMOD] = mode; + + // Return pointer to FILE + return fp; +} + +/** + * @fn int fgetc(FILE *fp) + * @brief Read character from file. + * @param fp - pointer to FILE + * @return character on success, else EOF on end of file or error + */ +fgetc(fp) +FILE *fp; +{ + int c; + +#ifdef CC_STDIO + + // Console? + if(!fp) + { + if((c = getch()) == '\r') + c = '\n'; + else if (c == 0x1A) + return EOF; + + if(c == '\n') + putch('\r'); + + return putch(c); + } +#endif + + // File opened for reading and without errors? + if(!(fp[_XF_IMOD] & _XF_READ) || fp[_XF_IMOD] & (_XF_EOF + _XF_ERR)) + return EOF; + + // Read binary + if((fp[_XF_IMOD] & _XF_BIN)) + return xfgetc(fp); + + // Read text + while((c = xfgetc(fp)) == '\r') + ; + + if(c == 0x1A) + { + fp[_XF_IMOD] |= _XF_EOF; + c = EOF; + } + + // Return character + return c; +} + +// int xfgetc(FILE *fp) : Helper for fgetc() - return next character, or EOF on end of file or error. + +xfgetc(fp) +FILE *fp; +{ +#ifdef CC_FOPEN_A + unsigned int *wp; +#endif + // Read next record if needed + if(fp[_XF_IPOS] == 128) + { + bdos_hl(BF_DMA, fp+_XF_IBUF); + +#ifdef CC_FOPEN_A + if(_FILEOP(BF_READRND, fp + _XF_IFCX)) +#else + if(_FILEOP(BF_READSEQ, fp + _XF_IFCX)) +#endif + { + fp[_XF_IMOD] |= _XF_EOF; + return EOF; + } + +#ifdef CC_FOPEN_A + wp = fp + _XF_IRND; ++(*wp); +#endif + + fp[_XF_IPOS] = 0; + } + + // Get character from buffer and increment pointer + return *(fp + _XF_IBUF + fp[_XF_IPOS]++); +} + +/** + * @fn int fputc(int c, FILE *fp) + * @brief Write character to file. + * @param c - character + * @param fp - pointer to FILE + * @return c on success, else EOF + */ +fputc(c,fp) +int c; +FILE *fp; +{ + +#ifdef CC_STDIO + + // Console? + if(!fp) + { + if(c == '\n') + putch('\r'); + + return putch(c); + } +#endif + + // File opened for writing and without errors? + if(!(fp[_XF_IMOD] & _XF_WRITE) || fp[_XF_IMOD] & (_XF_EOF + _XF_ERR)) + return EOF; + + // Write binary + if((fp[_XF_IMOD] & _XF_BIN)) + return xfputc(c, fp); + + // Write text + if(c == '\n') + { + if(xfputc('\r', fp) == EOF) + return EOF; + } + + return xfputc(c, fp); +} + +// int xfputc(int c, FILE *fp) : Helper for fputc() - return character, or EOF on error. + +xfputc(c,fp) +int c; +FILE *fp; +{ +#ifdef CC_FOPEN_A + unsigned int *wp; +#endif + + // Store character in buffer and increment pointer + *(fp + _XF_IBUF + fp[_XF_IPOS]++) = c; + + // Write record if needed + if(fp[_XF_IPOS] == 128) + { + bdos_hl(BF_DMA, fp + _XF_IBUF); + +#ifdef CC_FOPEN_A + if(_FILEOP(BF_WRITERND, fp + _XF_IFCX)) +#else + if(_FILEOP(BF_WRITESEQ, fp + _XF_IFCX)) +#endif + { + fp[_XF_IMOD] |= _XF_ERR; + return EOF; + } + +#ifdef CC_FOPEN_A + wp = fp + _XF_IRND; ++(*wp); +#endif + + fp[_XF_IPOS] = 0; + } + + // Return character + return c; +} + +/** + * @fn int fclose(FILE *fp) + * @brief Close file. + * @param fp - pointer to FILE + * @return 0 on success, else EOF + */ +fclose(fp) +FILE *fp; +{ + +#ifdef CC_STDIO + + // Console? + if(!fp) + return 0; +#endif + + // Writing mode? + if(fp[_XF_IMOD] & _XF_WRITE) + { + while(fp[_XF_IPOS]) + { + if(xfputc(0x1A, fp) == EOF) + return EOF; + } + } + + // Close file + bdos_hl(BF_DMA, fp + _XF_IBUF); + + if(_FILEOP(BF_CLOSE, fp + _XF_IFCX) == 255) + return EOF; + + // Free buffer memory + free(fp); + + // Success + return 0; +} + +/** + * @fn int feof(FILE *fp) + * @brief Test end of file. + * @param fp - pointer to FILE + * @return != 0 if true, else 0 + */ +feof(fp) +FILE *fp; +{ + +#ifdef CC_STDIO + + // Console? + if(!fp) + return 0; +#endif + + return fp[_XF_IMOD] & _XF_EOF; +} + +/** + * @fn int ferror(FILE *fp) + * @brief Test file error. + * @param fp - pointer to FILE + * @return != 0 if true, else 0 + */ +ferror(fp) +FILE *fp; +{ + +#ifdef CC_STDIO + + // Console? + if(!fp) + return 0; +#endif + + return fp[_XF_IMOD] & _XF_ERR; +} + +#ifdef CC_FREAD + +/** + * @fn int fread(char *ptr, int size, int nobj, FILE *fp) + * @brief Read from file. + * @param ptr - destination buffer + * @param size - object size in bytes + * @param nobj - # of objects to read + * @param fp - pointer to FILE + * @return # of objects read + */ +fread(ptr, size, nobj, fp) +unsigned char *ptr; +int size, nobj; +FILE *fp; +{ + int cobj, csize, c; + + for(cobj = 0; cobj != nobj; ++cobj) + { + for(csize = 0; csize != size; ++csize) + { + if((c = fgetc(fp)) == EOF) + return cobj; + + *ptr++ = c; + } + } + + return cobj; +} + +#endif + +#ifdef CC_FWRITE + +/** + * @fn int fwrite(char *ptr, int size, int nobj, FILE *fp) + * @brief Write to file. + * @param ptr - source buffer + * @param size - object size in bytes + * @param nobj - # of objects to write + * @param fp - pointer to FILE + * @return # of objects written + */ +fwrite(ptr, size, nobj, fp) +unsigned char *ptr; +int size, nobj; +FILE *fp; +{ + int cobj, csize; + + for(cobj = 0; cobj != nobj; ++cobj) + { + for(csize = 0; csize != size; ++csize) + { + if(fputc(*ptr++, fp) == EOF) + return cobj; + } + } + + return cobj; +} + +#endif + +#ifdef CC_FGETS + +/** + * @fn char *fgets(char *str, int size, FILE *fp) + * @brief Read string from file. + * @param str - destination buffer + * @param size - # of max. characters to read + * @param fp - pointer to FILE + * @return address of 'str' on success, else NULL + */ +fgets(str, size, fp) +char *str; int size; FILE *fp; +{ + int c; + char *cs; + + cs = str; + + while(--size) + { + if((c = fgetc(fp)) == EOF) + break; + + if((*cs++ = c) == '\n') + break; + } + + if(c == EOF && cs == str) + return NULL; + + *cs = '\0'; + + return str; +} + +#endif + +#ifdef CC_FPUTS + +/** + * @fn int fputs(char *str, FILE *fp) + * @brief Write string to file. + * @param str - source buffer + * @param fp - pointer to FILE + * @return # of characters written on success, else EOF + */ +fputs(str, fp) +char *str; FILE *fp; +{ + int i; + + for(i = 0; *str; ++i) { + if(fputc(*str++, fp) == EOF) + return EOF; + } + + return i; +} + +#endif + +/** + * @fn int remove(char *fname) + * @brief Delete a file. + * @param fname - filename + * @return 0 on success, else != 0 + */ +remove(fname) +char *fname; +{ + BYTE *fc; + int code; + + code = 0xFF; /* Error by default */ + + if((fc = malloc(_FCB_SIZE))) + { + if(!_MAKEFCB(fname, fc)) + { + bdos_hl(BF_DMA, 0x80); + + code = _FILEOP(BF_DELETE, fc); + } + + free(fc); + } + + return code != 0xFF ? 0 : -1; +} + +#ifdef CC_FCX +#define _REN_BUF_SIZE 54 /* 37 + 17 */ +#define _REN_OFFSET 17 +#else +#define _REN_BUF_SIZE 52 /* 36 + 16 */ +#define _REN_OFFSET 16 +#endif + +/** + * @fn int rename(char *oldname, char *newname) + * @brief Rename a file. + * @param oldname - old filename + * @param newname - new filename + * @return 0 on success, else != 0 + */ +rename(oldname, newname) +char *oldname, *newname; +{ + BYTE *fcb; + int code; + + code = 0xFF; /* Error by default */ + + if((fcb = malloc(_REN_BUF_SIZE))) + { + if(!_MAKEFCB(oldname, fcb)) + { + if(!_MAKEFCB(newname, fcb + _REN_OFFSET)) + { + /* FIXME : drive + user unchecked -- must match! */ +#ifdef CC_FCX + memcpy(fcb + 17, fcb + 18, 16); +#endif + bdos_hl(BF_DMA, 0x0080); + + code = _FILEOP(BF_RENAME, fcb); + } + } + + free(fcb); + } + + return code != 0xFF ? 0 : -1; +} + +#undef _REN_BUF_SIZE +#undef _REN_OFFSET + +#ifdef CC_FSIZE + +#ifdef CC_FCX +#define _FSZ_RR 34 +#else +#define _FSZ_RR 33 +#endif + +/** + * @fn int fsize(char *fname) + * @brief Get the file size in units of 128 bytes. + * @param fname - filename + * @return file size on success, else -1 + */ +fsize(fname) +char *fname; +{ + BYTE *fc; + int recs; + + recs = -1; /* Error by default */ + + if((fc = malloc(_FCB_SIZE))) + { + if(!_MAKEFCB(fname, fc)) + { + bdos_hl(BF_DMA, 0x80); + + /* + BDOS fn. 35 - Compute file size: + - CP/M v2 returns nothing about success / error. + - CP/M v3 returns success / error codes in the A register. + + So, for compatibility, first search the file and if it exists, + we assume we will get the file size. + */ + + if(_FILEOP(BF_FIND1ST, fc) != 0xFF) + { + _FILEOP(BF_FSIZE, fc); + + recs = fc[_FSZ_RR] + (fc[_FSZ_RR + 1] << 8); + } + } + + free(fc); + } + + return recs; +} + +#undef _FSZ_RR + +#endif + +// int xfnamb(char *fn) : check if fn is an ambiguous filename -- return 1 if true, else 0. +xfnamb(fn) +char *fn; +{ +#ifdef STRING_H + if(strchr(fn, '?') || strchr(fn, '*')) + return 1; +#else + while(*fn) + { + if(*fn == '?' || *fn == '*') + return 1; + + ++fn; + } +#endif + + return 0; +} + +// Cleaning +#undef _XF_READ +#undef _XF_WRITE +#undef _XF_BIN +#undef _XF_EOF +#undef _XF_ERR + +#undef _XF_IMOD +#undef _XF_IPOS +#undef _XF_IBUF +#undef _XF_IFCX + +#undef _XF_ISIZ +#undef _XF_IRND + +#undef _FILEOP +#undef _MAKEFCB +#undef _FCB_SIZE + +#endif + + \ No newline at end of file diff --git a/disks/images/d/fprintf.h b/disks/images/d/fprintf.h new file mode 100644 index 0000000..a3f670e --- /dev/null +++ b/disks/images/d/fprintf.h @@ -0,0 +1,115 @@ +/** + * @file fprintf.h + * @brief Library for fprintf() function. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Implementation of fprintf() function, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 23 Jan 2001 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 25 Aug 2016 : Documented. GPL v3. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef FPRINTF_H + +#define FPRINTF_H + +// Dependencies +// ------------ + +#ifndef XPRINTF_H + #include +#endif + +#ifndef FILEIO_H + #include +#endif + +/** + * @fn int fprintf(FILE *fp, char *fmt, arg1, arg2, ...) + * @brief Formatted output to a file. + * + * See the documentation for xprintf.h to learn about the string format. + * + * @param fp - file pointer + * @param fmt - string format + * @param arg1 - argument #1 + * @param arg? - argument #? + * @return number or characters written, or -1 on failure. + */ +#asm + +fprintf: + ADD HL,HL + ADD HL,SP ;HL=Adr. fmt + + LD DE,xfpfout + PUSH DE + LD DE,xfpfend + PUSH DE + PUSH HL + + INC HL + INC HL ;HL=Adr. *fp + LD A,(HL) + INC HL + LD H,(HL) + LD L,A + LD (xfpfout+2),HL + + CALL xprintf + + POP BC + POP BC + POP BC + + RET +#endasm + +// int xfpfout(char ch) : output ch to a file; return 0 on success, !=0 on failure. + +#asm + +xfpfout: + PUSH HL ;Char. + LD HL,0 ;*FP + PUSH HL + + CALL fputc + + POP BC + POP BC + + EX DE,HL + LD HL,0 + + LD A,255 + CP D + RET NZ + CP E + RET NZ + + INC L + RET +#endasm + +// void xfpfend(void) : end formatted output; currently does nothing. + +#asm + +xfpfend: + RET + +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/d/mem.h b/disks/images/d/mem.h new file mode 100644 index 0000000..72a1df2 --- /dev/null +++ b/disks/images/d/mem.h @@ -0,0 +1,139 @@ +/** + * @file mem.h + * @brief Memory functions. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Memory functions, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 25 Oct 2000 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 25 Aug 2016 : Documented. GPL v3. + * - 25 Dec 2018 : Optimize memset() for speed. + * + * Copyright (c) 1999-2018 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef MEM_H + +#define MEM_H + +/** + * @fn char *memset(char *dst, char data, int count) + * @brief Fill 'count' bytes with 'data' into 'dst'. + * @param dst - destination + * @param data - fill byte + * @param count - how many + * @return pointer to 'dst' + */ +#asm + +memset: + POP AF + POP BC + POP DE + POP HL + PUSH HL + PUSH DE + PUSH BC + PUSH AF + + LD A,B + OR C + RET Z + + PUSH HL + + LD (HL),E + LD D,H + LD E,L + INC DE + DEC BC + LDIR + + POP HL + RET +#endasm + +/** + * @fn char *memcpy(char *dst, char *src, int count) + * @brief Copy 'count' bytes from 'src' to 'dst'. + * @param dst - destination + * @param src - source + * @param count - how many + * @return pointer to 'dst' + */ +#asm + +memcpy: + POP AF + POP BC + POP HL + POP DE + PUSH DE + PUSH HL + PUSH BC + PUSH AF + PUSH DE + LD A,B + OR C + JR Z,memcpy2 + LDIR +memcpy2 + POP HL + RET +#endasm + +/** + * @fn int memcmp(char *mem1, char *mem2, int count) + * @brief Compare 'count' bytes. + * @param mem1 - pointer + * @param mem2 - pointer + * @param count - how many + * @return <0 on mem1 < mem2; =0 on mem1 == mem2; >0 on mem1 > mem2 + */ +#asm + +memcmp + POP AF + POP BC + POP HL + POP DE + PUSH DE + PUSH HL + PUSH BC + PUSH AF + +memcmp1 + LD A,C + OR B + JR Z,memcmp2 + + DEC BC + + LD A,(DE) + CP (HL) + INC DE + INC HL + JR Z,memcmp1 + +memcmp2 + LD HL,0 + RET Z + JR NC,memcmp3 + DEC HL + RET + +memcmp3 + INC L + RET +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/d/mescc.h b/disks/images/d/mescc.h new file mode 100644 index 0000000..bb730cc --- /dev/null +++ b/disks/images/d/mescc.h @@ -0,0 +1,945 @@ +/** + * @file mescc.h + * @brief Runtime library. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Runtime library for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * This library file must be included first! + * + * Need following EQU's (generated by the compiler): + * - ccSTACKSIZE : Stack size in bytes. + * + * Supports following #defs: + * - #define CC_STDIO Support for stdin, stdout & stderr. + * - #define CC_REDIR Support for stdin & stdout redirection + * in command line (needs CC_STDIO). + * - #define CC_NO_MUL To exclude MULTIPLICATION code. + * - #define CC_NO_DIV To exclude DIVISION & MODULUS code. + * - #define CC_NO_SWITCH To exclude SWITCH code. + * - #define CC_NO_ARGS To exclude ARGC & ARGV code. + * - #define CC_NO_ORG To exclude ORG 0100H code. + * + * Sets the following #defines: + * + * - BYTE + * - WORD + * - BOOL + * - NULL + * - TRUE + * - FALSE + * - SIZEOF_CHAR + * - SIZEOF_INT + * - SIZEOF_PTR + * + * Revisions: + * - 16 Jan 2001 : Last revision. + * - 23 Mar 2007 : Expand ccladr1 and ccladr2 for more speed. + * - 16 Apr 2007 : GPL'd. + * - 26 Aug 2012 : Added standard defs. + * - 08 Dec 2014 : Minor changes. + * - 09 Dec 2014 : Added support for stdin, stdout & stderr with CC_STDIO. + * - 12 Dec 2014 : Added support for stdin & stdout redirection in command line with CC_REDIR. + * - 16 Jan 2015 : Added SIZEOF_??? definitions. + * - 16 Feb 2015 : Modified / added code in cctmpw, ccxpb2, ccxpb, ccxpb3, ccxpw2 + * ccxpw, ccxpw3, ccladr2sv, ccladr2, ccladr1sv, ccladr1, + * to avoid use of IX register. + * - 20 Mar 2015 : Added support for CC_NO_MUL, CC_NO_DIV, CC_NO_SWITCH, CC_NO_ARGS. + * - 12 Apr 2015 : Removed ccDEFARGS code. + * - 14 Jul 2015 : Modified code for << and >>, because a shift of 0 positions, + * resulted in a wrong value (they assumed a shift > 0) - ie: 128 >> 0 resulted in 0. + * - 19 Oct 2015 : Improved multiplication algorithm (ccmul & ccumul). + * - 05 Nov 2015 : Modified ccsxt. + * - 30 Nov 2015 : Added support for atexit(). + * - 24 Jan 2016 : Added support for CC_NO_ORG. + * - 10 Dec 2016 : Documented. GPL v3. + * - 14 Sep 2021 : Bugfix in cccmp. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ + +/* STANDARD DEFs + ------------- +*/ + +#define BYTE unsigned char +#define WORD unsigned int +#define BOOL char +#define NULL 0 +#define TRUE 1 +#define FALSE 0 + +#define SIZEOF_CHAR 1 /* [unsigned] char */ +#define SIZEOF_INT 2 /* [unsigned] int */ +#define SIZEOF_PTR 2 /* pointer */ + +/* RUNTIME CODE + ------------ +*/ + +#ifndef CC_NO_ORG + +#asm +; Start at TPA + + ORG 0100H + +#endasm + +#endif + +#asm +; Runtime address + +ccrtadr: + +; Set stack under BDOS (xx00h) + + LD HL,(6) + LD L,0 + LD SP,HL + +; Leave space for stack and init. variables + + LD DE,ccSTACKSIZE + OR A + SBC HL,DE + DEC HL + LD (ccfreelast),HL + LD DE,ccfreemem + LD (ccfreefirst),DE + OR A + SBC HL,DE + INC HL + LD (ccfreebytes),HL + JR NC,ccargs + +; Error, no memory for stack + + LD C,9 + LD DE,ccerrstack + CALL 5 + JP 0 + +ccerrstack + DEFB 'Runtime Error - No stack$' + +; Setup command line arguments + +ccargs + +#endasm + +#ifndef CC_NO_ARGS + +#asm +; Copy command line + + LD HL,81H + LD DE,ccmdbuf + LD BC,127 + LDIR + + LD A,(80H) + LD B,0 + LD C,A + LD HL,ccmdbuf + ADD HL,BC + LD (HL),0 + +; Init. argc & argv + + LD DE,cchptr + LD HL,ccmdbuf - 1 + LD BC,1 +ccspc + INC HL + LD A,(HL) + OR A + JR Z,ccarg + CP ' ' + JR Z,ccspc + LD A,L + LD (DE),A + LD A,H + INC DE + LD (DE),A + INC DE + INC C +ccpar + INC HL + LD A,(HL) + OR A + JR Z,ccarg + CP ' ' + JR NZ,ccpar + LD (HL),0 + JR ccspc + +ccarg + LD HL,cchptr - 2 + PUSH BC ;argc + PUSH HL ;argv +#endasm + +#endif + +#ifdef CC_REDIR + +#asm + CALL redir ;FIXME - Check errors + POP DE + POP BC + PUSH HL ;argc + PUSH DE ;argv +#endasm + +#endif + +#asm + +; Execute program + + CALL main +#endasm + +/** + * @fn void exit(int code) + * @brief Exit to CP/M. + * + * FixMe: Return code is lost! + */ +#asm + +; Exit to CP/M + +exit + NOP ; Patch for atexit() -- 3 bytes. + NOP + NOP +#endasm + +#ifdef CC_STDIO + +BYTE *stdin, *stdout, *stderr; /* Sorry, no available FILE here */ + +#asm + LD HL,(stdin) + CALL ccflush + LD HL,(stdout) + CALL ccflush + + JP 0 + +ccflush + LD A,H + OR L + RET Z + PUSH HL + CALL fclose + POP BC + RET +#endasm + +#else + +#asm + JP 0 +#endasm + +#endif + +#asm + +; Variables for memory functions + +ccfreefirst + DEFW 0 ;Adr. first free byte +ccfreelast + DEFW 0 ;Adr. last free byte +ccfreebytes + DEFW 0 ;Number of free bytes + +#endasm + +#ifndef CC_NO_ARGS + +#asm +; Variables for command line arguments + +ccmdbuf + DEFS 128 ;Command line buffer + + DEFW ccNULL ;Pointers table for argv +cchptr + DEFW ccNULL,ccNULL,ccNULL,ccNULL,ccNULL + DEFW ccNULL,ccNULL,ccNULL,ccNULL,ccNULL + DEFW ccNULL,ccNULL,ccNULL,ccNULL,ccNULL + DEFW ccNULL,ccNULL,ccNULL,ccNULL,ccNULL + DEFW ccNULL,ccNULL,ccNULL,ccNULL,ccNULL + +ccNULL + DEFB 0 ;Null pointer +#endasm + +#endif + +#asm + +; Basic routines + +; Call formats to access locals: +; +; Format 1: CALL routine +; DEFB SpOffset +; +; Format 2: CALL routine +; DEFW SpOffset + +; HL = unsigned char from local (format 2) + +ccxgb2 + CALL ccladr2 + JR ccxgb3 + +; HL = unsigned char from local (format 1) + +ccxgb + CALL ccladr1 +ccxgb3 + LD L,(HL) + LD H,0 + RET + +; HL = signed char from local (format 2) + +ccxgc2 + CALL ccladr2 + JR ccgc + +; HL = signed char from local (format 1) + +ccxgc + CALL ccladr1 + +; HL = signed char from (HL) + +ccgc + LD A,(HL) + +; HL = signed char from A + +ccsxt + LD L,A + RLCA + SBC A + LD H,A + RET + +; LD H,0 +; LD L,A +; AND 128 +; RET Z +; DEC H +; RET + +; HL = word from local (format 2) + +ccxgw2 + CALL ccladr2 + JR ccgw + +; HL = word from local (format 1) + +ccxgw + CALL ccladr1 + +; HL = word from (HL) + +ccgw + LD A,(HL) + INC HL + LD H,(HL) + LD L,A + RET + +; char local = HL (format 2) + +ccxpb2 + CALL ccladr2sv + JR ccxpb3 + +; char local = HL (format 1) + +ccxpb + CALL ccladr1sv +ccxpb3 + LD DE,(cctmpw) + LD (HL),E + EX DE,HL + RET + +; int/ptr local = HL (format 2) + +ccxpw2 + CALL ccladr2sv + JR ccxpw3 + +; int/ptr local = HL (format 1) + +ccxpw + CALL ccladr1sv +ccxpw3 + LD DE,(cctmpw) + LD (HL),E + INC HL + LD (HL),D + EX DE,HL + RET + +; Copy 1 word from HL to (DE) + +ccpw + LD A,L + LD (DE),A + INC DE + LD A,H + LD (DE),A + RET + +; Calc. local adress + +cctmpw DEFW 0 + +ccladr2sv + LD (cctmpw),HL + +ccladr2 + POP DE + POP HL + LD C,(HL) + INC HL + LD B,(HL) + INC HL + PUSH HL + PUSH DE + LD HL,4 + ADD HL,BC + ADD HL,SP + RET + +ccladr1sv + LD (cctmpw),HL + +ccladr1 + POP DE + POP HL + LD B,0 + LD C,(HL) + INC HL + PUSH HL + PUSH DE + LD HL,4 + ADD HL,BC + ADD HL,SP + RET + +; OR HL = HL | DE + +ccor + LD A,L + OR E + LD L,A + LD A,H + OR D + LD H,A + RET + +; XOR HL = HL ^ DE + +ccxor + LD A,L + XOR E + LD L,A + LD A,H + XOR D + LD H,A + RET + +; AND HL = HL & DE + +ccand + LD A,L + AND E + LD L,A + LD A,H + AND D + LD H,A + RET + +; LOGIC OR HL = DE || HL + +cclgor + LD A,H + OR L + OR D + OR E + LD L,A + RET + + ;LD A,H + ;OR L + ;RET NZ + ;LD A,D + ;OR E + ;RET Z + ;INC L + ;RET + +; LOGIC AND HL = DE && HL + +cclgand + LD A,H + OR L + RET Z + LD A,D + OR E + RET NZ + JP ccfalse + +; HL = HL == DE + +cceq + OR A + SBC HL,DE + +; LOGIC NOT HL = !HL + +cclgnot + LD A,H + OR L + JP NZ,ccfalse + INC L + RET + +; HL = HL != DE + +ccne + OR A + SBC HL,DE + RET + +; HL = DE > HL (SIGNED) + +ccgt + EX DE,HL + +; HL = DE < HL (SIGNED) + +cclt + CALL cccmp + RET C + DEC L + RET + +; HL = DE <= HL (SIGNED) + +ccle + CALL cccmp + RET Z + RET C + DEC L + RET + +; HL = DE >= HL (SIGNED) + +ccge + CALL cccmp + RET NC + DEC L + RET + +; Compare DE with HL, and return: (SIGNED) +; +; CARRY if DE < HL +; ZERO if DE == HL +; HL = 1 + +cccmp + LD A,H + ADD 80H + LD B,A + LD A,D + ADD 80H + CP B + JR NZ,cccmp1 + LD A,E + CP L + +cccmp1 + LD HL,1 + RET + +; HL = DE <= HL (UNSIGNED) + +ccule + CALL ccucmp + RET Z + RET C + DEC L + RET + +; HL = DE >= HL (UNSIGNED) + +ccuge + CALL ccucmp + RET NC + DEC L + RET + +; HL = DE > HL (UNSIGNED) + +ccugt + EX DE,HL + +; HL = DE < HL (UNSIGNED) + +ccult + CALL ccucmp + RET C + DEC L + RET + +; Compare DE with HL, and return: (UNSIGNED) +; +; CARRY if DE < HL +; ZERO if DE == HL +; HL = 1 + +ccucmp + LD A,D + CP H + JR NZ,ccucmp1 + LD A,E + CP L + +ccucmp1 + LD HL,1 + RET + +; HL = DE >> HL (UNSIGNED) + +ccuasr + EX DE,HL + LD A,E +ccuasr1 + OR A + RET Z + DEC A + SRL H + RR L + JR ccuasr1 + +; HL = DE >> HL (ARITMETIC) + +ccasr + EX DE,HL + LD A,E +ccasr1 + OR A + RET Z + DEC A + SRA H + RR L + JR ccasr1 + +; HL = DE << HL (UNSIGNED) + +ccuasl + +; HL = DE << HL (ARITMETIC) + +ccasl + EX DE,HL + LD A,E +ccasl1 + OR A + RET Z + DEC A + ADD HL,HL + JR ccasl1 + +; HL = DE - HL + +ccsub + EX DE,HL + OR A + SBC HL,DE + RET + +; HL = ~HL (1 COMPLEMENT) + +cccom + LD A,H + CPL + LD H,A + LD A,L + CPL + LD L,A + RET + +; HL = -HL (2 COMPLEMENT) + +ccneg + LD A,H + CPL + LD H,A + LD A,L + CPL + LD L,A + INC HL + RET + +#endasm + +#ifndef CC_NO_MUL + +#asm + +; HL = DE * HL (UNSIGNED) + +ccumul + +; HL = DE * HL (SIGNED) + +ccmul + LD A,H + LD C,L + LD HL,0 + LD B,16 +ccmul0 + ADD HL,HL + SLA C + RL A + JR NC,ccmul1 + ADD HL,DE +ccmul1 + DJNZ ccmul0 + RET + +#endasm + +#endif + +#ifndef CC_NO_DIV + +#asm + +; HL = DE % HL (SIGNED) + +ccmod + CALL ccdiv + EX DE,HL + RET + +; HL = DE / HL (SIGNED) +; DE = DE % HL (SIGNED) + +ccdiv + LD B,H + LD C,L + LD A,D + XOR B + PUSH AF + LD A,D + OR A + CALL M,ccdivdeneg + LD A,B + OR A + + JP P,ccdiv0 + + LD A,B + CPL + LD B,A + LD A,C + CPL + LD C,A + INC BC + +ccdiv0 + EX DE,HL + LD DE,0 + LD A,16 + +ccdiv1 + PUSH AF + + ADD HL,HL + + RL E + RL D + LD A,D + OR E + + JR Z,ccdiv2 + + LD A,E + SUB C + LD A,D + SBC B + + JP M,ccdiv2 + LD A,L + OR 1 + LD L,A + LD A,E + SUB C + LD E,A + LD A,D + SBC B + LD D,A + +ccdiv2 + POP AF + DEC A + JR NZ,ccdiv1 + POP AF + RET P + + CALL ccneg + +ccdivdeneg + LD A,D + CPL + LD D,A + LD A,E + CPL + LD E,A + INC DE + RET + +; HL = DE % HL (UNSIGNED) + +ccumod + CALL ccudiv + EX DE,HL + RET + +; HL = DE / HL (UNSIGNED) +; DE = DE % HL (UNSIGNED) + +ccudiv + LD (ccudiv_tmp),HL + LD HL,ccudiv_cnt + LD (HL),17 + LD BC,0 + PUSH BC + XOR A + +ccudiv0 + RL E + RL D + DEC (HL) + POP HL + JR Z,ccudiv2 + LD A,0 + ADC 0 + ADD HL,HL + LD B,H + ADD L + LD HL,(ccudiv_tmp) + SUB L + LD C,A + LD A,B + SBC H + LD B,A + PUSH BC + JR NC,ccudiv1 + ADD HL,BC + EX (SP),HL + +ccudiv1 + LD HL,ccudiv_cnt + CCF + JR ccudiv0 + +ccudiv2 + EX DE,HL + RET + +ccudiv_tmp + DEFW 0 +ccudiv_cnt + DEFB 0 + +#endasm + +#endif + +#ifndef CC_NO_SWITCH + +#asm + +; Switch, on entry: +; +; DE = Table address +; HL = Where to go if value was not found in table +; B = Number of entries in table + +ccswtch + EX (SP),HL + EX DE,HL + +ccswch1 + LD A,E + CP (HL) + INC HL + JR NZ,ccswch2 + LD A,D + CP (HL) + JR NZ,ccswch2 + INC HL + LD E,(HL) + INC HL + LD D,(HL) + EX DE,HL + POP BC + JP (HL) + +ccswch2 + INC HL + INC HL + INC HL + DJNZ ccswch1 + EX (SP),HL + POP BC + JP (HL) + +#endasm + +#endif + +#asm + +; HL = TRUE + +cctrue + LD L,1 + RET + +; HL = FALSE + +ccfalse + LD HL,0 + RET + +#endasm + + \ No newline at end of file diff --git a/disks/images/d/printf.h b/disks/images/d/printf.h new file mode 100644 index 0000000..60e9117 --- /dev/null +++ b/disks/images/d/printf.h @@ -0,0 +1,94 @@ +/** + * @file printf.h + * @brief Library for printf() function. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Implementation of printf() function, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 20 Oct 2000 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 25 Aug 2016 : Documented. GPL v3. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef PRINTF_H + +#define PRINTF_H + +// Dependencies +// ------------ + +#ifndef XPRINTF_H + #include +#endif + +#ifndef CONIO_H + #include +#endif + +/** + * @fn int printf(char *fmt, arg1, arg2, ...) + * @brief Formatted output to stdout (or console). + * + * See the documentation for xprintf.h to learn about the string format. + * + * @param fmt - string format + * @param arg1 - argument #1 + * @param arg? - argument #? + * @return number or characters written, or -1 on failure (currently always #). + */ +#asm + +printf: + ADD HL,HL + ADD HL,SP + INC HL + INC HL ;HL=Adr. fmt + + LD DE,xpfout + PUSH DE + LD DE,xpfend + PUSH DE + PUSH HL + + CALL xprintf + + POP BC + POP BC + POP BC + + RET +#endasm + +// int xpfout(char ch) : output ch to stdout; return 0 on success, !=0 on failure (currently always returns 0). + +#asm + +xpfout: + PUSH HL + CALL putchar + POP BC + LD HL,0 + RET + +#endasm + +// void xpfend(void) : end formatted output; currently does nothing. + +#asm + +xpfend: + RET + +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/d/qsort.h b/disks/images/d/qsort.h new file mode 100644 index 0000000..5bd98ec --- /dev/null +++ b/disks/images/d/qsort.h @@ -0,0 +1,68 @@ +/** + * @file qsort.h + * @brief Sort function. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * This library implements a sort function of general use, + * which uses the bubble sort algorithm, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 30 Nov 2015 : First version (bubble sort). + * - 15 Aug 2016 : Documented. GPL v3. + * + * Copyright (c) 2015-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef QSORT_H + +#define QSORT_H + +/** + * @fn void qsort(void *base, size_t items, size_t size, int (*comp)(const void *, const void*)) + * @brief Sort an array of elements. + * + * Sort an array of elements into ascending order. + * + * The comparison function must return: + * - <0 on elem1 < elem2 + * - =0 on elem1 == elem2 + * - >0 on elem1 > elem2 + * + * @param base - address of first element + * @param items - number of elements in the array + * @param size - size in bytes of each element + * @param comp - comparison function + */ +qsort(base, items, size, comp) +BYTE *base; int items, size; WORD comp; +{ + int i, j, k; + BYTE *pi, *pj, t; + + for(i = 0; i < items; ++i) + { + for(j = i + 1; j < items; ++j) + { + pi = base + i * size; + pj = base + j * size; + + if(comp(pi, pj) > 0) + { + for(k = 0; k < size; ++k) { + t = *pi; + *pi++ = *pj; + *pj++ = t; + } + } + } + } +} + +#endif + + \ No newline at end of file diff --git a/disks/images/d/rand.h b/disks/images/d/rand.h new file mode 100644 index 0000000..53307ce --- /dev/null +++ b/disks/images/d/rand.h @@ -0,0 +1,57 @@ +/** + * @file rand.h + * @brief Pseudo-random number generation. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Pseudo-random number generation, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 18 Mar 2015 : 1st version. + * - 23 Mar 2015 : Trying to improve rand(). + * - 15 Aug 2016 : Documented. GPL v3. + * + * Defined macros: + * - RAND_MAX + * + * Copyright (c) 2015-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef RAND_H + +#define RAND_H + +#define RAND_MAX 32767 + +int xs_seed = 1; // Initial value for seed + +/** + * @fn int rand(void) + * @brief Generate a pseudo-random value between 0 and RAND_MAX (both included). + * @return value + */ +rand() +{ + // return (xs_seed = ((xs_seed * 3) + 1) & 0x7FFF); + + return (xs_seed = (((xs_seed << 1) + xs_seed) + 1) & 0x7FFF); +} + +/** + * @fn void srand(unsigned int seed) + * @brief Seeds the pseudo-random number generator used by rand(). + * @param seed - value + */ +srand(seed) +unsigned int seed; +{ + xs_seed = seed; +} + +#endif + + \ No newline at end of file diff --git a/disks/images/d/redir.h b/disks/images/d/redir.h new file mode 100644 index 0000000..fbc3e6f --- /dev/null +++ b/disks/images/d/redir.h @@ -0,0 +1,107 @@ +/** + * @file redir.h + * @brief I/O redirection in command line. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Support library for I/O redirection in command line, + * for MESCC (Mike's Enhanced Small C Compiler for Z80 & CP/M). + * + * Supported redirections: + * - echo < address.txt + * - echo 'Park Avenue, 234b' > address.txt + * - echo 'Call Elvis' >> todo.txt + * + * Revisions: + * - 08 Dec 2014 : 1st version. + * - 29 Nov 2016 : Support for '>>' redirection. Optimizations in NULL comparisons. + * - 07 Dec 2016 : GPL v3. + * + * Copyright (c) 2014-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef REDIR_H + +#define REDIR_H + +/** + * @fn int redir(int argc, char *argv[]) + * @brief Stdin & stdout redirection in command line. + * @param argc - number of arguments + * @param argv - array of arguments + * @return number of arguments after redirection parsing + */ +redir(argc, argv) +int argc, argv[]; +{ + int i, z; char *p; + char *fnin, *fnout; + FILE *fp; + +#ifdef CC_FOPEN_A + int append; +#endif + + fnin = fnout = NULL; + + for(i = 1; i < argc; ++i) + { + p = argv[i]; + +#ifdef CC_FOPEN_A + if(((*p == '<' || *p == '>') && !(p[1])) || (*p == '>' && p[1] == '>' && !(p[2]))) +#else + if((*p == '<' || *p == '>') && !(p[1])) +#endif + { + if(i + 1 == argc) + return -1; /* No filename */ + + if(*p == '<') + fnin = argv[i + 1]; + else + { + fnout = argv[i + 1]; + +#ifdef CC_FOPEN_A + append = p[1]; +#endif + } + + argc -= 2; + + for(z = i; z < argc; ++z) + argv[z] = argv[z + 2]; + --i; + } + } + + if(fnin) + { + if((fp = fopen(fnin, "r"))) + stdin = fp; + else + return -2; + } + + if(fnout) + { +#ifdef CC_FOPEN_A + if((fp = fopen(fnout, (append ? "a" : "w")))) +#else + if((fp = fopen(fnout, "w"))) +#endif + stdout = fp; + else + return -3; + } + + return argc; +} + +#endif + + \ No newline at end of file diff --git a/disks/images/d/setjmp.h b/disks/images/d/setjmp.h new file mode 100644 index 0000000..c02ef6d --- /dev/null +++ b/disks/images/d/setjmp.h @@ -0,0 +1,90 @@ +/** + * @file setjmp.h + * @brief Non-local jumps. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Non-local jumps functions, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Only one jmp_buf is allowed. + * + * Call to setjmp is performed as - ie: setjmp(env): + * LD HL,(env) + * PUSH HL + * CALL setjmp + * POP BC + * + * Call to longjmp is performed as - ie: longjmp(env, 1): + * + * LD HL,(env) + * PUSH HL + * LD HL,1 + * PUSH HL + * CALL longjmp + * POP BC + * POP BC + * + * Defined macros: + * - jmp_buf + * + * Revisions: + * - 21 Ago 2015 : Initial version. + * - 22 Ago 2015 : Changed jmp_buf from char to int. + * - 15 Ago 2016 : Documented. GPL v3. + * + * Copyright (c) 2015-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef SETJMP_H + +#define SETJMP_H + +#define jmp_buf int // Just something + +WORD setjmp_rt; // Return address +WORD setjmp_sp; // SP + +/** + * @fn int setjmp (jmp_buf env) + * @brief Save state information for later use of longjmp(). + * @param env - buffer for state data + * @return 0 from direct call, other values from a longjmp call + */ +#asm +setjmp + POP HL + LD (setjmp_rt), HL + LD (setjmp_sp), SP + PUSH HL + LD HL, 0 + RET +#endasm + +/** + * @fn void longjmp (jmp_buf env, int rv) + * @brief Resume execution after setjmp(). + * + * This function resumes the execution after setjmp(), restoring + * the previously stored state in env. + * + * @param env - buffer with state data + * @param rv - value to return; must be != 0 + * @return rv value + */ +#asm +longjmp + POP BC + POP HL + LD SP,(setjmp_sp) + LD DE,(setjmp_rt) + PUSH DE + RET +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/d/sprintf.h b/disks/images/d/sprintf.h new file mode 100644 index 0000000..00fa6a5 --- /dev/null +++ b/disks/images/d/sprintf.h @@ -0,0 +1,104 @@ +/** + * @file sprintf.h + * @brief Library for sprintf() function. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Implementation of sprintf() function, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 20 Oct 2000 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 14 Apr 2015 : Ammended a bad closed comment. + * - 25 Aug 2016 : Documented. GPL v3. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef SPRINTF_H + +#define SPRINTF_H + +// Dependencies +// ------------ + +#ifndef XPRINTF_H + #include +#endif + +/** + * @fn int sprintf(char *dst, char *fmt, arg1, arg2, ...) + * @brief Formatted output to memory. + * + * See the documentation for xprintf.h to learn about the string format. + * + * @param dst - destination + * @param fmt - string format + * @param arg1 - argument #1 + * @param arg? - argument #? + * @return number or characters written, or -1 on failure (currently always #). + */ +#asm + +sprintf: + ADD HL,HL + ADD HL,SP ;HL=Adr. fmt + + LD DE,xspfout + PUSH DE + LD DE,xspfend + PUSH DE + PUSH HL + + INC HL + INC HL ;HL=Adr. dst + LD A,(HL) + INC HL + LD H,(HL) + LD L,A + LD (xspfout+2),HL + + CALL xprintf + + POP BC + POP BC + POP BC + + RET +#endasm + +// int xspfout(char ch) : output ch to memory; return 0 on success, !=0 on failure (currently always returns 0). + +#asm + +xspfout: + LD A,L + LD HL,0 ;Adr. + LD (HL),A + + INC HL + LD (xspfout+2),HL + + LD HL,0 + + RET +#endasm + +// void xspfend(void) : end formatted output; writes a trailing zero byte. + +#asm + +xspfend: + LD HL,(xspfout+2) + LD (HL),0 + RET + +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/d/stdbool.h b/disks/images/d/stdbool.h new file mode 100644 index 0000000..a3ca14b --- /dev/null +++ b/disks/images/d/stdbool.h @@ -0,0 +1,38 @@ +/** + * @file stdbool.h + * @brief Boolean type and values. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Boolean type and values for MESCC (Mike's Enhanced Small C Compiler + * for Z80 & CP/M). + * + * Defined macros: + * - bool + * - true + * - false + * + * Revisions: + * - 13 May 2016 : 1st version. + * + * Notes: + * - In standard / ISO C, bool type is _Bool, not int. + * - ISO C defines bool_true_false_are_defined = 1. + * + * Copyright (c) 2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef STDBOOL_H + +#define STDBOOL_H + +#define bool int +#define true 1 +#define false 0 + +#endif + + \ No newline at end of file diff --git a/disks/images/d/string.h b/disks/images/d/string.h new file mode 100644 index 0000000..0cca902 --- /dev/null +++ b/disks/images/d/string.h @@ -0,0 +1,249 @@ +/** + * @file string.h + * @brief String functions. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * String functions, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 19 Mar 2001 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 15 Aug 2016 : Documented. GPL v3. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef STRING_H + +#define STRING_H + +/** + * @fn int strlen(char *str) + * @brief Return string length. + * @param str - string + * @return length in characters + */ +#asm +strlen: + LD D,H + LD E,L + LD BC,0FFFFH + XOR A + CPIR + OR A + SBC HL,DE + DEC HL + RET +#endasm + +/** + * @fn char *strcpy(char *dst, char *src) + * @brief Copy string. + * @param dst - destination string + * @param src - source string + * @return pointer to dst + */ +#asm +strcpy: + POP BC + POP HL + POP DE + PUSH DE + PUSH HL + PUSH BC + + PUSH DE + +strcpy2: + LD A,(HL) + LD (DE),A + INC HL + INC DE + OR A + JR NZ,strcpy2 + POP HL + RET +#endasm + +/** + * @fn char *strcat(char *dst, char *src) + * @brief Copy string at the end of another string. + * @param dst - destination string + * @param src - source string + * @return pointer to dst + */ +#asm +strcat: + POP BC + POP HL + POP DE + PUSH DE + PUSH HL + PUSH BC + + PUSH DE + +strcat2 + LD A,(DE) + OR A + JR Z,strcpy2 + INC DE + JR strcat2 +#endasm + +/** + * @fn int strcmp(char *str1, char *str2) + * @brief Compare two strings. + * @param str1 - a string + * @param str2 - a string + * @return <0 on str1 < str2; =0 on str1 == str2; >0 on str1 > str2 + */ +#asm +strcmp + POP BC + POP HL + POP DE + PUSH DE + PUSH HL + PUSH BC +strcmp1 + LD A,(DE) + CP (HL) + JR NZ,strcmp2 + + OR A + JR Z,strcmp2 + + INC DE + INC HL + JR strcmp1 + +strcmp2 + LD HL,0 + RET Z + JR NC,strcmp3 + DEC HL + RET +strcmp3 + INC L + RET +#endasm + +/** + * @fn char *strchr(char *str, char ch) + * @brief Search a character in a string. + * @param str - the string where to search + * @param ch - the character to find + * @return pointer to ch in the string, or NULL on failure + */ +#asm +strchr + POP BC + POP DE + POP HL + PUSH HL + PUSH DE + PUSH BC + + +strchr2 + LD A,(HL) + CP E + RET Z + + INC HL + OR A + JR NZ,strchr2 + + LD H,A + LD L,A + RET +#endasm + +/** + * @fn char *strupr(char *str) + * @brief Convert a string to upper case. + * @param str - a string + * @return pointer to str + */ +#asm +strupr + POP BC + POP HL + PUSH HL + PUSH BC + + PUSH HL + +strupr1 + LD A,(HL) + OR A + JR Z,strupr3 + + CP 'a' + JR C,strupr2 + CP 'z'+1 + JR NC,strupr2 + SUB 32 + LD (HL),A + +strupr2 + INC HL + JR strupr1 + +strupr3 + POP HL + RET +#endasm + +/** + * @fn int atoi(char *s) + * @brief Convert string to a integer. + * + * This function parses a string, interpreting its content as + * a decimal integer number, until the end of the string, or + * a non decimal digit: + * + * [+|-][[0..9]...][ZERO|NON_DECIMAL_DIGIT] + * + * Examples: + * - "-256" == -256 + * - "64" == 64 + * - "1024 bytes" == 1024 + * - "what?" == 0 + * + * @param s - a string + * @return integer value + */ +atoi(s) +char *s; +{ + int sign, val; + + if(*s == '+') + { + ++s; sign = 1; + } + else if(*s == '-') + { + ++s; sign = -1; + } + else + sign = 1; + + val=0; + + while(*s >= '0' && *s <= '9') + val = val * 10 + (*s++ - '0'); + + return val * sign; +} + +#endif + + \ No newline at end of file diff --git a/disks/images/d/xprintf.h b/disks/images/d/xprintf.h new file mode 100644 index 0000000..7184f24 --- /dev/null +++ b/disks/images/d/xprintf.h @@ -0,0 +1,373 @@ +/** + * @file xprintf.h + * @brief Support library for formatted output. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Support library for formatted output, + * for MESCC (Mike's Enhanced Small C Compiler for Z80 & CP/M). + * + * All functions with formatted output like printf(), fprintf() + * and sprintf() call some private functions in this order: + * - pf_sf() + * - pf_s() + * - pf_out() + * + * Revisions: + * - 19 Mar 2001 : Last revision. + * - 16 Apr 2007 : GPL'd. + * - 09 Dec 2016 : Documented. Optimized. GPL v3. + * - 02 Aug 2017 : Output '%%' as '%'. + * - 15 Sep 2021 : Output -32768 in pf_dec() as expected. + * + * Copyright (c) 1999-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef XPRINTF_H + +#define XPRINTF_H + +// Dependencies +// ------------ + +#ifndef STRING_H + #include +#endif + +// Private globals +// --------------- + +BYTE xpf_err; // True on error + +extern WORD xpf_out; // Output function +extern WORD xpf_end; // End function + +int xpf_fw; // Field width +BYTE xpf_fa; // Field alignment: 0=left, 1=right +BYTE xpf_fz; // True on zero filling + +int xpf_cnt; // # of characters sent + +/** + * @fn int xprintf(WORD funout, WORD funend, WORD adrpars) + * @brief Formatted output. + * + * This function performs formatted output. It is used + * by printf(), fprintf() and sprintf() functions. + * + * The format is indicated in the string as follows: + * + * %[-][0][w]t + * + * | - : Left align (default: right align). + * | 0 : Zero filling on right align. + * | w : Width for alignment. If the specified width + * | is lower than the argument length, output is + * | done without aligment. Care with sprinf()! + * | t : d = Signed decimal integer. + * | u = Unsigned decimal integer. + * | x = Hexadecimal integer. + * | s = String. + * | c = Character. + * + * The pair %% outputs a single %. + * + * @param funout - function to output a character + * @param funend - function to end output + * @param adrpars - arguments addresses + * @return # of characters sent on sucess, -1 on failure + */ +xprintf(funout, funend, adrpars) +WORD funout, funend; +WORD *adrpars; +{ + WORD *parg; // Pointer to arguments + char *pfor; // Pointer to formatted string + int ivalue; + char ch; + + // Setup + xpf_out = funout; + xpf_end = funend; + + pfor = *adrpars; + parg = --adrpars; + + xpf_err = xpf_cnt = 0; + + // Loop + while((ch = *pfor++)) + { + if(ch == '%') + { + // Character % + if(*pfor == '%') + { + pf_out(ch); + ++pfor; + + continue; + } + + // Align + if(*pfor == '-') + { + xpf_fa = 0; // Left align + ++pfor; + } + else + xpf_fa = 1; // Right align + + // Zero filling + if(*pfor == '0') + { + xpf_fz = 1; // Zero filling + ++pfor; + } + else + xpf_fz = 0; + + // Width + xpf_fw = 0; + + while(*pfor >= '0' && *pfor <= '9') + xpf_fw = xpf_fw * 10 + (*pfor++) - '0'; + + // Type + switch(ch = *pfor++) + { + case 'd' : + ivalue = *parg--; + pf_dec(ivalue); + break; + case 'u' : + ivalue = *parg--; + pf_udec(ivalue); + break; + case 'x' : + ivalue = *parg--; + pf_hex(ivalue); + break; + case 'c' : + pf_cf(*parg--); + break; + case 's' : + pf_sf(*parg--); + break; + case '\0' : + --pfor; + // P'abajo + default : + pf_out('!'); + break; + } + } + else + pf_out(ch); + + if(xpf_err) + break; + } + + pf_end(); + + return xpf_err ? -1 : xpf_cnt; +} + +// void pf_sf(char *s) : output formatted string. + +pf_sf(s) +char *s; +{ + int len; + char fill; + + if(xpf_fw) + { + if((len = strlen(s)) < xpf_fw) + { + xpf_fw = xpf_fw-len; + + if(xpf_fa) + { + // Left align + fill = (xpf_fz ? '0' : ' '); + + while(xpf_fw--) + pf_out(fill); + pf_s(s); + } + else + { + // Right align + pf_s(s); + + while(xpf_fw--) + pf_out(' '); + } + + return; + } + } + + pf_s(s); +} + +// void pf_cf(char c) : output formatted character. + +pf_cf(c) +char c; +{ + char tmp[2]; + + tmp[0] = c; tmp[1] = '\0'; + + pf_sf(tmp); +} + +unsigned char xpf_dst[7]; // Buffer for numbers +unsigned char *xpf_dpt; // Buffer pointer + +// void pf_dec(int i) : output signed decimal integer. + +pf_dec(i) +int i; +{ + if(i != -32768) + { + xpf_dpt = xpf_dst; + + if(i < 0) + { + *xpf_dpt++ = '-'; i = -i; + } + + pf_dec2(i); + + *xpf_dpt = '\0'; + } + else + { + strcpy(xpf_dst, "-32768"); + } + + pf_sf(xpf_dst); +} + +// void pf_dec2(int i) : helper for pf_dec(). + +pf_dec2(i) +int i; +{ + int n; + + if(n = i / 10) + pf_dec2(n); + + *xpf_dpt++ = i % 10 + '0'; +} + +// void pf_udec(unsigned int i) : output unsigned decimal integer. + +pf_udec(i) +unsigned i; +{ + xpf_dpt = xpf_dst; + + pf_udec2(i); + + *xpf_dpt = '\0'; + + pf_sf(xpf_dst); +} + +// void pf_udec2(unsigned int i) : helper for pf_udec(). + +pf_udec2(i) +unsigned i; +{ + unsigned n; + + if(n = i / 10) + pf_udec2(n); + + *xpf_dpt++ = i % 10 + '0'; +} + +// void pf_hex(unsigned int i) : output hexadecimal integer. + +pf_hex(i) +unsigned i; +{ + xpf_dpt = xpf_dst; + + pf_hex2(i); + + *xpf_dpt = '\0'; + + pf_sf(xpf_dst); +} + +// void pf_hex2(unsigned int i) : helper for pf_hex(). + +pf_hex2(i) +unsigned i; +{ + unsigned n; + + if(n = i / 16) + pf_hex2(n); + + i %= 16; + + *xpf_dpt++ = i < 10 ? '0' + i : 'A' + i - 10; +} + +// void pf_s(char *s) : output string. + +pf_s(s) +char *s; +{ + while(*s) + pf_out(*s++); +} + +// void pf_out(char c) : output character. + +#asm +pf_out: + PUSH HL + DEFB 0CDH +xpf_out: + DEFW 0 + POP BC + + EX DE,HL + + LD HL,(xpf_cnt) + INC HL + LD (xpf_cnt),HL + + LD A,D + OR E + RET Z +;; LD A,255 + LD (xpf_err),A + RET +#endasm + +// void pf_end(void) : end output. + +#asm +pf_end: + DEFB 0C3H +xpf_end: + DEFW 0 +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/d/z80.h b/disks/images/d/z80.h new file mode 100644 index 0000000..704c88c --- /dev/null +++ b/disks/images/d/z80.h @@ -0,0 +1,84 @@ +/** + * @file z80.h + * @brief Z80 specific functions. + * @author Miguel I. Garcia Lopez / FloppySoftware + * + * Functions for the Z80 cpu, for MESCC (Mike's Enhanced + * Small C Compiler for Z80 & CP/M). + * + * Revisions: + * - 13 Dec 2014 : 1st version. + * - 15 Aug 2016 : Documented. GPL v3. + * + * Copyright (c) 2014-2016 Miguel I. Garcia Lopez / FloppySoftware. + * + * Licensed under the GNU General Public License v3. + * + * http://www.floppysoftware.es + * floppysoftware@gmail.com + */ +#ifndef Z80_H + +#define Z80_H + +/** + * @fn int Z80in(int port) + * @brief Input a byte from a port. + * @return byte value + */ +#asm + +Z80in + LD C,L + IN A,(C) + LD H,0 + LD L,A + RET + +#endasm + +/** + * @fn void Z80out(int port, int value)) + * @brief Output a byte to a port. + */ +#asm + +Z80out + POP DE + POP HL + POP BC + PUSH BC + PUSH HL + PUSH DE + OUT (C),L + RET + +#endasm + +/** + * @fn void Z80di(void) + * @brief Disable interrupts. + */ +#asm + +Z80di + DI + RET + +#endasm + +/** + * @fn void Z80ei(void) + * @brief Enable interrupts. + */ +#asm + +Z80ei + EI + RET + +#endasm + +#endif + + \ No newline at end of file diff --git a/disks/images/e/anagram.com b/disks/images/e/anagram.com new file mode 100644 index 0000000..137145a Binary files /dev/null and b/disks/images/e/anagram.com differ diff --git a/disks/images/e/chapter1.doc b/disks/images/e/chapter1.doc new file mode 100644 index 0000000..1dcd69f --- /dev/null +++ b/disks/images/e/chapter1.doc @@ -0,0 +1 @@ +Thiу iу chapteт 1. diff --git a/disks/images/e/chapter2.doc b/disks/images/e/chapter2.doc new file mode 100644 index 0000000..0e2cd59 --- /dev/null +++ b/disks/images/e/chapter2.doc @@ -0,0 +1 @@ +Thiу iу chapteт 2. diff --git a/disks/images/e/chapter3.doc b/disks/images/e/chapter3.doc new file mode 100644 index 0000000..901c35c --- /dev/null +++ b/disks/images/e/chapter3.doc @@ -0,0 +1 @@ +Thiу iу chapteт 3. diff --git a/disks/images/e/diary.doc b/disks/images/e/diary.doc new file mode 100644 index 0000000..7da1084 --- /dev/null +++ b/disks/images/e/diary.doc @@ -0,0 +1,73 @@ + Triр Diary + +Septembeт 10 + +Whaф  б wonderfuм citщ Londoо isЎ We'vе beeо herе twп  dayу  anд Ќ +havе  beeо  literallщ runninз froн onе touт  tп  another®   We'rе Ќ +prettщ  exhausted¬ anд looл ferwarд tп explorinз б feч sightу  oо Ќ +ouт own. + +Thiу  morninз wе tooл б touт thaф begaо aф Trafalgaт Square®   Wе Ќ +tooл  thе  undergrounд (theiт worд foт subway©  froн  ouт  hotel® Ќ +We'vе  founд  thе  Londoо undergrounд tп bе б greaф  waщ  tп  geф Ќ +arounд  anд  lesу  costlщ thaо taxis® Wе haд  б  whirlwinд  touт Ќ +seeinз  Parliament¬  thе Toweт oж London¬ Toweт Bridge¬  anд  thе Ќ +changinз  oж thе guarд aф thе palace® Mosф impressivе  werе  thе Ќ +crowо jewelу iо thе Toweт oж London. + +Wе  havе beiо tourinз sп mucи thaф thiу afternoon¬ wе decideд  tп Ќ +dп  б  littlе  shopping®   Wе wenф tп onе  oж  thе  worlд  famouу Ќ +departmenф  stores® Thе enormitщ oж thе placе waу  overwhelming® Ќ +Wе founд wе werе morе comfortablе shoppinз inthе smalleт shops® Й Ќ +boughф б wooм scarж anд б teб set. + +Hydе Parл iу walkinз distancе froн ouт hotel® Sп aф thе enд oж б Ќ +hectiг day¬ wе decideд б strolм througи thе parл waу jusф whaф wе Ќ +needed®   Wе endeд uр sittinз oо б parл bencи foт abouф aо  hour® Ќ +Thе peoplе-watchinз waу fun® Alм thе classiг Englisи  characterу Ќ +passeд  beforе uу ­­ meо iо derbщ hatу anд piо  stripes¬  nannieу Ќ +pushinз babщ carriages¬ anд bobbieу amonз them. + +Ouт  morninз  touт  guidе saiд nп visiф  tп  Londoо  iу  completе Ќ +withouф  teб  aф thе Ritъ Hotel® Sп froн Hydе Park wе  walkeд  б Ќ +shorф distancе uр Picadillщ anд haд б mosф memorablе testime® Iф Ќ +waу  reallщ б smalм meal¬ witи hoф disheу beinз offereд witи  thе Ќ +usuaм farе oж scones¬ cookies¬ anд cakes. + +Afteт sufficientlщ stuffinз ourselveу aф teatime¬ wе walkeд б biф Ќ +more® Buф thе Londoо rusи houт goф tп uу sп wе decideд tп taлe iо Ќ +б moviе ratheт thaо trщ tп geф bacл tп thе hotel® Somehow¬  I'vе Ќ +gotteо enougи energщ tп writе thiу entrщ iо mщ triр diary®   I'vе Ќ +haд б trulщ wonderfuм daщ® Й lovе thiу city. + +Septembeт 12 + +I'vе  goф tп catcи uр oо twп dayу oж diarщ entries® Wе  wenф  tп Ќ +thе theateт lasф night¬ anд goф bacл tп thе hoteм toп latе tп  dп Ќ +anщ writing. + +Yesterday¬  wе tooл б breaл froн organizeд tours¬ anд decideд  tп Ќ +visiф  severaм  Londoо siteу oо ouт own® Iо thе morninз  wе  wenф  tп Ќ +Westminsteт  Abbey® Wе boughф б guidebooл anд tooл  б  leisurelщ Ќ +touт oж thе church® + +Iо thе afternoon¬ wе visiteд thе Britisи Museum® Thе placе iу sп Ќ +hugе  thaф iф iу impossiblе tп eveо thinл oж coverinз iф  alм  iо ЌЉonе afternoon® Buф wе tooл б quicл touт anд saч thе Magnб Carta¬ Ќ +thе Rosettб Stone¬ anд б hugе collectioо oж originaм  manuscriptу Ќ +anд  musicaм scoreу ­­ Bach¬ Handel¬ Beethoven¬  Keats¬  Shelley¬ Ќ +Dickenу, anд manщ more. + +Today¬  wе lefф Londoо anд tooл б daщ touт tп Stratforд-oо-Avon¬  thе Ќ +birthplacе  oж Williaн Shakespeare® Wе wenф bщ buу witи б  largе Ќ +grouр  buф thе touт guidе waу sп welм informeд thaф iф  waу  welм Ќ +wortи  it® Wе covereд б loф iо onе daщ anд eveо tooл timе foт  б Ќ +leisurelщ luncи aф б locaм hotel. + +Stratforд-oо-Avoо   iу  б  picturesquе  littlе  towо  anд   stilм Ќ +maintainу  itу  Elizabethaо  flavor®   Mosф  buildingу  arе   thе Ќ +originalу  anд havе beeо verщ welм preserved® Wе enjoyeд  seeinз Ќ +alм thе siteу relateд tп Shakespeare'у life. + +Tomorroч iу ouт lasф daщ iо London® We'lм havе tп makе thе  mosф Ќ +oж it! + diff --git a/disks/images/e/dictsort.com b/disks/images/e/dictsort.com new file mode 100644 index 0000000..afd6e58 Binary files /dev/null and b/disks/images/e/dictsort.com differ diff --git a/disks/images/e/find.com b/disks/images/e/find.com new file mode 100644 index 0000000..7a0a7f6 Binary files /dev/null and b/disks/images/e/find.com differ diff --git a/disks/images/e/homonyms.txt b/disks/images/e/homonyms.txt new file mode 100644 index 0000000..3771cf3 Binary files /dev/null and b/disks/images/e/homonyms.txt differ diff --git a/disks/images/e/hyexcept.txt b/disks/images/e/hyexcept.txt new file mode 100644 index 0000000..5bef28a --- /dev/null +++ b/disks/images/e/hyexcept.txt @@ -0,0 +1,357 @@ +CON-TROL-LABLE +EQ-UABLE +IN-SA-TIABLE +NE-GO-TIABLE +SO-CIABLE +TURN-TABLE +UN-CON-TROLLABLE +UN-SO-CIABLE + +DE-PEND-ENT +IN-DE-PEND-ENT + +ANY-THING +BAL-DING +DAR-LING +DUMP-LING +ERR-ING +EVE-NING +EVERY-THING +FAR-THING +FOUND-LING +INK-LING +MAIN-SPRING +NEST-LING +OFF-SPRING +PLAY-THING +SAP-LING +SHOE-STRING +SIB-LING +SOME-THING +STAR-LING +STER-LING +UN-ERR-ING +UP-SWING +WEAK-LING +YEAR-LING + +CIV-I-LIZE +CRYS-TAL-LIZE +IM-MO-BI-LIZE +ME-TA-BO-LIZE +MO-BI-LIZE +MO-NOP-O-LIZE +STA-BI-LI*ZE +TAN-TA-LIZE +UN-CIV-I-LIZED + +PAL-ATE +IN-CLEM-ENT +BAR-ON-ESS +LI-ON-ESS +EU-LOGY +PED-A-GOGY +LUS-CIOUS +AT-MOS-PHERE +MET-AL +NON-METAL +PET-AL +POST-AL +RENT-AL +CAT-ION +COM-BAT-IVE +STAT-URE +BECK-ON +BES-TIAL +COM-A-TOSE +COME-BACK +CO-ME-DIAN +COMP-TROLLER +CONE-FLOWER +CO-NUN-DRUM +EQUIPPED +HANDLE-BAR +INCH-WORM +INK-BLOT +INN-KEEPER +IN-TE-RIOR +MIN-IS-TER +MIN-IS-TRY +NONE-THE-LESS +QUA-DRILLE +SOM-ER-SAULT +SU-PE-RIOR +U-NA-NIM-ITY +U-NAN-I-MOUS +UNC-TUOUS +DEBT-OR +AC-KNOW-LEDGE +DE-DUCT-I*BLE +EX-ACT-I-TUDE +IN-EX-ACT-I-TUDE +PRE-DICT-*ABLE +RE-SPECT-*ABLE +UN-PRE-DICT-ABLE +VICT-UAL +NEEDLE-WORK +IDLER +BUFF-ER +OFF-BEAT +OFF-HAND +OFF-PRINT +OFF-SHOOT +OFF-SHORE +STIFF-EN +LEFT-IST +LEFT-OVER +LIFT-OFF +SOFT-HEARTED +EGG-SHELL +EGG-PLANT +EGG-NOG +EGG-HEAD +COGNAC +FOR-EIGN-ER +VIGNETTE +HOGS-HEAD +CHILD-ISH +ELD-EST +GOLD-EN +HOLD-OUT +HOLD-OVER +HOLD-UP +SELF-ISH +BULL-ISH +CREST-FALLEN +DIS-TILL-*E*RY +FALL-OUT +LULL-ABY +ROLL-AWAY +SELL-OUT +WALL-EYE +PSALM-IST +ELSE-WHERE +FALSE-HOOD +CON-SULT-ANT +VOLT-AGE +RE-SOLV-ABLE +RE-VOLV-ER +SOLV-ABLE +UN-SOLV-ABLE +BEACH-COMBER +BOMB-ER +CLIMB-ER +PLUMB-ER +DAMP-EN +DAMP-EST +CLINCH-ER +LAUNCH-ER +LUNCH-EON +RANCH-ER +TRENCH-ANT +AN-NOUNCER +BOUNCER +FENCER +HENCE-FORTH +MINCE-MEAT +SI-LENCER +BIND-ERY +BOUND-ARY +COM-MEND-*A-*T*ORY +DE-PEND-ABLE +EX-PEND-ABLE +FIEND-ISH +LAND-OWNER +OUT-LAND-ISH +ROUND-ABOUT +SEND-OFF +STAND-OUT +UN-DER-STAND-ABLE +CHANGE-OVER +HANG-OUT +HANG-OVER +HA-RANGUE +ME-RINGUE +ORANGE-ADE +TONGUE +VENGE-ANCE +SENSE-LESS +AC-COUNT-ANT +ANT-ACID +ANT-EATER +COUNT-ESS +PER-CENT-*AGE +REP-RE-SENTATIVE +ANT-HILL +PENT-HOUSE +AC-CEPT-ABLE +AC-CEPTOR +ADAPT-ABLE +ADAPT-ER +CRYPT-ANALYSIS +IN-TER-RU*P*T-*I*BLE +AN-TIQ-UI*TY +INEQ-UITY +INIQ-UITY +LIQ-UEFY +LIQ-UID +LIQ-UI-D*A*T*E +LIQ-UI-D*A-*T*ION +LIQ-UOR +PRE-REQ-UI-SITE +REQ-UI-SI-TION +SUB-SEQUENCE +U-BIQ-UI-TOUS +AB-SORB-ENT +CARB-ON +HERBAL +IM-PERT-TURB-ABLE +ARCH-ERY +ARCH-AN-GEL +RE-SEARCH-ER +UN-SEARCH-ABLE +AC-CORD-ANCE +BOARD-ER +CHORDAL +HARD-EN +HARD-EST +HAZ-ARD-OUS +JEOP-ARD-IZE +RE-CORDER +STAND-ARD-IZE +STEW-ARD-ESS +YARD-AGE +SURF-ER +MORGUE +CURL-I-CUE +AF-FIRM-*A*T*IVE +CON-FORM-*ITY +DE-FORM-ITY +IN-FORM-A*NT +NON-CON-FORM-IST +CAV-ERN-OUS +DIS-CERN-IBLE +MOD-ERN-IZE +TURN-ABOUT +TURN-OVER +UN-GOV-ERN-ABLE +WEST-ERN-IZE +HARP-IST +SHARPEN +TORQUE +COARS-EN +IR-RE-VERS-IBLE +NURSE-MAID +NURS-ERY +RE-HEARS-AL +RE-VERS-IBLE +WORS-EN +ART-IST +CON-VERT-IBLE +COURT-YARD +FORE-SHORT-EN +HEART-ACHE +HEART-ILY +SHORT-EN +APART-HEID +COURT-HOUSE +EARTH-EN-WARE +NORTH-EAST +NORTH-ERN +PORT-HOLE +NERV-OUS +OB-SERV-A*BLE +OB-SERVER +PRE-SERV-*A*T*I*VE +SERV-ER + +SERV-ICE-ABLE +PRE-SCHOOL +CON-DE-SCEND +CRE-SCENDO +DE-CRE-SCENDO +DE-SCEND-ENT +DE-SCENT +PLEB-I-SCITE +RE-SCIND +SEA-SCAPE +ASKANCE +SNAKE-SKIN +WHISK-ER +COLE-SLAW +RATTLE-SNAKE +CLASS-IFY +CLASS-ROOM +CROSS-OVER +DIS-MISS-*AL +EX-PRESS-*I*BLE +IM-PASS-ABLE +LESS-EN +PASS-ABLE +TOSS-UP +UN-CLASS-I-FIED +AR-MI-STICE +ASTIG-MA-TISM +ASTIR +ASTONISH-MENT +BLAST-OFF +BY-STAND-ER +CANDLE-STICK +CAST-AWAY +CAST-OFF +CON-TEST-ANT +CO-STAR +DE-TEST-ABLE +DI-GEST-IBLE +EAST-ERN +EX-IST-ENCE +FORE-STALL +IN-CON-TEST-ABLE +IN-DI-GES*T-*I*BLE +IN-EX-HAUST-IBLE +LIFE-STYLE +LIME-STONE +LIVE-STOCK +MILE-STONE +NON-EX-IST-ENT +PER-SIST-ENT +PHO-TO-STAT +RE-START-ED +RE-STATE-MENT +RE-STORE +SHY-STER +SIDE-STEP +SMOKE-STACK +SUG-GEST-*I*BLE +THERMO-STAT +WASTE-BAS-KET +WASTE-LAND +MAST-HEAD +POST-HU-MOUS +PRIEST-HOOD +SIDE-SWIPE +WATT-METER +BE-TWEEN +KIB-ITZER +BUZZ-ER +AL-GO-RITHM +BIB-LI-OG-RAPHY +BI-NO-MIAL +CEN-TER +COM-PUT-A*BIL-ITY +DEC-LA-RA-TION +DE-GREE +ES-TAB-LISH +GEN-ER-ATOR +HAP-HAZARD +NEG-LI-GIBLE +PE-RI-ODIC +POLY-NO-MIAL +PRE-VIOUS +PROB-ABIL-ITY +PROB-ABLE +PRO-CE-DURE +PUB-LI-CA-TION +PUB-LISH +RE-PLACE-MENT +WHEN-EVER diff --git a/disks/images/e/hyphen.com b/disks/images/e/hyphen.com new file mode 100644 index 0000000..4ab3a14 Binary files /dev/null and b/disks/images/e/hyphen.com differ diff --git a/disks/images/e/lookup.com b/disks/images/e/lookup.com new file mode 100644 index 0000000..7e194c2 Binary files /dev/null and b/disks/images/e/lookup.com differ diff --git a/disks/images/e/maindict.cmp b/disks/images/e/maindict.cmp new file mode 100644 index 0000000..707b1db Binary files /dev/null and b/disks/images/e/maindict.cmp differ diff --git a/disks/images/e/markfix.com b/disks/images/e/markfix.com new file mode 100644 index 0000000..a60a048 Binary files /dev/null and b/disks/images/e/markfix.com differ diff --git a/disks/images/e/moveprn.com b/disks/images/e/moveprn.com new file mode 100644 index 0000000..63e864f Binary files /dev/null and b/disks/images/e/moveprn.com differ diff --git a/disks/images/e/print.tst b/disks/images/e/print.tst new file mode 100644 index 0000000..f5865f6 --- /dev/null +++ b/disks/images/e/print.tst @@ -0,0 +1,142 @@ +.hePRINT.TST Features of Your Printer +.f1 WordStar +.f2 Print test +.f3 Page # +.oj on + WordStaт anд Youт Printer + +WordStar‚  workу  witи б widе rangе oж printerу anд offerу  yoх  б Ќ +varietщ oж prinф enhancements® Whetheт youт printeт caо producе Ќ +thе  prinф enhancementу outlineд iо thiу documenф dependу oо  itу Ќ +capabilities®   Pleasе notе thaф noф alм printerу arе capablе  oж Ќ +showinз alм thе exampleу below. + +Speciaм Printinз Capabilities + +WordStaт supportу thе followinз speciaм printinз capabilities: + + Є Boldface¬ Doublе strike + * Italics/Alternatе ribboо color + * Strikе out + * Overprinф (aу iо co^te) + * Noncontinuouу underline¬ anд +.ul on + * Continuouу underline +.ul off + + * SuperScript¬ SubScript + + * anд almosф anщ combinatioо -­ WordStar + +Characteт Width + +Somе  printerу  wilм  supporф  WordStar‚  commandу  foт   variablе Ќ +characteт widths®Ќ + +.cw 24 +µ characterу peт inch® (.CЧ 24) +.cw 20 +¶ characterу peт inch® (.CЧ 20) +.cw 14 +8.¶ characterу peт inch® (.CЧ 14) +.cw 12 +1° characterу peт inch® (.CЧ 12) +.cw 10 +1І characterу peт inch® (.CЧ 10) +.cw 7 +17.± characterу peт inch® (.CЧ 7) +.cw 12 + +Youт printeт caо alsп bе seф tп "toggleў betweeо normaм pitcи anд Ќ +alternatе pitch: + +     Thiу  sentencе iу printeд witи thе normaм 1°-pitcи  setting¬ Ќ +     theо toggleд tп 1І pitch¬ theо bacл tп normal. +.cw 7 + +Yoх caо alsп changе thе normaм anд alternatе characteт widths: + +.cw 14 +.rm 55 +     Thе  "normalў characteт widtи iу 1ґ (8.¶ cpi©  anд Ќ +     thе alternatе characteт widtи iу · (17.± cpi). +.pa Љ.rm 65 +.cw 10 + +.cw 12 +Linе Height + +Yoх caо alsп usе differenф linе heights. + +.lh 16 +Thiу iу aо examplе oж variablе linе height® (.LИ 1¶ ­ і lpi) +.lh 12 +Thiу iу aо examplе oж variablе linе height® (.LИ 1І ­ ґ lpi) +.lh 8 +Thiу iу aо examplе oж variablе linе height® (.LИ ё ­ ¶ lpi) +.lh 6 +Thiу iу aо examplе oж variablе linе heighф® (.LИ ¶ ­ ё lpi) +.lh 8 + +Proportionaм Printing + +.ps on +.uj on +WordStar‚  alsп supportу proportionaм printinз foт  mosф  printerу Ќ +thaф  havе  it®   Yoх  selecф  proportionaм  fontу  bщ   changinз Ќ +characteт widthу aу iо thе followinз examples:Ќ + +.cw 22 +Thiу iу characteт widtи 22. +.cw 11 +Thiу iу characteт widtи 11. +.cw 9 +Thiу iу characteт widtи 9. +.cw 7 +Thiу iу characteт widtи 7. +.uj dis +.ps off +.cw 12 + +Other + +Phantoн Spacе¬ Phantoн Rubout + +WordStaт maщ alloч yoх tп prinф speciaм characterу (foт  example¬ Ќ +б  paragrapи  sigо  oт centу sign© bщ  usinз  thе  phantoн  spacе Ќ +commanд (^PF© oт thе phantoн rubouф commanд (^PG© iо б  document® Ќ +Foт  youт  printer¬ thе phantoн spacе characteт isє  ¬  anд  thе Ќ +phantoн rubouф characteт isє . + +Switchinз tп Drafф Mode + +.lq off +Doф matriш printeт driverу alloч switchinз froн NLС (neaт  letteт Ќ +quality© modе tп drafф modе foт fasteт printing. +.lq on + +Microspacе Justification + +.uj on +WordStar‚   allowу  microspacе  justification¬  iж  youт   printeт Ќ +supportу  it¬ tп producе evenlщ spaceд wordу iо  justifieд  text® Ќ +Microspacinз spreadу thе whitе spacе betweeо wordу (anд sometimeу Ќ +betweeо thе letterу oж eacи word© aу evenlщ aу possible® +.uj dis +.pa ЉLookinз Aф Thiу Filе Onscreen + +Iж  yoх wanф tп seе thе embeddeд commandу thaф produceд thе  texф Ќ +yoх arе noч reading¬ folloч thesе steps: + +1 Aф thе Openinз Menu¬ presу D‚ tп ediф б document. + +І Aф thе prompф foт filename¬ typе print.tsф anд presу Enter. + +Noticе thaф thе texф onscreeо includeу somе characterу thaф don'ф Ќ +appeaт  iо  thе  printeд copy® Foт example¬ б  headinз  linе  iу Ќ +identifieд  bщ  thе  doф  commanд .he®   Wordу  iо  boldfacе  arе Ќ +surroundeд bщ ^В anд appeaт eitheт highlighteд oт iо б  differenф Ќ +coloт oо youт screen. + +Tп continuе viewinз thе contentу oж thiу file¬ ¬ presу ^C® Presу Ќ +^R‚ tп movе iо thе otheт direction. diff --git a/disks/images/e/review.com b/disks/images/e/review.com new file mode 100644 index 0000000..5f3ad97 Binary files /dev/null and b/disks/images/e/review.com differ diff --git a/disks/images/e/ruler.doc b/disks/images/e/ruler.doc new file mode 100644 index 0000000..aecfd23 --- /dev/null +++ b/disks/images/e/ruler.doc @@ -0,0 +1,21 @@ + Thе Ruleт Line + +Thiу  documenф  iу seф uр tп teacи yoх abouф ruleт  lines®   Thiу Ќ +texф  waу writteо usinз thе defaulф lefф anд righф marginу  oж  ± Ќ +anд  65®   Wе didn'ф changе anщ tabу here® Next¬  wе  wanteд  tп Ќ +changе  botи  marginу  tп  indenф thе texф®  Wе  useд  doф Ќ +commands® Witи doф commands¬ thе neч marginу arе saveд wheо  yoх Ќ +exiф anд savе thе document.Ќ +.lm10 +.rm45 +         Neч  marginу  changе thе  ruleт  anд Ќ +         text®   Watcи thе ruleт linе aу  yoх Ќ +         movе  thе cursoт througи thiу  text® Ќ +         WordStaт wilм continuе tп holд thesе Ќ +         marginу untiм yoх enteт anotheт  doф Ќ +         гommand. +.lm1 +.rm65 +Margiо  changeу brinз thе ruleт anд thе texф bacл tп thе  defaulф Ќ +settingу oncе again. + diff --git a/disks/images/e/sample1.doc b/disks/images/e/sample1.doc new file mode 100644 index 0000000..9b4eeb2 --- /dev/null +++ b/disks/images/e/sample1.doc @@ -0,0 +1,16 @@ + Itinerary + +Depart Datе Time Arrive Date Time + +Florence 10Ї3± 08:30 a Rome 10Ї31 05:3µ p +Romе 11Ї05 08:00 a Naples 11/05 12:2· p + +Noф includeд iо thе rateу are +.lm10 +.rm55 + +         Transfeт  services¬ sightseeing¬ mealу  excepф Ќ +         aу specified¬ tipу tп statioо porters¬  wines¬ Ќ +         spirits¬   mineraм waters¬  laundry¬   theateт Ќ +         tickets¬ anд otheт itemу oж б similaт personaм Ќ +         nature® diff --git a/disks/images/e/sample2.doc b/disks/images/e/sample2.doc new file mode 100644 index 0000000..5f87f10 --- /dev/null +++ b/disks/images/e/sample2.doc @@ -0,0 +1,14 @@ + +Excursions + + +Daщ ± +Florencе-Romeє Leavе aф 8:3° aн bщ deluxе motorcoach® Arrivе aф Ќ +Romе iо thе afternoon® + +Daщ І +Romeє   Morninз  anд afternooо citщ  sightseeinз  bщ  motorcoach® Ќ +Englisи speakinз guidе optional. + +Farе iо firsф clasу hotelsє $100.00® Batи optionaмє $25.00® + diff --git a/disks/images/e/sample3.doc b/disks/images/e/sample3.doc new file mode 100644 index 0000000..2509190 --- /dev/null +++ b/disks/images/e/sample3.doc @@ -0,0 +1,4 @@ +Daщ 8 +Romе-Naplesє   Deparф  aф 8:0° aн bщ CIAФ deluxе  motorcoacи  viб Ќ +Formia®   Arrivе  Napleу  aф  luncи  time®   Afternooо   optionaм Ќ +excursioо tп Phlegreaо Fieldу anд Sulphuт Mine® diff --git a/disks/images/e/spell.com b/disks/images/e/spell.com new file mode 100644 index 0000000..07bffa1 Binary files /dev/null and b/disks/images/e/spell.com differ diff --git a/disks/images/e/table.doc b/disks/images/e/table.doc new file mode 100644 index 0000000..e690808 --- /dev/null +++ b/disks/images/e/table.doc @@ -0,0 +1,16 @@ + TABLЕ II + + CENTRIFUGAМ FORCЕ CALIBRATIOО DATA + +__________________________________________________________________ + Elemenф No® | Maximuн з ь Minimuн з ь Averagе з ь Spreaд iо з | +______________|____________|___________|___________|_____________| + ± ь 2.2± ь 1.6µ ь 1.9і | 0.5¶ | + ь 2.2° ь 1.6µ ь 1.9і ь 0.5° | + І ь 2.4ё ь 2.2µ ь 2.3¶ ь 0.2і | + ь 2.5° ь 2.2І ь 2.3¶ ь 0.2ё | + і ь 3.0ё ь 2.5№ ь 2.8ґ ь 0.4№ | + ь 3.1І ь 2.5ё ь 2.8µ ь 0.5ґ | + ґ ь 3.0· ь 2.6° ь 2.8ґ ь 0.4· | + ь 3.1° ь 2.6° ь 2.8µ ь 0.5° | + diff --git a/disks/images/e/text.doc b/disks/images/e/text.doc new file mode 100644 index 0000000..6a7724d --- /dev/null +++ b/disks/images/e/text.doc @@ -0,0 +1,93 @@ + Gulliver'у Travels + Parф I + + Б Voyagе tп Lilliput + + Chap® I + + +Mщ fatheт haд б smalм estatе iо Nottinghamshire» Й waу thе  thirд Ќ +oж  fivе  sons®  Hе senф mе tп Emanueм Collegе  iо  Cambridgе  aф Ќ +fourteeо  yearу  old¬ wherе Й resideд threе  years¬  anд  applieд Ќ +myselж  closе  tп mщ studiesє buф thе chargе  oж  maintaininз  mе Ќ +(althougи  Й haд б verщ scantщ allowance© beinз toп greaф  foт  б Ќ +narroч  fortune¬  Й waу bounд apprenticе tп Mr® Jameу  Bates¬  aо Ќ +eminenф surgeoо iо London¬ witи whoн Й continueд fouт years»  anд Ќ +mщ  fatheт  noч anд theо sendinз mе smalм sumу oж money¬  Й  laiд Ќ +theн  ouф  iо  learninз  navigation¬  anд  otheт  partу  oж   thе Ќ +mathematics¬  usefuм tп thosе whп intenд tп travel¬ aу  Й  alwayу Ќ +believeд iф woulд bе somе timе oт otheт mщ fortunе tп do® Wheо  Й Ќ +lefф Mr® Bates¬ Й wenф dowо tп mщ father» wherе bщ thе assistancе Ќ +oж  hiн anд mщ unclе John¬ anд somе otheт relations¬ Й goф  fortщ Ќ +pounds¬  anд б promisе oж thirtщ poundу б yeaт tп maintaiо mе  aф Ќ +Leydenє  therе  Й  studieд physiг twп  yearу  anд  seveо  months¬ Ќ +knowinз iф woulд bе usefuм iо lonз voyages. + +Sooо  afteт mщ returо froн Leyden¬ Й waу recommended¬ bщ mщ  gooд Ќ +masteт Mr® Bates¬ tп bе surgeoо tп thе "Swallow,ў Captaiо Abrahaн Ќ +Panneм  commander» witи whoн Й continueд threе yearу anд б  half¬ Ќ +makinз  б  voyagе oт twп intп thе Levant¬ anд somе  otheт  parts® Ќ +Wheо  Й  camе back¬ Й resolveд tп settlе iо Londoо tп  whicи  Mr® Ќ +Bates¬ mщ master¬ encourageд me¬ anд bщ hiн Й waу recommendeд  tп Ќ +severaм  patients® Й tooл parф oж б smalм housе iо thе Olд  Jury» Ќ +anд  beinз  adviseд tп alteт maщ condition¬ Й marrieд  Mrs®  Marщ Ќ +Burton¬ seconд daughteт tп Mr® Edmunд Burton¬ hosieт iо  Newgatе-Ќ +street¬ witи whoн Й receiveд fouт hundreд poundу foт б portion. + +But¬ mщ gooд masteт Bateу dyinз iо twп yearу after¬ anд Й  havinз Ќ +feч  friends¬ mщ businesу begaо tп fail» foт mщ consciencе  woulд Ќ +noф  suffeт mе tп imitatе thе baд practicе oж toп manщ  amonз  mщ Ќ +brethren®   Havinз thereforе consulteд witи mщ wife¬ anд somе  oж Ќ +mщ  acquaintance¬ Й determineд tп gп agaiо tп sea® Й waу  surgeoо Ќ +successivelщ  iо  twп ships¬ anд madе severaм  voyages¬  foт  siш Ќ +years¬ tп thе Easф anд Wesф-Indies¬ bщ whicи Й goф somе  additioо Ќ +tп  mщ fortune® Mщ hourу oж leisurе Й spenф iо readinз  thе  besф Ќ +authors¬  ancienф anд modern¬ beinз alwayу provideд witи  б  gooд Ќ +numbeт oж books» anд wheо Й waу ashore¬ iо observinз thе  mannerу Ќ +anд  dispositionу  oж  thе  people¬ aу  welм  aу  learninз  theiт Ќ +language¬  whereiо Й haд б greaф facilitщ bщ thе strengtи  oж  mщ Ќ +memory. + +Thе  lasф  oж thesе voyageу noф provinз verщ  fortunate¬  Й  greч Ќ +wearщ  oж thе sea¬ anд intendeд tп staщ aф homе witи mщ wifе  anд Ќ +family®   Й  removeд froн thе Olд Jurщ tп Fetteт-Lane¬  anд  froн Ќ +thencе tп Wapping¬ hopinз tп geф businesу amonз thе sailors»  buф Ќ +iф woulд noф turо tп account® Afteт threе yearу expectatioо  thaф ЌЉthingу woulд mend¬ Й accepteд aо advantageouу offeт froн  Captaiо Ќ +Williaн  Prichard¬  masteт oж thе "Antelope,ў whп  waу  makinз  б Ќ +voyagе  tп thе Soutи-Sea® Wе seф saiм froн Bristoм Maщ  4¬  1699¬ Ќ +anд ouт voyagе waу verщ prosperous. + +Iф  woulд noф bе proper¬ foт somе reasons¬ tп troublе thе  readeт Ќ +witи  thе  particularу oж ouт adventureу iо thosе  seasє  leф  iф Ќ +sufficе  tп  inforн him¬ thaф iо ouт passagе froн thencе  tп  thе Ќ +Easф-Indies¬ wе werе driveо bщ б violenф storн tп thе  nortи-wesф Ќ +oж  Vaо Diemen'у Land® Bщ aо observation¬ wе founд  ourselveу  iо Ќ +thе  latitudе oж 3° degreeу І minuteу south® Twelvе oж  ouт  creч Ќ +werе  deaд bщ immoderatе labouт anд ilм food¬ thе resф werе iо  б Ќ +verщ  weaл  condition® Oо thе fiftи oж November¬  whicи  waу  thе Ќ +beginninз oж summeт iо thosе parts¬ thе weatheт beinз verщ  hazy¬ Ќ +thе  seameо  spieд б rock¬ withiо halж б cable'у  lengtи  oж  thе Ќ +ship»  buф thе winд waу sп strong¬ thaф wе werе  driveо  directlщ Ќ +upoо  it¬ anд immediatelщ split® Siш oж thе crew¬ oж whoн  Й  waу Ќ +one¬  havinз leф dowо thе boaф intп thе sea¬ madе б shifф tп  geф Ќ +cleaт oж thе ship¬ anд thе rock® Wе roweд bщ mщ computatioо abouф Ќ +threе leagues¬ tilм wе werе ablе tп worл nп longer¬ beinз alreadщ Ќ +spenф  witи  labouт  whilе wе werе iо  thе  ship®   Wе  thereforе Ќ +trusteд ourselveу tп thе mercщ oж thе waves¬ anд iо abouф halж aо Ќ +houт thе boaф waу overseф bщ б suddeо flurrщ froн thе north® Whaф Ќ +becamе mщ companionу iо thе boat¬ aу welм aу oж thosе whп escapeд Ќ +oо  thе  rock¬  oт werе lefф iо thе vessel¬ Й  cannoф  tell»  buф Ќ +concludе  theщ werе alм lost® Foт mщ owо part¬ Й swaн aу  fortunе Ќ +directeд  me¬ anд waу pusheд forwarд bщ winд anд tide®   Й  ofteо Ќ +leф mщ legу droр anд coulд feeм nп bottomє buф wheо Й waу  almosф Ќ +gone¬  anд ablе tп strugglе nп longer¬ Й founд myselж  withiо  mщ Ќ +depth» anд bщ thiу timе thе storн waу mucи abated® Thе  declivitщ Ќ +waу  sп  small¬  thaф Й walkeд neaт б milе beforе Й  goф  tп  thе Ќ +shore¬  whicи  Й  conjectureд  waу abouф  eighф  o'clocл  iо  thе Ќ +evening® Й theо advanceд forwarд neaт halж б mile¬ buф coulд  noф Ќ +discoveт anщ sigо oж houseу oт inhabitants» aф leasф Й waу iо  sп Ќ +weaл  б condition¬ thaф Й diд noф observе them® Й  waу  extremelщ Ќ +tired¬ anд witи that¬ anд thе heaф oж thе weather¬ anд abouф halж Ќ +б pinф oж brandщ thaф Й dranл aу Й lefф thе ship¬ Й founд  myselж Ќ +mucи inclineд tп sleep. + diff --git a/disks/images/e/tw.com b/disks/images/e/tw.com new file mode 100644 index 0000000..a09c626 Binary files /dev/null and b/disks/images/e/tw.com differ diff --git a/disks/images/e/wc.com b/disks/images/e/wc.com new file mode 100644 index 0000000..4ed1c05 Binary files /dev/null and b/disks/images/e/wc.com differ diff --git a/disks/images/e/winstall.com b/disks/images/e/winstall.com new file mode 100644 index 0000000..4ed26d0 Binary files /dev/null and b/disks/images/e/winstall.com differ diff --git a/disks/images/e/wordfreq.com b/disks/images/e/wordfreq.com new file mode 100644 index 0000000..2ddc304 Binary files /dev/null and b/disks/images/e/wordfreq.com differ diff --git a/disks/images/e/ws.com b/disks/images/e/ws.com new file mode 100644 index 0000000..7280ddc Binary files /dev/null and b/disks/images/e/ws.com differ diff --git a/disks/images/e/ws.ovr b/disks/images/e/ws.ovr new file mode 100644 index 0000000..69586fb Binary files /dev/null and b/disks/images/e/ws.ovr differ diff --git a/disks/images/e/wschange.com b/disks/images/e/wschange.com new file mode 100644 index 0000000..091e7c4 Binary files /dev/null and b/disks/images/e/wschange.com differ diff --git a/disks/images/e/wschange.ovr b/disks/images/e/wschange.ovr new file mode 100644 index 0000000..9effde4 Binary files /dev/null and b/disks/images/e/wschange.ovr differ diff --git a/disks/images/e/wschhelp.ovr b/disks/images/e/wschhelp.ovr new file mode 100644 index 0000000..5abc8bf Binary files /dev/null and b/disks/images/e/wschhelp.ovr differ diff --git a/disks/images/e/wshelp.ovr b/disks/images/e/wshelp.ovr new file mode 100644 index 0000000..152fb73 Binary files /dev/null and b/disks/images/e/wshelp.ovr differ diff --git a/disks/images/e/wsindex.xcl b/disks/images/e/wsindex.xcl new file mode 100644 index 0000000..261a77a --- /dev/null +++ b/disks/images/e/wsindex.xcl @@ -0,0 +1,231 @@ +A +ABOUT +ABOVE +ACROSS +AFTER +AFTERWARDS +AGAIN +AGAINST +AGO +AHEAD +ALIKE +ALL +ALMOST +ALONE +ALONG +ALREADY +ALSO +ALTHOUGH +ALTOGETHER +ALWAYS +AMONG +AN +AND +ANOTHER +ANY +ANYMORE +ANYONE +ANYTHING +ANYWAY +ANYWHERE +ARE +AREN'T +AROUND +AS +ASIDE +AT +AVAILABLE +AWAY +B +BE +BECAUSE +BEEN +BEFORE +BEFOREHAND +BELOW +BENEATH +BESIDES +BETWEEN +BEYOND +BUT +BY +C +D +DID +DIDN'T +DO +DOES +DOESN'T +DONE +DON'T +DOWN +DOWNRIGHT +E +EACH +EITHER +ELSE +EVEN +EVER +EXCEPT +F +FINALLY +FOR +FROM +G +H +HAD +HADN'T +HAPPEN +HAS +HASN'T +HAVE +HAVEN'T +HE +HER +HERE +HERE'S +HERS +HIM +HIS +HOW +HOWEVER +I +IF +IN +INTO +IS +ISN'T +IT +ITS +ITSELF +IT'LL +IT'S +I'D +I'LL +I'M +I'VE +J +JUST +K +KNOW +KNOWING +KNOWS +L +LIKE +M +MAYBE +ME +MY +N +NO +NONE +NOR +NOT +NOW +O +OF +OFF +OFTEN +OH +ON +ONLY +ONTO +OR +OTHER +OTHERWISE +OUR +OURS +OUT +OVER +P +Q +R +S +SHE +SINCE +SO +SOME +SOON +SOONER +SUCH +T +THAN +THAT +THAT'S +THE +THEIR +THEM +THEMSELVES +THEN +THERE +THEREFORE +THERE'LL +THERE'S +THESE +THEY +THEY'D +THEY'LL +THEY'RE +THEY'VE +THIS +THOSE +THOUGH +THROUGH +THROUGHOUT +THUS +TIL +TO +TOGETHER +TOO +U +UN +UNDER +UNTIL +UP +US +V +VALUE +VALUED +VERY +W +WAS +WASN'T +WE +WE'D +WE'LL +WE'RE +WE'VE +WHAT +WHATEVER +WHATEVER'S +WHAT'S +WHEN +WHENEVER +WHERE +WHEREAS +WHEREVER +WHERE'S +WHETHER +WHICH +WHICHEVER +WHILE +WHO +WHOSE +WHY +WILL +WITH +WITHIN +WITHOUT +WON'T +X +YES +YET +YOU +YOUR +YOURS +YOURSELF +YOU'D +YOU'LL +YOU'RE +YOU'VE +Z diff --git a/disks/images/e/wsmsgs.ovr b/disks/images/e/wsmsgs.ovr new file mode 100644 index 0000000..80a9abb Binary files /dev/null and b/disks/images/e/wsmsgs.ovr differ diff --git a/disks/images/e/wsprint.ovr b/disks/images/e/wsprint.ovr new file mode 100644 index 0000000..d70f419 Binary files /dev/null and b/disks/images/e/wsprint.ovr differ diff --git a/disks/images/e/wsshort.ovr b/disks/images/e/wsshort.ovr new file mode 100644 index 0000000..343707d Binary files /dev/null and b/disks/images/e/wsshort.ovr differ diff --git a/disks/images/f/ass8080.fb b/disks/images/f/ass8080.fb new file mode 100644 index 0000000..ce1c1b4 --- /dev/null +++ b/disks/images/f/ass8080.fb @@ -0,0 +1 @@ +\ VolksForth 8080 Assembler UH 09Mar86 Ideen lieferten: John Cassady Mike Perry Klaus Schleisiek Bernd Pennemann Dietrich Weineck \ VolksForth 8080 Assembler Load Screen UH 03Jun86Onlyforth Assembler also definitions hex 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr OnlyForth \ Vektorisierte Erzeugung UH 03Jun86Variable >codes | Create nrc ] c, , c@ here allot ! c! [ : nonrelocate ( -- ) nrc >codes ! ; nonrelocate | : >exec ( n -- n+2 ) Create dup c, 2+ does> c@ >codes @ + perform ; 0 | >exec >c, | >exec >, | >exec >c@ | >exec >here | >exec >allot | >exec >! | >exec >c! drop \ Register und Definierende Worte UH 09Mar86 7 Constant A 0 Constant B 1 Constant C 2 Constant D 3 Constant E 0 Constant I 1 Constant I' 2 Constant W 3 Constant W' 0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L 6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S | : 1MI Create >c, does> C@ >c, ; | : 2MI Create >c, does> C@ + >c, ; | : 3MI Create >c, does> C@ swap 8 * + >c, ; | : 4MI Create >c, does> C@ >c, >c, ; | : 5MI Create >c, does> C@ >c, >, ; \ Mnemonics UH 09Mar8600 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc 0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc 2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa 80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr 03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call 2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo EA 5MI jpe F2 5MI jp FA 5MI jm \ Spezial Mnemonics und Spruenge UH 09Mar86DA Constant C0= D2 Constant C0<> D2 Constant CS C2 Constant 0= CA Constant 0<> E2 Constant PE F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ; : mov 8 * 40 + + >c, ; : mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ; : [[ ( -- addr ) >here ; \ BEGIN : ?] ( addr opcode -- ) >c, >, ; \ UNTIL : ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF : ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE : ]? ( addr -- ) >here swap >! ; \ THEN : ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE : ]] ( addr -- ) jmp ; \ AGAIN : ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT \ Macros UH 14May86: end-code context 2- @ context ! ; : ;c: 0 recover call end-code ] ; : Next >next jmp ; : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ; \ Definierende Worte UH 06Aug86Forth definitions : Code ( -- ) Create here dup 2- ! Assembler ; : ;Code ( -- ) 0 ?pairs compile [ ' does> >body 2+ @ , ] reveal [compile] [ Assembler ; immediate : >label ( adr -- ) here | Create swap , 4 hallot >here 4 - heap 4 cmove heap last @ (name> ! dp ! does> ( -- adr ) @ State @ IF [compile] Literal THEN ; : Label [ Assembler ] >here >label Assembler ; UH 14May86 % VolksForth 8080 Assembler Shadow-Screens UH 09Mar86 % VolksForth 8080 Assembler UH 03Jun86 Der 8080 Assembler wurde von John Cassady, in den Forth Dimensions veroeffentlicht und von Mike Perry im F83 implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat und auch Befehle zur strukturierten Assemblerprogrammierung. Um ein Wort in Assembler zu definieren wird das definierende Wort Code benutzt, es kann, muss aber nicht mit end-code beendetwerden. Wie der Assembler arbeitet ist ein interessantes Beispiel fuer die Maechtigkeit von Create does>. Am Anfang werden die Befehle in Klassen eingeteilt und fuer jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic des Befehls spaeter interpretiert wird, kompiliert er den entsprechenden Opcode. % Vektorisierte Erzeugung UH 09Mar86Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren. Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler Schaltet Assembler in den In-Line Modus. Definierendes Wort fuer Erzeugungs-Operator-Namen. Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden aktuellen Erzeugungsoperator aus. Mit diesen Erweiterungen kann der Assembler auch fuer den Target-Compiler benutzt werden. % Register und Definierende Worte UH 09Mar86 Die 8080 Register werden definiert. Es sind einfach Konstanten die Information fuer die Mnemonics hinterlassen. Einige Register der Forth-Maschine: IP ist BC, W ist DE Definierende Worte fuer die Mnemonics. Fast alle 8080 Befehle fallen in diese 5 Klassen. % Mnemonics UH 09Mar86Die 8080 Mnemonics werden definiert. % Spezial Mnemonics und Spruenge UH 09Mar86Vergleiche des 8080 not folgt einem Vergleich, wenn er invertiert werden soll. die Mnemonics, die sich nicht in die Klassen MI1 bis MI5 einteilen lassen. Die strukturierten Assembler-Anweisungen. Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungenzu den strukturierten Anweisungen in Forth entstehen. Es findet keine Absicherung der Kontrollstrukturen statt, sodasssie auch beliebig missbraucht, werden koennen. Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig. % Macros UH 17May86end-code beendet eine Code-Definition ;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten. Next Assembliert einen Sprung zum Adress-Interpretierer. rpush Das angegebene Register wird auf den Return-Stack gelegt. rpop Das angegebene Register wird vom Return-Stack genommen. rpush und rpop benutzen das HL Register. mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register Bewegt Registerpaare HL BC DE % Definierende Worte UH 17May86Code leitet eine Code-Definition ein. ;code ist das Low-Level-Aequivalent von does> >label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert Label erzeugt ein Label auf dem Heap, mit dem Wert von here \ No newline at end of file diff --git a/disks/images/f/asstran.fb b/disks/images/f/asstran.fb new file mode 100644 index 0000000..4e1447f --- /dev/null +++ b/disks/images/f/asstran.fb @@ -0,0 +1 @@ +\\ Transinient Assembler 11Nov86 Dieses File enthaelt Befehle, die den Assembler vollstaendig in den Heap laden, so dass er schliesslich mit clear wieder vergessen werden kann. Dadurch ist es nicht notwendig in einer Anwendung den ganzen Assembler im Speicher lassen zu muessen, nur weil einige primitive Worte in Assembler geschrieben sind. \ Internal Assembler UH 22Oct86 Onlyforth here $C00 hallot heap dp ! include ass8080.scr dp ! \ No newline at end of file diff --git a/disks/images/f/copy.fb b/disks/images/f/copy.fb new file mode 100644 index 0000000..30357c5 --- /dev/null +++ b/disks/images/f/copy.fb @@ -0,0 +1 @@ +\ Copy und Convey 19Nov87 Dieses File enthaelt Definitionen, die urspruenglich im Kern enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern klein zu halten. copy kopiert einen Screen convey kopiert einen Bereich von Screens \ moving blocks 20Oct86 19Nov87| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; | : fromblock ( blk -- adr ) fromfile @ (block ; | : (copy ( from to -- ) dup isfile@ core? IF prev @ emptybuf THEN full? IF save-buffers THEN offset @ + isfile@ rot fromblock 6 - 2! update ; | : blkmove ( from to quan --) save-buffers >r over r@ + over u> >r 2dup u< r> and IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN save-buffers 2drop ; : copy ( from to --) 1 blkmove ; : convey ( [blk1 blk2] [to.blk --) swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ; \ No newline at end of file diff --git a/disks/images/f/disass.fb b/disks/images/f/disass.fb new file mode 100644 index 0000000..08ae90c --- /dev/null +++ b/disks/images/f/disass.fb @@ -0,0 +1 @@ +\\ Z80-Disassembler 08Nov86 Dieses File enthaelt einen Z80-Disassembler, der assemblierten Code in Standard Zilog-Z80 Mnemonics umsetzt. Benutzung: TOOLS ALSO \ Schalte Disassembler-Vokabular an addr DIS \ Disassembliere ab Adresse addr xxxx displace ! \ Beruecksichte bei allen Adressen einen \ Versatz von xxxx. \ Wird gebraucht, wenn ein Assemblerstueck \ nicht an dem Platz disassembliert wird, \ an dem es ablaeuft. \ Z80-Disassembler Load Screen 08Nov86 Onlyforth Tools also definitions hex ' Forth | Alias F: immediate ' Tools | Alias T: immediate 1 $10 +THRU cr .( Disassembler geladen. ) cr OnlyForth \\ Fragen Anregungen & Kritik an: U. Hoffmann Harmsstrasse 71 2300 Kiel 1 \ Speicherzugriff und Ausgabe 07Jul86internal \needs Case: : Case: Create: Does> swap 2* + perform ; Variable index Variable address Variable offset Variable oldoutput external Variable displace displace off internal ' pad Alias str1 ( -- addr ) : str2 ( -- addr ) str1 $40 + ; : byte ( -- b ) address @ displace @ + c@ ; : word ( -- w ) address @ displace @ + @ ; : .byte ( byte -- ) 0 <# # #s #> type ; : .word ( addr -- ) 0 <# # # # #s #> type ; \ neue Bytes lesen Byte-Fraktionen 07Jul86 : next-byte output push oldoutput @ output ! byte .byte space 1 address +! ; : next-word next-byte next-byte ; : f ( -- b ) byte $40 / ; : g ( -- b ) byte 8 / 7 and ; : h ( -- b ) byte 7 and ; : j ( -- b ) g 2/ ; : k ( -- b ) g 1 and ; \\ 76543210 ffggghhh jjk \ Select" 08Nov86 : scan/ ( limit start -- limit start' ) over swap DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ; : select ( n addr len -- addr' len' ) bounds rot 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN LOOP under scan/ nip over - ; : (select" ( n -- ) "lit count select type ; : select" ( -- ) compile (select" ," ; immediate : append ( c str -- ) under count + c! dup c@ 1+ swap c! ; \ StringOutput 07Jul86 Variable $ : $emit ( c -- ) $ @ append pause ; : $type ( adr len -- ) 0 ?DO count $emit LOOP drop ; : $cr ( -- ) $ @ off ; : $at? ( -- row col ) 0 $ @ c@ ; Output: $output $emit $cr $type noop $cr 2drop $at? ; \ Register 07Jul86 : reg ( n -- ) dup 5 = IF index @ negate index ! THEN select" B/C/D/E/H/L/$/A" ; : double-reg ( n -- ) select" BC/DE/%/SP" ; : double-reg2 ( n -- ) select" BC/DE/%/AF" ; : num ( n -- ) select" 0/1/2/3/4/5/6/7" ; : cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ; : arith ( n -- ) select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ; \ no-prefix Einteilung der Befehle in Klassen 07Jul86 : 00xxx000 g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN select" nop/ex AF,AF'/djnz ?/jr ?" ; : 00xxx001 k IF ." add %," j double-reg exit THEN ." ld " j double-reg ." ,&" ; : 00xxx010 ." ld " g select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)" ; : 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ; \ no-prefix 07Jul86 : 00xxx100 ." inc " g reg ; : 00xxx101 ." dec " g reg ; : 00xxx110 ." ld " g reg ." ,#" ; : 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ; : 01xxxxxx ." ld " g reg ." ," h reg ; : 10xxxxxx g arith h reg ; \ no-prefix 07Jul86 : 11xxx000 ." ret " g cond ; : 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN ." pop " j double-reg2 ; : 11xxx010 ." JP " g cond ." ,&" ; : 11xxx011 g select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ; : 11xxx100 ." call " g cond ; : 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ; : 11xxx110 g arith ." #" ; : 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ; \ no-prefix 07Jul86 Case: 00xxxhhh 00xxx000 00xxx001 00xxx010 00xxx011 00xxx100 00xxx101 00xxx110 00xxx111 ; Case: 11xxxhhh 11xxx000 11xxx001 11xxx010 11xxx011 11xxx100 11xxx101 11xxx110 11xxx111 ; : 00xxxxxx h 00xxxhhh ; : 11xxxxxx h 11xxxhhh ; Case: ffxxxxxx 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ; \ no-prefix 07Jul86 : get-offset index @ 0> IF byte offset ! next-byte THEN ; : no-prefix f ffxxxxxx next-byte get-offset ; \ CB-Prefix 07Jul86 : CB-00xxxxxx g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ; : CB-01xxxxxx ." bit " g num ." ," h reg ; : CB-10xxxxxx ." res " g num ." ," h reg ; : CB-11xxxxxx ." set " g num ." ," h reg ; case: singlebit CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ; : CB-prefix get-offset f singlebit next-byte ; \ ED-Prefix 30Sep86: ED-01xxx000 ." in (C)," g reg ; : ED-01xxx001 ." out (C)," g reg ; : ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN ." HL," j double-reg ; : ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN ." (&)," j double-reg ; : ED-01xxx100 ." neg" ; : ED-01xxx101 k IF ." reti" exit THEN ." retn" ; : ED-01xxx110 g select" im 0/-/im 1/im 2" ; : ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ; : ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ; Case: ED-01xxxhhh ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011 ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ; : ED-01xxxxxx h ED-01xxxhhh ; \ ED-Prefix 07Jul86 Case: extended noop ED-01xxxxxx ED-10xxxxxx noop ; : ED-prefix get-offset f extended next-byte ; \ Disassassemblieren eines einzelnen Befehls 30Sep86 : index-register ( n -- ) index ! next-byte ; : get-instruction ( -- ) index off str1 $ ! cr byte $DD = IF 1 index-register ELSE byte $FD = IF 2 index-register THEN THEN byte $76 case? IF next-byte ." halt" exit THEN $CB case? IF next-byte CB-prefix exit THEN $ED case? IF next-byte ED-prefix exit THEN drop no-prefix ; \ Adressierungsarten ausgeben 07Jul86 27Nov87: .index-register ( -- ) index @ abs select" HL/IX/IY" ; : offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ; : +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ; : .offset ( -- ) offset @ offset-sign extend under dabs <# # #s rot +- #> type ; : .index-register-offset index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ; : .inline-byte ( -- ) byte .byte next-byte ; : .inline-word ( -- ) word .word next-word ; : .displace ( -- ) byte offset-sign address @ + 1+ .word next-byte ; \ Hauptebene: dis 07Jul86: .char ( c -- ) Ascii % case? IF .index-register exit THEN Ascii $ case? IF .index-register-offset exit THEN Ascii # case? IF .inline-byte exit THEN Ascii & case? IF .inline-word exit THEN Ascii ? case? IF .displace exit THEN emit ; : instruction ( -- ) cr address @ .word 2 spaces output @ oldoutput ! $output get-instruction str2 $ ! cr str1 count 0 ?DO count .char LOOP drop oldoutput @ output ! $20 col - 0 max spaces str2 count type ; external : dis ( addr -- ) address ! BEGIN instruction stop? UNTIL ; \ No newline at end of file diff --git a/disks/images/f/double.fb b/disks/images/f/double.fb new file mode 100644 index 0000000..a7c6663 --- /dev/null +++ b/disks/images/f/double.fb @@ -0,0 +1 @@ +\\ Double words 11Nov86 Dieses File enthaelt Worte fuer 32-Bit Objekte. Im Kern bereits enthalten sind: 2@ 2! 2dup 2drop 2swap dnegate d+ Hier werden definiert: 2Variable 2Constant 2over d* \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86 : 2Variable Variable 2 allot ; : 2Constant Create , , does> 2@ ; Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi SP dad M D mov H dcx M E mov D push H dcx M D mov H dcx M E mov D push Next end-code --> \\ Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ d* d- 29Jun86 : d* ( d1 d2 -- d1*d2 ) rot 2over rot um* 2swap um* d+ 2swap um* d+ ; : d- ( d1 d2 -- d1-d2 ) dnegate d+ ; \ No newline at end of file diff --git a/disks/images/f/editor.fb b/disks/images/f/editor.fb new file mode 100644 index 0000000..80a9b95 --- /dev/null +++ b/disks/images/f/editor.fb @@ -0,0 +1 @@ +\ Full-Screen Editor UH 02Nov86 Dieses File enthaelt den Full-Screen Editor fuer die CP/M - volksFORTH-Version. Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- Funktion und des sichtbaren Laden von Screens (showload). Durch die integrierte Tastaturtabelle (keytable) laesst sich dieKommandobelegung der Tasten auf einfache Art und Weise aendern. Anregungen, Kritik und Verbesserungsvorschlaege bitte an: U. Hoffmann Harmsstrasse 71 2300 Kiel \ Load Screen for the Editor UH 03Nov86 UH 27Nov87 Onlyforth cr 1 $1E +thru Onlyforth \ String primitves 27Nov87 : delete ( buffer size count -- ) over umin dup >r - 2dup over r@ + -rot cmove + r> bl fill ; : insert ( string length buffer size -- ) rot over umin dup >r - over dup r@ + rot cmove> r> cmove ; : replace ( string length buffer size -- ) rot umin cmove ; \ usefull definitions and Editor vocabulary UH 27Nov87 : blank ( addr len -- ) bl fill ; : ?enough ( n --) depth 1- > abort" Not enough Parameters" ; : ?abort( ( f -- ) IF [compile] .( true abort" !" THEN [compile] ( ; Vocabulary Editor ' Forth | Alias F: immediate ' Editor | Alias E: immediate Editor also definitions \ move cursor with position-checking 23Nov86 | : c ( n --) \ checks the cursor position r# @ + dup 0 b/blk uwithin not Abort" There is a border!" r# ! ; \\ : c ( n --) \ goes thru the screens r# @ + dup b/blk 1- > IF 1 scr +! THEN dup 0< IF -1 scr +! THEN b/blk mod r# ! ; : c ( n --) \ moves cyclic thru the screen r# @ + b/blk mod r# ! ; \ calculate addresses UH 31Oct86 | Code *line ( l -- adr ) H pop H dad H dad H dad H dad H dad H dad Hpush jmp end-code | Code /line ( n -- c l ) H pop L A mov $3F ani A E mov 0 D mvi L A mov ral A L mov H A mov ral A H mov L A mov ral A L mov H A mov ral A H mov L A mov ral 3 ani H L mov A H mov dpush jmp end-code \\ | : *line ( l -- adr ) c/l * ; | : /line ( n -- c l ) c/l /mod ; \ calculate addresses UH 01Nov86 | : top ( -- ) r# off ; | : cursor ( -- n ) r# @ ; | : 'start ( -- adr ) scr @ block ; | : 'end ( -- adr ) 'start b/blk + ; | : 'cursor ( -- adr ) 'start cursor + ; | : position ( -- c l ) cursor /line ; | : line# ( -- l ) position nip ; | : col# ( -- c ) position drop ; | : 'line ( -- adr ) 'start line# *line + ; | : 'line-end ( -- adr ) 'line c/l + 1- ; | : #after ( -- n ) c/l col# - ; | : #remaining ( -- n ) b/blk cursor - ; | : #end ( -- n ) b/blk line# *line - ; \ move cursor directed UH 01Nov86 | : curup c/l negate c ; | : curdown c/l c ; | : curleft -1 c ; | : curright 1 c ; | : +tab \ 1/4 line forth cursor $10 / 1+ $10 * cursor - c ; | : -tab \ 1/8 line back cursor 8 mod negate dup 0= 8 * + c ; | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; | : #after c ; \ show border UH 27Nov87&15 | Constant dx 1 | Constant dy | : horizontal ( row -- row' ) dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ; | : vertical ( row -- row' ) l/s 0 DO dup dx 1- at Ascii | emit row dx c/l + at Ascii | emit 1+ LOOP ; | : border dy 1- horizontal vertical horizontal drop ; | : edit-at ( -- ) position swap dy dx d+ at ; Forth definitions : updated? ( -- f) scr @ block 2- @ 0< ; \ display screen UH 02Nov86 UH 27NouhoEditor definitions | Variable isfile' | Variable imode | : .updated ( -- ) 7 0 at updated? IF 4 spaces ELSE ." not " THEN ." updated" ; | : redisplay ( line# -- ) dup dy + dx at *line 'start + c/l type ; | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ; | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at imode @ IF ." insert " exit THEN ." overwrite" ; | : .screen l/s 0 DO I redisplay LOOP ; | : .all .title .screen ; \ check errors UH 02Nov86 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip Abort" You would lose a line" ; | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > IF line# redisplay true Abort" You would lose a char" THEN ; | : ?end 1 ?fit ; \ programmer's id UH 02Nov86 $12 | Constant id-len Create id id-len allot id id-len erase | : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; | : ?stamp ( -- ) updated? IF stamp THEN ; | : get-id ( -- ) id c@ ?exit id on cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at id id-len 2 /string expect rvsoff span @ id 1+ c! ; \ update screen-display UH 02Dec86 | : emptybuf prev @ 2+ dup on 4+ off ; | : undo emptybuf .all ; | : modified updated? ?exit update .updated ; | : linemodified modified line# redisplay ; | : screenmodified modified l/s line# ?DO I redisplay LOOP ; | : .modified ( -- ) dy l/s + 4+ 0 at scr @ . updated? not IF ." un" THEN ." modified" ?stamp ; \ leave editor UH 02Dec86 UH 23Feb88| Variable (pad (pad off | : memtop ( -- adr) sp@ $100 - ; | Create char 1 allot ( | Variable imode ) imode off | : setimode imode on .title ; | : clrimode imode off .title ; | : flipimode ( -- ) imode @ 0= imode ! .title ; | : done ( -- ) ['] (quit is 'quit ['] (error errorhandler ! quit ; | : update-exit ( -- ) .modified done ; | : flushed-exit ( -- ) .modified save-buffers done ; \ handle lines UH 01Nov86 | : (clear-line 'line c/l blank ; | : clear-line (clear-line linemodified ; | : clear> 'cursor #after blank linemodified ; | : delete-line 'line #end c/l delete screenmodified ; | : backline curup delete-line ; | : (insert-line ?bottom 'line c/l over #end insert (clear-line ; | : insert-line (insert-line screenmodified ; \ handle characters UH 01Nov86 | : delete-char 'cursor #after 1 delete linemodified ; | : backspace curleft delete-char ; | : (insert-char ?end 'cursor 1 over #after insert ; | : insert-char (insert-char bl 'cursor c! linemodified ; | : putchar ( --) char c@ imode @ IF (insert-char THEN 'cursor c! linemodified curright ; \ stack lines UH 31Oct86 | Create lines 4 allot \ { 2+pointer | 2base } | : 'lines ( -- adr) lines 2@ + ; | : @line 'lines memtop u> Abort" line buffer full" 'line 'lines c/l cmove c/l lines +! ; | : copyline @line curdown ; | : line>buf @line delete-line ; | : !line c/l negate lines +! 'lines 'line c/l cmove ; | : buf>line lines @ 0= Abort" line buffer empty" ?bottom (insert-line !line screenmodified ; \ stack characters UH 01Nov86 | Create chars 4 allot \ { 2+pointer | 2base } | : 'chars ( -- adr) chars 2@ + ; | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" 'cursor c@ 'chars c! 1 chars +! ; | : copychar @char curright ; | : char>buf @char delete-char ; | : !char -1 chars +! 'chars c@ 'cursor c! ; | : buf>char chars @ 0= Abort" char buffer empty" ?end (insert-char !char linemodified ; \ switch screens UH 03Nov86 UH 27Nov87 | Variable r#' r#' off | Variable scr' scr' off ( | Variable isfile' ) isfile@ isfile' ! | : associate \ switch to alternate screen isfile' @ isfile@ isfile' ! isfile ! scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ; | : n ?stamp 1 scr +! .all ; | : b ?stamp -1 scr +! .all ; | : a ?stamp associate .all ; \ shadow screens UH 03Nov86 Variable shadow shadow off | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; | : >shadow ?stamp \ switch to shadow screen (shadow dup scr @ u> not IF negate THEN scr +! .all ; \ load and show screens UH 06Mar88 ' name >body &10 + | Constant 'name | : showoff ['] exit 'name ! curoff rvsoff ; | : show ( -- ) blk @ 0= IF showoff exit THEN >in @ 1- r# ! curoff edit-at curon stop? IF showoff true Abort" Break! " THEN blk @ scr @ - IF blk @ scr ! rvsoff curoff .all rvson curon THEN ; | : showload ( -- ) ?stamp save-buffers ['] show 'name ! curon rvson ['] .status >body push ['] noop is .status scr @ scr push scr off r# push r# @ (load showoff ; \ find strings UH 01Nov86 | Variable insert-buffer | Variable find-buffer | : 'insert ( -- addr ) insert-buffer @ ; | : 'find ( -- addr ) find-buffer @ ; | : .buf ( addr -- ) count type ." |" &80 col - spaces ; | : get ( addr -- ) >r at? r@ .buf 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN at r> .buf ; | : get-buffers dy l/s + 2+ dx 1- 2dup at ." find: |" 'find get swap 1+ swap 2- at ." ? replace: |" 'insert get ; \ search for string UH 02Nov86 UH 27Nov87 | : skip ( addr -- addr' ) 'find c@ + ; | : find? ( -- addr T | F ) 'find count 'cursor #remaining "search ; | : "find ( -- r# scr ) find? IF skip 'start - scr @ exit THEN ?stamp capacity scr @ 1+ ?DO 'find count I dup 5 5 at 4 .r block b/blk "search IF skip I block - I endloop exit THEN stop? Abort" Break! " LOOP true Abort" not found!" ; \ replace strings UH 03Nov86 UH 27Nov87| : replace? ( -- f ) dy l/s + 3+ dx 3 - at key dup #cr = IF line# redisplay true Abort" Break!" THEN capital Ascii R = ; | : "mark ( -- ) r# push 'find count dup negate c edit-at rvson type rvsoff ; | : (replace 'insert c@ 'find c@ - ?fit 'find c@ negate c 'cursor #after 'find c@ delete 'insert count 'cursor #after insert 'insert c@ c modified ; | : "replace get-buffers BEGIN "find dup scr @ - swap scr ! IF .all THEN r# ! "mark replace? IF (replace THEN line# redisplay REPEAT ;\ Control-Characters 'normal' CP/M uho 08May2005 Forth definitions : Ctrl ( -- c ) name 1+ c@ $1F and state @ IF [compile] Literal THEN ; immediate $7F Constant #del Editor definitions \ | : flipimode imode @ 0= imode ! ; \ Try a Screen-Editor 'normal' CP/M UH 29Nov86 Create keytable Ctrl E c, Ctrl S c, Ctrl X c, Ctrl D c, Ctrl I c, Ctrl J c, Ctrl O c, Ctrl K c, Ctrl P c, Ctrl L c, Ctrl H c, Ctrl H c, #del c, Ctrl G c, Ctrl T c, Ctrl Y c, Ctrl N c, Ctrl V c, Ctrl Z c, #cr c, Ctrl F c, Ctrl A c, Ctrl \ c, Ctrl U c, Ctrl Q c, #esc c, Ctrl W c, Ctrl C c, Ctrl R c, Ctrl ] c, Ctrl B c, here keytable - Constant #keys \ Try a screen Editor UH 29Nov86 Create: actiontable curup curleft curdown curright line>buf char>buf buf>line buf>char copyline copychar backspace backspace backspace delete-char insert-char delete-line insert-line flipimode ( clear-line ) clear> +tab -tab ( top >""end ) "replace undo update-exit flushed-exit ( showload ) >shadow n b a mark ; here actiontable - 2/ 1- #keys - ?abort( # of actions) \ find keys UH 01Nov86 | Code findkey ( key -- addr/default ) H pop L A mov keytable H lxi #keys $100 * D lxi [[ M cmp 0= ?[ actiontable H lxi 0 D mvi D dad D dad M E mov H inx M D mov D push next ]? H inx E inr D dcr 0= ?] ' putchar H lxi hpush jmp end-code \\ | : findkey ( key -- adr/default ) #keys 0 DO dup keytable F: I + c@ = IF drop E: actiontable F: I 2* + @ endloop exit THEN LOOP drop ['] putchar ; \ allocate buffers UH 01Nov86 c/l 2* | Constant cstack-size | : nextbuf ( adr -- adr' ) cstack-size + ; | : ?clearbuffer pad (pad @ = ?exit pad dup (pad ! nextbuf dup find-buffer ! 'find off nextbuf dup insert-buffer ! 'insert off nextbuf dup 0 chars 2! nextbuf 0 lines 2! ; \ enter and exit the editor, editor's loop UH 02Nov86| Variable jingle jingle on | : bell 07 con! jingle off ; | : clear-error jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; | : fullquit BEGIN ?clearbuffer edit-at key dup char c! findkey execute clear-error REPEAT ; | : fullerror ( string --) jingle @ IF bell THEN dy l/s + 1+ dx $16 + at rvson count type rvsoff &80 col - spaces scr @ capacity 1- min 0 max scr ! .title quit ; | : install ( -- ) ['] fullquit Is 'quit ['] fullerror errorhandler ! ; \ enter and exit the Editor UH 02Nov86 Forth definitions : v ( -- ) E: 'start drop get-id install ?clearbuffer page curoff border .all quit ; : l ( scr -- ) 1 ?enough scr ! E: top F: v ; \ savesystem uho 09May2uho : savesystem \ save image E: id off (pad off savesystem ; | : >find ?clearbuffer >in push bl word count 'find 1+ place bl 'find 1+ dup >r count dup >r + c! r> 2+ 'find c! bl r> c! ; | : %view ( -- ) >find ' >name 4- @ (view ?dup 0= Abort" hand made" scr ! E: top curdown find? 0= IF ." From Scr # " scr @ u. true Abort" wrong file" THEN skip 'start - 1- r# ! ; : view ( -- ) %view scr @ list ; : fix ( -- ) %view v ; \ No newline at end of file diff --git a/disks/images/f/f.com b/disks/images/f/f.com new file mode 100644 index 0000000..89c5944 Binary files /dev/null and b/disks/images/f/f.com differ diff --git a/disks/images/f/fileint.fb b/disks/images/f/fileint.fb new file mode 100644 index 0000000..435de32 --- /dev/null +++ b/disks/images/f/fileint.fb @@ -0,0 +1 @@ +\ CP/M 2.2 File-Interface (3.80a) UH 05Oct87 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. Damit ist Zugriff auf normale CP/M-Files moeglich. Wenn ein File mit USE benutzt wird, beziehen sich alle Worte, die mit dem Massenspeicher arbeiten, auf dieses File. Benutzung: USE \ benutze ein schon existierendes File FILE \ erzeuge ein Forthfile mit dem Namen . MAKE \ Erzeuge ein File mit und ordne \ es dem aktuellen Forthfile zu. MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen . INCLUDE \ Lade File mit Forthnamen ab Screen 1 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M) \ CP/M 2.2 File-Interface load-Screen UH 18Feb88OnlyForth 2 load \ view numbers for this file 3 4 thru \ DOS File Functions 5 $11 thru \ Forth File Functions $12 $16 thru \ User Interface File source.fb \ Define already existing Files File fileint.fb File startup.fbr ' (makeview Is makeview ' remove-files Is custom-remove ' file-r/w Is r/w ' noop Is drvinit \ include startup.fb \ load Standard System \ Build correct view-numbers for this file UUH 19Nov87 | : fileintview ( -- ) $400 blk @ + ; ' fileintview Is makeview \ File Control Blocks UH 18Feb88Dos definitions also | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ; &11 Constant filenamelen 0 2 | Fcbyte nextfile immediate 1 Fcbyte drive ' drive | Alias >dosfcb filenamelen 3 - Fcbyte filename 3 Fcbyte extension &21 + \ ex, s1, s2, rc, d0, ... dn, cr 2 Fcbyte record \ r0, r1 1+ \ r2 2 Fcbyte opened 2 Fcbyte fileno 2 Fcbyte filesize \ in 128-Byte-Records 4 Fcbyte position Constant b/fcb \ dos primitives UH 10Oct87 ' 2- | Alias body> ' 2- | Alias dosfcb> : drive! ( drv -- ) $0E bdos ; : search0 ( dosfcb -- dir ) $11 bdosa ; : searchnext ( dosfcb -- dir ) $12 bdosa ; : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ; : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ; : createfile ( dosfcb -- f ) $16 bdosa dos-error? ; : size ( dos -- size ) dup $23 bdos dosfcb> record @ ; : drive@ ( -- drv ) 0 $19 bdosa ; : killfile ( dosfcb -- ) $13 bdos ; \ File sizes UH 05Oct87 : (capacity ( fcb -- n ) \ filecapacity in blocks filesize @ rec/blk u/mod swap 0= ?exit 1+ ; : in-range ( block fcb -- ) (capacity u< not Abort" beyond capacity!" ; Forth definitions : capacity ( -- n ) isfile@ (capacity ; Dos definitions \ (open UH 18Feb88 : (open ( fcb -- ) dup opened @ IF drop exit THEN dup position 0. rot 2! dup >dosfcb openfile Abort" not found!" dup opened on dup >dosfcb size swap filesize ! ; : (make ( fcb -- ) dup >dosfcb killfile dup >dosfcb createfile Abort" directory full!" dup position 0. rot 2! dup filesize off opened on offset off ; : file-r/w ( buffer block fcb f -- f ) over 0= Abort" no Direct Disk IO supported! " >r dup (open 2dup in-range r> (r/w ; \ Print Filenames UH 10Oct87 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN fcb dosfcb> case? IF ." DEFAULT" exit THEN body> >name .name ; : .drive ( fcb -- ) drive c@ ?dup 0=exit [ Ascii A 1- ] Literal + emit Ascii : emit ; : .dosfile ( fcb -- ) dup filename 8 -trailing type Ascii . emit extension 3 type ; \ Print Filenames UH 10Oct87 : tab ( -- ) col &59 > IF cr exit THEN &20 col &20 mod - 0 max spaces ; : .fcb ( fcb -- ) dup fileno @ 3 u.r tab dup .file tab dup .drive dup .dosfile tab dup opened @ IF ." opened" ELSE ." closed" THEN 3 spaces base push decimal (capacity 3 u.r ." kB" ; \ Filenames UH 05Oct87 : !name ( addr len fcb -- ) dup >r filename filenamelen bl fill over 1+ c@ Ascii : = IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r> ELSE 0 THEN r@ drive c! r> dup filename 2swap filenamelen 1+ min bounds ?DO I c@ Ascii . = IF drop dup extension ELSE I c@ over c! 1+ THEN LOOP 2drop ; : !fcb ( fcb -- ) dup opened off name count rot !name ; \ Print Directory UH 18Nov87 | Create dirbuf b/rec allot dirbuf b/rec erase | Create fcb0 b/fcb allot fcb0 b/fcb erase | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ; | : (expand ( addr len -- ) false -rot bounds ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ; | : expand ( fcb -- ) \ expand * to ??? dup filename 8 (expand extension 3 (expand ; : (dir ( addr len -- ) fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0 BEGIN dup dos-error? not WHILE $20 * dirbuf + dosfcb> tab .dosfile fcb0 >dosfcb searchnext stop? UNTIL drop ; \ File List UH 10Oct87 User file-link file-link off | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ; Forth definitions : forthfiles ( -- ) file-link @ BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ; Dos definitions \ Close a file UH 10Oct87 ' save-buffers >body $0C + @ | Alias backup | : filebuffer? ( fcb -- fcb bufaddr/flag ) prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; | : flushfile ( fcb -- ) \ flush file buffers BEGIN filebuffer? ?dup WHILE dup backup emptybuf REPEAT drop ; : (close ( fcb -- ) \ close file in fcb dup flushfile dup opened dup @ 0= IF 2drop exit THEN off >dosfcb closefile Abort" not found!" ; \ Create fcbs UH 10Oct87 : !files ( fcb -- ) dup isfile ! fromfile ! ; ' r@ | Alias newfcb Forth definitions : File ( -- ) Create here >r b/fcb allot newfcb b/fcb erase last @ count $1F and newfcb !name #file newfcb fileno ! file-link @ newfcb nextfile ! r> file-link ! Does> !files ; : direct 0 !files ; \ flush buffers & misc. UH 10Oct87 UH 28Nov87Dos definitions : save-files ( -- ) file-link BEGIN @ ?dup WHILE dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ; ' save-files Is save-dos-buffers \ : close-files ( -- ) file-link \ BEGIN @ ?dup WHILE dup (close REPEAT ; Forth definitions : file? isfile@ .file ; \ print current file : list ( n -- ) 3 spaces file? list ; \ words for viewing UH 10Oct87 Forth definitions | $200 Constant viewoffset \ max. %512 kB files : (makeview ( -- n ) \ calc. view filed for a name blk @ dup 0= ?exit loadfile @ ?dup IF fileno @ viewoffset * + THEN ; : (view ( blk -- blk' ) \ select file and leave block dup 0=exit viewoffset u/mod file-link BEGIN @ dup WHILE 2dup fileno @ = UNTIL !files drop ; \ not found: direct access \ FORGETing files UH 10Oct87 | : remove? ( dic symb addr -- dic symb addr f ) dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; | : remove-files ( dic symb -- dic symb ) \ flush files ! isfile@ remove? nip IF direct THEN fromfile @ remove? nip IF fromfile off THEN file-link BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT file-link remove ; \ print a list of all buffers UH 20Oct86 : .buffers prev BEGIN @ ?dup WHILE stop? abort" stopped" cr dup u. dup 2+ @ dup 1+ IF ." Block: " over 4+ @ 5 .r ." File : " [ Dos ] .file dup 6 + @ 0< IF ." updated" THEN ELSE ." Buffer empty" drop THEN REPEAT ; \ File Interface User words UH 11Oct87 | : same ( addr -- ) >in ! ; : open isfile@ (open offset off ; : close isfile@ (close ; : assign close isfile@ !fcb open ; : make isfile@ dup !fcb (make ; | : isfile? ( addr -- addr f ) \ is adr a fcb? file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ; : use >in @ name find \ create a fcb if not present IF isfile? IF execute drop exit THEN THEN drop dup same File same ' execute open ; \ File Interface User words UH 25May88 : makefile >in @ File dup same ' execute same make ; : emptyfile isfile@ >dosfcb createfile ; : from isfile push use ; : loadfrom ( n -- ) isfile push fromfile push use load close ; : include 1 loadfrom ; : eof ( -- f ) isfile@ dup filesize @ swap record @ = ; : files " *.*" count (dir ; : files" Ascii " word count 2dup upper (dir ; ' files Alias dir ' files" Alias dir" \ extend Files UH 20Nov87 | : >fileend isfile@ >dosfcb size drop ; | : addblock ( n -- ) \ add block n to file dup buffer under b/blk bl fill isfile@ rec/blk over filesize +! false file-r/w IF close Abort" disk full!" THEN ; : more ( n -- ) open >fileend capacity swap bounds ?DO I addblock LOOP close open close ; : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ; 0 Drive: a: Drive: b: Drive: c: Drive: d: 5 + Drive: j: drop \ save memory-image as disk-file UH 29Nov86 Forth definitions : savefile ( from count -- ) \ filename isfile push makefile bounds ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!" b/rec +LOOP close ; \ Status UH 10OCt87 : .blk ( -- ) blk @ ?dup 0=exit dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ; ' .blk Is .status \ No newline at end of file diff --git a/disks/images/f/hashcash.fb b/disks/images/f/hashcash.fb new file mode 100644 index 0000000..a456b88 --- /dev/null +++ b/disks/images/f/hashcash.fb @@ -0,0 +1 @@ +\ HashCash Suchalgorithmus UH 11Nov86 Ein Algorithmus, der die Dictionarysuche beschleunigt: Zuerst wird uebr das gesucht Wort gehasht und in in einer Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normalgesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchenherunter. Hinzu kommen die Worte: cash, hash-thread, erase-cash, 'cash, und found? Im Kernal neudefiniert oder gepatched werden muessen: (find, hide, reveal, forget-words (find und (forget benutzen jejweils die alten Worte. Sie muessenumbenannt oder in die neuen Worte eingebettet werden. \ Hash Cash fuer volksFORTH UH 11Nov86 Create cash $200 allot ' Forth >body Constant hash-thread : erase-cash ( -- ) cash $200 erase ; erase-cash 1 3 +thru patch (find ( patch forget-words ) ' forget-words \ forget-words dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen dup ' (forget >body $12 + ! \ Adresse, sodass das automa- dup ' empty >body 8 + ! \ tische Patchen nicht klappt. ' save >body 4+ ! patch hide patch reveal forget (patch save \ 'cash found? hfind UH 23Oct86 : 'cash ( nfa -- 'cash ) count $1F and under bounds ?DO I c@ + LOOP $FF and 2* cash + ; : found? ( str nfa -- f ) count rot count rot over = IF swap -text 0= exit THEN drop 2drop false ; : (find ( str thread -- str false | nfa true ) dup hash-thread - IF (find exit THEN drop dup 'cash @ 2dup found? IF nip true exit THEN drop hash-thread (find dup 0= ?exit over dup 'cash ! ; \ Kernal changes UH 23Oct86 ' hide >body @ | Alias last? : hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ; : reveal last? IF dup dup 'cash ! 2- current @ ! THEN ; ' clear >body 6 + @ | Alias forget-words | : forget-words erase-cash forget-words ; : .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ; \ patching UH 23Oct86 : (patch ( new old -- ) ['] cash 0 DO i @ over = IF cr I u. over I ! THEN LOOP 2drop ; : patch \ name >in @ ' swap >in ! dup >name 2- context push context ! ' (patch ; \ No newline at end of file diff --git a/disks/images/f/install.fb b/disks/images/f/install.fb new file mode 100644 index 0000000..a14b07a --- /dev/null +++ b/disks/images/f/install.fb @@ -0,0 +1 @@ +\\ Install Editor Dieses File enthaelt einen Installer fuer den Editor. Es werden nacheinander die Tasten erfragt, die einen bestimmten Befehl ausloesen sollen. Damit ist es moeglich, die Tastatur an die individuellen Beduerfnisse anzupassen. \ install Editor UH 17Nov86 Onlyforth Editor also save warning on : tab &20 col &20 mod - spaces ; : .key ( c -- ) dup $7E > IF ." $" u. exit THEN dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; : install \ install editor's keyboard page ." Entsprechende Tasten druecken. (Blank uebernimmt.)" #keys 0 ?DO cr I 2* actiontable + @ >name .name tab ." : " I keytable + dup c@ .key tab ." -> " key dup bl = IF drop dup c@ THEN dup .key swap c! LOOP ; --> \ define action-names UH 29Nov86: :a ( addr -- adr' ) dup @ Alias 2+ ; actiontable :a up :a left :a down :a right :a push-line :a push-char :a pull-line :a pull-char :a copy-line :a copy-char :a backspace :a backspace :a backspace :a delete-char :a insert-char :a delete-line :a insert-line :a flipimode ( :a erase-line) :a clear-to-right :a new-line :a +tab :a -tab ( :a home :a to-end ) :a search :a undo :a update-exit :a flushed-exit ( :a showload ):a shadow-screen :a next-Screen :a back-Screen :a alter-Screen :a mark-screen drop warning off install empty UH 17Nov86 \ No newline at end of file diff --git a/disks/images/f/kernel.com b/disks/images/f/kernel.com new file mode 100644 index 0000000..c2b39d1 Binary files /dev/null and b/disks/images/f/kernel.com differ diff --git a/disks/images/f/meta.com b/disks/images/f/meta.com new file mode 100644 index 0000000..a4b05fe Binary files /dev/null and b/disks/images/f/meta.com differ diff --git a/disks/images/f/port8080.fb b/disks/images/f/port8080.fb new file mode 100644 index 0000000..c0bf563 --- /dev/null +++ b/disks/images/f/port8080.fb @@ -0,0 +1 @@ +\ 8080-Portzugriff UH 11Nov86 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit Adressen anzusprechen. Der Code ist leider selbstmodifizierend, da beim 8080 die Portadresse im Code ausdruecklich angegeben werden muss. Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen, kann auch das File portz80.scr benutzt werden, indem die Z80-IO-Befehle (16Bit-Adressen) benutzt werden. \ 8080-Portzugriff pc@, pc! 15Jul86 ' 0 | Alias patch Code pc@ ( addr -- c ) H pop L A mov here 4 + sta patch in 0 H mvi A L mov Hpush jmp end-code Code pc! ( c addr -- ) H pop L A Mov here 6 + sta H pop L A mov patch out Next end-code \ No newline at end of file diff --git a/disks/images/f/portz80.fb b/disks/images/f/portz80.fb new file mode 100644 index 0000000..1e11c85 --- /dev/null +++ b/disks/images/f/portz80.fb @@ -0,0 +1 @@ +\ Z80-Portzugriff UH 05Nov86 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit Adressen anzusprechen. Einige Komputer, so die der Schneider Serie dekodieren ihre Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit Adressen angesprochen werden muessen. Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen. \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86 Assembler definitions | : Z80-io ( base -- ) \ define special Z80-io instruction Create c, Does> ( reg -- ) $ED c, c@ swap 8 * + c, ; $40 Z80-io (c)in $41 Z80-io (c)out Forth definitions --> \ store and fetch values with 16-bit port-adresses UH 05Nov86 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr H pop IP push H B mvx L (c)in 0 H mvi IP pop hpush jmp end-code Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr H pop D pop IP push H B mvx E (c)out IP pop Next end-code \ No newline at end of file diff --git a/disks/images/f/primed.fb b/disks/images/f/primed.fb new file mode 100644 index 0000000..e4194d3 --- /dev/null +++ b/disks/images/f/primed.fb @@ -0,0 +1 @@ +\\ Primitivst Editor zur Installation UH 17Nov86 Da zur Installationszeit der Full-Screen Editor noch nicht funtionsfaehig ist, muessen die zu aendernden Screens auf eine andere Weise ge{nder werden: mit dem primitivst Editor PRIMED, der nur ein Benutzer wort enthaelt: Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen, dann mit "ll NEW" den Screen aendern. Es koennen immer nur ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW. Nach jeder Eingabe von RETURN wird die eingegebene Zeile in den Screen uebernommen, und der ganze Screen zur Kontrolle nocheinmal ausgegeben. \ primitivst Editor PRIMED UH 17Nov86 | : !line ( adr count line# -- ) scr @ block swap c/l * + dup c/l bl fill swap cmove update ; : new ( n -- ) l/s 1+ swap ?DO cr I . pad c/l expect span @ 0= IF leave THEN pad span @ I !line cr scr @ list LOOP ; \ PRIMED Demo-Screen Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender Eingabe dieses Textes Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit "0 NEW" erzeugt. Ulrich Hoffmann \ No newline at end of file diff --git a/disks/images/f/printer.fb b/disks/images/f/printer.fb new file mode 100644 index 0000000..b642433 --- /dev/null +++ b/disks/images/f/printer.fb @@ -0,0 +1 @@ +\\ Printer Interface 08Nov86 Dieses File enthaelt das Printer Interface zwischen volksFORTH und dem Drucker. Damit ist es moeglich Source-Texte auf bequeme Art und Weise in uebersichtlicher Form auszudrucken (6 auf eine Seite). In Verbindung mit dem Multitasker ist es moeglich, auch Texte imHintergrund drucken zu lassen und trotztdem weiterzuarbeiten. \ Printer Interface Epson RX80 18Aug86\ angepasst auf M 130i 07dec85we Onlyforth Variable shadow capacity 2/ shadow ! \ s. Editor Vocabulary Printer Printer definitions also | Variable printsem printsem off 01 +load 04 0C +thru \ M 130i - Printer \ 01 03 +thru 06 0C +thru \ Fujitsu - Printer Onlyforth \ Printer p! and controls UH 02Nov87 | : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ; : p! ( n --) BEGIN pause stop? IF printsem unlock true abort" stopped! " THEN ready? UNTIL [ Dos ] 5 bios ; | : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ; 07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET 1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF 0F | ctrl: (+17cpi 12 | ctrl: (-17cpi \ Printer Escapes 24dec85 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; \ Printer Escapes 29jan86 Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii P on: (10cpi Ascii P off: (12cpi : 10cpi (-17cpi (10cpi ; : 12cpi (-17cpi (12cpi ; : 17cpi (10cpi (+17cpi ; : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Escapes 16Jul86 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" Ascii 2 esc: 1/6" Ascii T esc: suoff Ascii N esc: +jump Ascii O esc: -jump Ascii G esc: +dark Ascii H esc: -dark Ascii 4 esc: +cursive Ascii 5 esc: -cursive Ascii M esc: 12cpi Ascii P | esc: (-12cpi : 10cpi (-12cpi (-17cpi ; : 17cpi (-12cpi (+17cpi ; ' 10cpi Alias pica ' 12cpi Alias elite \ Printer Escapes 16Jul86 | : ESC2 ( 8b0 8b1 --) ESC p! p! ; | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; Ascii W on: +wide Ascii W off: -wide Ascii - on: +under Ascii - off: -under Ascii S on: sub Ascii S off: super Ascii p on: +prop Ascii p off: -prop : lines ( #.of.lines --) Ascii C ESC2 ; : "long ( inches --) 0 lines p! ; : american 0 Ascii R ESC2 ; : german 2 Ascii R ESC2 ; : normal 12cpi american suoff 1/6" 0C "long RET ; \ Printer Output 04Jul86 : prinit ; \ initializing Printer | Variable pcol pcol off | Variable prow prow off | : pemit ( 8b --) p! 1 pcol +! ; | : pcr ( --) RET LF 1 prow +! pcol off ; | : pdel ( --) DEL pcol @ 1- 0 max pcol ! ; | : ppage ( --) FF prow off pcol off ; | : pat ( row col --) over prow @ < IF ppage THEN swap prow @ - 0 ?DO pcr LOOP dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; | : pat? ( -- row col) prow @ pcol @ ; | : ptype ( adr len --) dup pcol +! bounds ?DO I c@ p! LOOP ; \ Printer output 28Jun86 | Output: >printer pemit pcr ptype pdel ppage pat pat? ; Forth definitions : print >printer normal ; : printable? ( char -- f) bl Ascii ~ uwithin ; \ Variables and Setup 23Oct86 Printer definitions $00 | Constant logo | Variable pageno | Create scr#s $0E allot \ enough room for 6 screens | : header ( -- ) 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV " 5 spaces file? -dark 1 pageno +! 17cpi ; \ Print 2 screens across on a page 03dec85 | : text? ( scr# -- f) block dup c@ printable? IF b/blk -trailing nip 0= THEN 0= ; | : pr ( scr# --) dup capacity 1- u> IF drop logo THEN 1 scr#s +! scr#s dup @ 2* + ! ; | : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r pad $101 bl fill swap block r@ + pad c/l cmove block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ; | : 2scr ( scr#1 scr#2 --) cr cr $1E spaces +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark cr l/s 0 DO 2dup I 2pr LOOP 2drop ; \ Printer 6 screens on a page 03dec85 | : pr-start ( --) scr#s off 1 pageno ! ; | : pagepr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ; | : shadowpr ( --) header scr#s off scr#s 2+ 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ; | : pr-flush ( -- f) scr#s @ dup \ any screens left over? IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN 0<> ; \ Printer 6 screens on a page 23Nov86Forth definitions : pthru ( first last --) printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN LOOP pr-flush IF pagepr THEN printsem unlock ; : document ( first last --) isfile@ IF capacity 2/ shadow ! THEN printsem lock output push print pr-start 1+ swap ?DO I text? IF I pr I shadow @ + pr THEN scr#s @ 6 = IF shadowpr THEN LOOP pr-flush IF shadowpr THEN printsem unlock ; : listing ( --) 0 capacity 2/ 1- document ; \ Printerspool 03Nov86 \needs Task \\ | Input: noinput 0 false drop 2drop ; $100 $200 noinput Task spooler keyboard : spool ( from to -- ) isfile@ spooler 3 pass isfile ! pthru stop ; \ No newline at end of file diff --git a/disks/images/f/readme.txt b/disks/images/f/readme.txt new file mode 100644 index 0000000..8e45d95 --- /dev/null +++ b/disks/images/f/readme.txt @@ -0,0 +1,76 @@ +volksFORTH Readme + +Version 1.2 +18th August 2006 (cas) + +volksFORTH is a 16bit Forth System produced by the german Forth Gesellschaft e.V. Major development of this system was done between 1985 until 1989. The volksFORTH Project was revived in 2005 with the goal to produce a manageable Forthsystem for computer systems with restricted system resources. + +Some modern Forth Systems were influenced by or were derived from volksFORTH (GNU-Forth, bigForth). + +The current Version of VolksForth is 3.81. Work on Version 3.90 has started. + +At this time volksFORTH is available for this Systems: + +volksFORTH MS-DOS (Intel x86 Architecture i8086-ia64) +volksFORTH 6502 (Commodore 64, Commodore Plus 4, Commodre C16, Atari XL/XE, Apple I) +volksFORTH Z80 (CP/M, Amstrad CPC) +volksFORTH 68000 (Atari ST) + +VolksForth is in work for this Systems: + +VolksForth MS-DOS (Atari Portfolio) +VolksForth 6502 (Apple II, Commodore PET) +VolksForth Z80 (Schneider CPC AMSDOS) +VolksForth 68000 (Mac Classic) + +Copyright + +The volksFORTH Sources are made available under the terms of the +BSD License - http://www.opensource.org/licenses/bsd-license.php + +The Handbook is Copyright (c) 1985 - 2006 Forth Gesellschaft +e.V. ( Klaus Schleisiek, Ulrich Hoffmann, Bernd Pennemann, Georg Rehfeld +and Dietrich Weineck). + +The Handbook, binary Files and Source-code for volksFORTH as well as Information about +Forth Gesellschaft are available on the Forth Gesellschaft Web-server at +http://www.forth-ev.de/ + +(most of the Information is still in german. We are planning to provide future versions with english documentation) + +Information and Help about the Programming Language Forth can be found on the Internet, +starting with the Website of the Forthgesellschaft, or in the Usenet Forum de.comp.lang.forth (via Google Groups: http://groups.google.de/group/de.comp.lang.forth ) + +Authors of volksForth/ultraForth are + + - Bernd Pennemann, + - Claus Vogt, + - Dietrich Weineck, + - Georg Rehfeld, + - Klaus Schleisieck, + - Ulrich Hoffmann, + - Ewald Rieger, + - Carsten Strotmann. + +Details for CP/M-volksFORTH + +* System Prerequisites +CP/M or CPM+ system with floppy drive or harddrive + + +* Using volksFORTH in an Emulator + * volksForth 3.80a for CP/M has been tested in these + Emulators: + * YAZE-AG - http://www.mathematik.uni-ulm.de/users/ag/yaze/ + +* Website: + VolksForth is available ob SourceForge + http://volksForth.sf.net + and on the Website of Forth Gesellschaft (German Chapter of Forth Interst Group, FIG) + http://www.forth-ev.de + +The Forth Live-Linux CD-ROM (available in the Download-section of the Forth Gesellschaft Website) includes the current Versions of volksFORTH direct usable without Installation including the Handbooks as PDF-Files. + +Have fun with volksFORTH +the volksFORTH Team + diff --git a/disks/images/f/relocate.fb b/disks/images/f/relocate.fb new file mode 100644 index 0000000..832e6bd --- /dev/null +++ b/disks/images/f/relocate.fb @@ -0,0 +1 @@ +\\ Relocate System 11Nov86 Dieses File enthaelt das Utility-Wort BUFFERS. Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen, die volksFORTH benutzt. Voreingestellt sind 4 Buffer. Benutzung: nn BUFFERS \ Relocate a system 16Jul86 | : relocate-tasks ( mainup -- ) up@ dup BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ; | : relocate ( stacklen rstacklen -- ) 2dup + b/buf + 2+ limit origin - u> abort" kills all buffers" over pad $100 + origin - u< abort" cuts the dictionary" dup udp @ $40 + u< abort" a ticket to the moon with no return ..." flush empty over + origin + origin $0A + ! \ r0 origin + dup relocate-tasks \ multitasking link 6 - origin 8 + ! \ s0 cold ; --> \ bytes.more buffers 29Jun86 | : bytes.more ( n+- -- ) up@ origin - + r0 @ up@ - relocate ; : buffers ( +n -- ) b/buf * 4+ limit r0 @ - swap - bytes.more ; \ No newline at end of file diff --git a/disks/images/f/savesys.fb b/disks/images/f/savesys.fb new file mode 100644 index 0000000..a07add8 --- /dev/null +++ b/disks/images/f/savesys.fb @@ -0,0 +1 @@ +\\ savesystem 11Nov86 Dieses File enthaelt das Utility-Wort SAVESYSTEM. Mit ihm kann man das gesamte System als File auf Disk schreiben. Achtung: Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM der Heap geloescht! Benutzung: SAVESYSTEM \ savsystem 05Nov86 : savesystem \ filename save $100 here over - savefile ; \\ Einfaches savesystem 18Aug86 | : message ( -- ) base push decimal cr ." ready for SAVE " here 1- $100 / u. ." VOLKS4TH.COM" cr ; : savesystem ( -- ) save message bye ; \ No newline at end of file diff --git a/disks/images/f/see.fb b/disks/images/f/see.fb new file mode 100644 index 0000000..d91fa7d --- /dev/null +++ b/disks/images/f/see.fb @@ -0,0 +1 @@ +\ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86 Dieses File enthaelt einen Decompiler, der bereits kompilierte Worte wieder in Sourcetextform bringt. Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang erkannt und umgeformt. Ein Decompiler kann aber keine (Stack-) Kommentare wieder herzaubern, die Benutzung der Screens und dann view, wird daher staerkstens empfohlen. Denn: Es ist immernoch ein Fehler drin! Und um den zu korrigieren, ist der Sourcetext dem Objektkode doch vorzuziehen. Benutzung: see \ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86 Onlyforth Tools also definitions 1 13 +thru \\ Produces compilable Forth source from normal compiled Forth. These source blocks are based on the works of Henry Laxen, Mike Perry and Wil Baden volksFORTH version: U. Hoffmann \ detacting does> 01Jul86 internal ' does> 4+ @ Alias (;code ' Forth @ 1+ @ Constant (dodoes> : does? ( IP - f ) dup c@ $CD ( call ) = swap 1+ @ (dodoes> = and ; \ indentation. 04Jul86Variable #spaces #spaces off : +in ( -- ) 3 #spaces +! ; : -in ( -- ) -3 #spaces +! ; : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; \ case defining words 01Jul86 : Case: ( -- ) Create: Does> swap 2* + perform ; : Associative: ( n -- ) Constant Does> ( n - index ) dup @ -rot dup @ 0 DO 2+ 2dup @ = IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; \ branching 04Jul86 Variable #branches Variable #branch : branch-type ( n -- a ) 6 * pad + ; : branch-from ( n -- a ) branch-type 2+ ; : branch-to ( n -- a ) branch-type 4+ ; : branched ( adr type -- ) \ Make entry in branch-table. #branches @ branch-type ! dup #branches @ branch-from ! 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } \ branching 01Jul86 : branch-back ( adr type -- ) \ : make entry in branch-table & reclassify branch-type.) over swap branched 2+ dup dup @ + swap 2+ ( loop-start,-end.) 0 #branches @ 1- ?DO over I branch-from @ u> IF LEAVE THEN dup I branch-to @ = IF ['] while I branch-type ! THEN -1 +LOOP 2drop ; \ branching 01Jul86: forward? ( ip -- f ) 2+ @ 0> ; : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] if branched exit THEN ['] until branch-back ; : branch+ ( ip -- ip' ) dup 4+ swap dup forward? IF ['] else branched exit THEN ['] repeat branch-back ; : (loop)+ ( ip -- ip' ) dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; : string+ ( ip -- ip' ) 2+ count + even ; : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; \ classify each word 25Aug86Forth &15 Associative: execution-class ] clit lit ?branch branch (do (." (abort" (;code (" (?do (loop (+loop unnest (is compile [ Case: execution-class+ 3+ 4+ ?branch+ branch+ 2+ string+ string+ (;code+ string+ 2+ 4+ 4+ 0= 4+ 4+ 2+ ; Tools \ first pass 01Jul86 : pass1 ( cfa -- ) #branches off >body BEGIN dup @ execution-class execution-class+ dup 0= stop? or UNTIL drop ; \ identify branch destinations. 04Jul86: thru.branchtable ( -- limit start ) #branches @ 0 ; : ?.then ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< IF I branch-type @ dup ['] else = swap ['] if = or IF -in ." THEN " ind-cr LEAVE THEN THEN THEN LOOP ; : ?.begin ( ip -- ) thru.branchtable ?DO I branch-to @ over = IF I branch-from @ over u< not IF I branch-type @ dup ['] repeat = swap ['] until = or IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN LOOP ; ( put "BEGIN" and "THEN" where used.) \ decompile each type of word 01Jul86 : .word ( ip -- ip' ) dup @ >name .name 2+ ; : .(word ( ip -- ip' ) dup @ >name ?dup 0= IF ." ??? " ELSE count $1f and swap 1+ swap 1- type space THEN 2+ ; : .inline ( val16b -- ) dup >name ?dup IF ." ['] " .name drop exit THEN . ; : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; : .string ( ip -- ip' ) .(word count 2dup type Ascii " emit space + even ?.then ; : .unnest ( ip -- 0 ) ." ; " 0= ; \ decompile each type of word 01Jul86 : .default ( ip -- ip' ) dup @ >name ?dup IF c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; : .compile ( ip -- ip' ) .word .word ?.then ; \ decompiling conditionals 04Jul86 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; 5 Associative: branch-class ' if , ' while , ' else , ' repeat , ' until , Case: .branch-class .if .else .else .repeat .repeat ; : .branch ( ip -- ip' ) #branch @ branch-type @ 1 #branch +! dup >name swap branch-class .branch-class ; \ decompile Does> ;code 04Jul86 : .(;code ( IP - IP' f) 2+ dup does? IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; \ classify word's output 01Jul86 Case: .execution-class .clit .lit .branch .branch .do .string .string .(;code .string .do .loop .loop .unnest .['] .compile .default ; \ decompile colon-definitions 04Jul86 : pass2 ( cfa -- ) #branch off >body BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class dup 0= stop? or UNTIL drop ; : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; : .immediate ( cfa - ) >name c@ dup ?ind-cr 40 and IF ." IMMEDIATE " THEN ?ind-cr 80 and IF ." RESTRICT" THEN ; : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; \ display category of word 01Jul86external Defer (see internal : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; : .user-variable ( cfa - ) ." USER " dup >name dup .name 3 spaces swap execute @ u. .name ." ! " ; : .defer ( cfa - ) ." deferred " dup >name .name ." Is " >body @ (see ; : .other ( cfa - ) dup >name .name dup @ over >body = IF drop ." is Code " exit THEN dup @ does? IF .does> exit THEN drop ." is unknown " ; \ decompiling variables and constants 01Jul86 : .constant ( cfa - ) dup >body @ u. ." CONSTANT " >name .name ; : .variable ( cfa - ) ." VARIABLE " dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; \ classify a word UH 25Jan88 5 Associative: definition-class ' quit @ , ' 0 @ , ' scr @ , ' base @ , ' 'cold @ , Case: .definition-class .: .constant .variable .user-variable .defer .other ; \ Top level of Decompiler 04Jul86 external : ((see ( cfa -) #spaces off cr dup dup @ definition-class .definition-class .immediate ; ' ((see Is (see Forth definitions : see ' (see ; \ No newline at end of file diff --git a/disks/images/f/simpfile.fb b/disks/images/f/simpfile.fb new file mode 100644 index 0000000..1fd4b38 --- /dev/null +++ b/disks/images/f/simpfile.fb @@ -0,0 +1 @@ +\\ Simple Files 11Nov86 Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es trotzdem wuenschenswert eine Art File-Struktur zu besitzen. Dieses File enthaelt eine einfache Implementation eines Filesystems. Der/die Programmierer/in muss selbst die Direktory auf dem laufenden halten: in ihr sind die Start-Bloecke des entsprechenden Diskettenteils gespeichert. Sogar eine Hierarchie von Direktories laesst sich so relisieren. Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64). \ simple files 12feb86 \needs search .( search missing) \\ | Variable (dir : dir (dir @ ; : root 0 (dir ! ; root | : read" ( -- n) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in push >in ! bl dir block b/blk (word number drop ; : load" read" dir + load ; : dir" read" (dir +! ; : list" read" dir + list ; \ 1 +load \ Only if file" is needed \ simple files 01feb86 | : snap ( n0 -- n1) $20 / 3 max $20 * ; : file" ( n --) Ascii " word count 2dup dir block b/blk search IF + nip ELSE drop dir block b/blk -trailing nip snap $20 + dup b/blk 1- > abort" directory full" 2dup + >r dir block + swap cmove r> THEN snap $18 + >r dir - extend under dabs <# # # # # base @ $0A = IF Ascii & ELSE Ascii $ THEN hold rot 0< IF Ascii - ELSE bl THEN hold #> r> dir block + swap cmove update ; \ dir load" 11feb86 \needs search .( search missing) \\ 0 Constant dir : load" ( -- ) Ascii " word count dup >r dir block b/blk search 0= abort" not found" r> + >in @ blk @ rot >in ! dir blk ! bl word number drop -rot blk ! >in ! load ; \ No newline at end of file diff --git a/disks/images/f/source.fb b/disks/images/f/source.fb new file mode 100644 index 0000000..296d46d --- /dev/null +++ b/disks/images/f/source.fb @@ -0,0 +1 @@ +\\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87 Entwicklung des volksFORTH-83 von K. Schleisiek, B. Pennemann, G. Rehfeld, D. Weineck, U. Hoffmann Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann Dieses File enthaelt den kompletten Sourcetext des Kern-Systems fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+.Mit Hilfe eines Target-Compilers wird daraus das volksFORTH- System erzeugt, daher finden sich an einigen Stellen Anweisungenan den Target-Compiler, die fuer das Verstaendnis des Systems nicht wichtig sind. Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- besondere die Bdos-Schnittstelle fuer Disk-IO im Kern. \ CP/M 2.2 volksForth Load Screen 27Nov87 Onlyforth $9000 displace ! Target definitions $100 here! 1 $74 +thru \ Standard 8080-System cr .( unresolved: ) .unresolved ( ' .blk is .status ) save-target KERNEL.COM \ FORTH Preamble and ID uho 19May2005 Assembler nop 0 jmp here 2- >label >boot nop 0 jmp here 2- >label >cold nop 0 jmp here 2- >label >restart here dup origin! \ Hier beginnen die Kaltstartwerte der Benutzervariablen 6 rst 0 jmp end-code \ for multitasker $100 allot | Create logo ," volksFORTH-83 rev. 3.80a" \ Assembler Labels Next Forth-Register 29Jun86 Label dpush D push Label hpush H push Label >next IP ldax IP inx A L mov IP ldax IP inx A H mov Label >next1 M E mov H inx M D mov xchg pchl end-code Variable RP Variable UP \ IP in BC \ W in DE \ SP in SP Variable IPsave \ Assembler Macros 20Oct86Compiler Assembler also definitions Forth : Next T >next jmp [ Forth ] ; T hpush Forth Constant hpush T dpush Forth Constant dpush T >next Forth Constant >next : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) H dcx 1+ M mov ( low ) RP shld [ Forth ] ; : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx M swap mov ( high ) H inx RP shld [ Forth ] ; \ rpush und rpop gehen nicht mit HL : mvx ( src dest -- ) 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ; Target \ recover ;c: noop 20Oct86 Create recover Assembler W pop IP rpush W IP mvx Next end-code Compiler Assembler also definitions Forth : ;c: 0 T recover call end-code ] [ Forth ] ; Target | Code di di Next end-code | Code ei ei Next end-code Code noop >next here 2- ! end-code \ User variables 04Oct87 Constant origin 8 uallot drop \ Multitasker \ Felder: entry link spare SPsave \ Laenge kompatibel zum 68000 und 6502 volksFORTH User s0 User r0 User dp User offset 0 offset ! User base $0A base ! User output User input User errorhandler \ pointer for Abort" -code User voc-link User udp \ points to next free addr in User \ manipulate system pointers 11Jun86 Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code Code sp! ( addr --) H pop sphl Next end-code Code up@ ( -- addr) UP lhld hpush jmp end-code Code up! ( addr --) H pop UP shld Next end-code \ manipulate returnstack 11Jun86 Code rp@ ( -- addr ) RP lhld hpush jmp end-code Code rp! ( addr -- ) H pop RP shld Next end-code Code >r ( 16b -- ) D pop D rpush Next end-code restrict Code r> ( -- 16b ) D rpop D push Next end-code restrict \ r@ rdrop exit unnest ?exit 07Oct87Code r@ ( -- 16b ) RP lhld M E mov H inx M D mov D push Next end-code Code rdrop RP lhld H inx H inx RP shld Next end-code restrict Code exit Label >exit IP rpop Next end-code Code unnest >exit here 2- ! Code ?exit ( flag -- ) H pop H A mov L ora >exit jnz Next end-code Code 0=exit ( flag -- ) H pop H A mov L ora >exit jz Next end-code \ : ?exit ( flag -- ) IF rdrop THEN ; \ execute perform 11Jun86 18Nov87 Code execute ( cfa -- ) H pop >Next1 jmp end-code Code perform ( 'cfa -- ) H pop M A mov H inx M H mov A L mov >Next1 jmp end-code \\ : perform ( addr -- ) @ execute ; \ c@ c! ctoggle 07Oct87 Code c@ ( addr -- 8b ) H pop M L mov 0 H mvi hpush jmp end-code Code c! ( 16b addr -- ) H pop D pop E M mov Next end-code Code flip ( 16b1 -- 16b2 ) H pop H A mov L H mov A L mov Hpush jmp end-code Code ctoggle ( 8b addr -- ) H pop D pop M A mov E xra A M mov Next end-code \\ : ctoggle ( 8b addr --) under c@ xor swap c! ; \ @ ! 2@ 2! 11Jun86 18Nov87 Code @ ( addr -- 16b ) H pop Label fetch M E mov H inx M D mov D push Next end-code Code ! ( 16b addr -- ) H pop D pop E M mov H inx D M mov Next end-code Code 2@ ( addr -- 32b ) H pop H push H inx H inx M E mov H inx M D mov H pop D push M E mov H inx M D mov D push Next end-code Code 2! ( 32b addr -- ) H pop D pop E M mov H inx D M mov H inx D pop E M mov H inx D M mov Next end-code \ +! drop swap 11Jun86 18Nov87 Code +! ( 16b addr -- ) H pop Label +store D pop M A mov E add A M mov H inx M A mov D adc A M mov Next end-code \ : +! ( n addr -- ) under @ + swap ! ; Code drop ( 16b -- ) H pop Next end-code Code swap ( 16b1 16b2 -- 16b2 16b1 ) H pop xthl hpush jmp end-code \ dup ?dup 16May86 Code dup ( 16b -- 16b 16b ) H pop H push hpush jmp end-code Code ?dup ( 16b -- 16b 16b / false) H pop H A mov L ora 0<> ?[ H push ]? hpush jmp end-code \\ : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; : dup ( 16b -- 16b 16b ) sp@ @ ; \ over rot nip under 11Jun86 Code over ( 16b1 16b2 - 16b1 16b2 16b1 ) D pop H pop H push dpush jmp end-code Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) D pop H pop xthl dpush jmp end-code Code nip ( 16b1 16b2 -- 16b2) H pop D pop hpush jmp end-code Code under ( 16b1 16b2 -- 16b2 16b1 16b2) H pop D pop H push dpush jmp end-code \\ : over >r swap r> swap ; : rot >r dup r> swap ; : nip swap drop ; : under swap over ; \ -rot pick roll -roll 11Jun86Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) H pop D pop xthl H push D push Next end-code Code pick ( n -- 16b.n ) H pop H dad SP dad M E mov H inx M D mov D push Next end-code : roll ( n -- ) dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; : -roll ( n -- ) >r dup sp@ dup 2+ dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; \\ : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; \ double word stack manipulation 09May86Code 2swap ( 32b1 32b2 -- 32b2 32b1) H pop D pop xthl H push 5 H lxi SP dad M A mov D M mov A D mov H dcx M A mov E M mov A E mov H pop dpush jmp end-code Code 2drop ( 32b -- ) H pop H pop Next end-code Code 2dup ( 32b -- 32b 32b) H pop D pop D push H push dpush jmp end-code \\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; : 2drop ( 32b -- ) drop drop ; : 2dup ( 32b -- 32b 32b) over over ; \ + and or xor not 09May86Code + ( n1 n2 -- n3 ) H pop D pop D dad hpush jmp end-code Code or ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ora A H mov L A mov E ora A L mov hpush jmp end-code Code and ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D ana A H mov L A mov E ana A L mov hpush jmp end-code Code xor ( 16b1 16b2 -- 16b3 ) H pop D pop H A mov D xra A H mov L A mov E xra A L mov hpush jmp end-code Code not ( 16b1 -- 16b2 ) H pop Label >not H A mov cma A H mov L A mov cma A L mov hpush jmp end-code \ - negate 16May86 Code - ( n1 n2 -- n3 ) D pop H pop L A mov E sub A L mov H A mov D sbb A H mov hpush jmp end-code Code negate ( n1 -- n2 ) H pop H dcx >not jmp end-code \\ : - ( n1 n2 -- n3 ) negate + ; \ dnegate d+ 10Mar86 18Nov87 Code dnegate ( d1 -- -d1 ) H pop Label >dnegate D pop A sub E sub A E mov 0 A mvi D sbb A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb A H mov dpush jmp end-code Code d+ ( d1 d2 -- d3) 6 H lxi SP dad M E mov C M mov H inx M D mov B M mov B pop H pop D dad xchg H pop L A mov C adc A L mov H A mov B adc A H mov B pop dpush jmp end-code \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code Code 2+ ( n1 -- n2 ) H pop H inx H inx hpush jmp end-code Code 3+ ( n1 -- n2 ) H pop H inx H inx H inx hpush jmp end-code Code 4+ ( n1 -- n2 ) H pop 4 D lxi D dad hpush jmp end-code | Code 6+ ( n1 -- n2 ) H pop 6 D lxi D dad hpush jmp end-code Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code Code 2- ( n1 -- n2 ) H pop H dcx H dcx hpush jmp end-code Code 4- ( n1 -- n2 ) H pop -4 D lxi D dad hpush jmp end-code \ number Constants 07Oct87-1 Constant true 0 Constant false 0 ( -- 0 ) Constant 0 1 ( -- 1 ) Constant 1 2 ( -- 2 ) Constant 2 3 ( -- 3 ) Constant 3 4 ( -- 4 ) Constant 4 -1 ( -- -1 ) Constant -1 Code on ( addr -- ) H pop $FF A mvi Label set A M mov H inx A M mov Next Code off ( addr -- ) H pop A xra set jmp end-code \ : on ( addr -- ) true swap ! ; \ : off ( addr -- ) false swap ! ; \ words for number literals 16May86 Code lit ( -- 16b ) IP ldax A L mov IP inx IP ldax A H mov IP inx hpush jmp end-code Code clit ( -- 8b ) IP ldax A L mov 0 H mvi IP inx hpush jmp end-code : Literal ( 16b -- ) dup $FF00 and IF compile lit , exit THEN compile clit c, ; immediate restrict \ comparision words 18Nov87Label (u< ( HL,DE -> HL u< DE c,z ) H A mov D cmp rnz L A mov E cmp ret Label (< ( HL,DE -> HL < DE c,z ) H A mov D xra (u< jp D A mov H cmp ret Label yes true H lxi hpush jmp Code u< ( u1 u2 -- flag ) D pop H pop Label uless (u< call yes jc Label no false H lxi hpush jmp Code < ( n1 n2 -- flag ) D pop H pop Label less (< call yes jc no jmp end-code Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code \ comparision words 18Nov87Code 0< ( n1 n2 -- flag ) H pop Label negative H dad yes jc no jmp end-code Code 0> ( n -- flag ) H pop H A mov A ora no jm L ora yes jnz no jmp end-code Code 0= ( n -- flag ) H pop Label zero= H A mov L ora yes jz no jmp end-code Code 0<> ( n -- flag ) H pop H A mov L ora yes jnz no jmp end-code Code = ( n1 n2 -- flag ) H pop D pop L A mov E cmp no jnz H A mov D cmp no jnz yes jmp end-code \\ comparision words high level 18Nov87: 0< ( n1 -- flag ) 8000 and 0<> ; : > ( n1 n2 -- flag ) swap < ; : 0> ( n -- flag ) negate 0< ; : 0<> ( n -- flag ) 0= not ; : u> ( u1 u2 -- flag ) swap u< ; : = ( n1 n2 -- flag ) - 0= ; : uwithin ( u1 [low up[ -- flag ) over - -rot - u> ; | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; : min ( n1 n2 -- n3 ) 2dup > minimax ; : max ( n1 n2 -- n3 ) 2dup < minimax ; : umax ( u1 u2 -- u3 ) 2dup u< minimax ; : umin ( u1 u2 -- u3 ) 2dup u> minimax ; : extend ( n -- d ) dup 0< ; : dabs ( d -- ud ) extend IF dnegate THEN ; : abs ( n -- u) extend IF negate THEN ; \ uwthin double number comparison words 18Nov87 Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl (u< call cs ?[ H pop no jmp ]? D pop (u< call yes jc no jmp end-code Code d0= ( d -- flag ) H pop H A mov L ora H pop no jnz zero= jmp end-code : d= ( d1 d2 -- flag ) rot = -rot = and ; : d< ( d1 d2 -- flag ) rot 2dup = IF 2drop u< exit THEN > nip nip ; \\ : d0= ( d -- flag ) or 0= ; \ minimum maximum 18Nov87 Code umax ( u1 u2 -- u3 ) H pop D pop (u< call Label minimax cs ?[ xchg ]? hpush jmp end-code Code umin ( u1 u2 -- u3 ) H pop D pop (u< call cmc minimax jmp end-code Code max ( n1 n2 -- n3 ) H pop D pop (< call minimax jmp end-code Code min ( n1 n2 -- n3 ) H pop D pop (< call cmc minimax jmp end-code \ sign extension absolute values 18Nov87 Code extend ( n -- d ) H pop H push negative jmp end-code Code abs ( a -- u ) H pop H A mov A ora hpush jp H dcx >not jmp end-code Code dabs ( d -- ud ) H pop H A mov A ora hpush jp >dnegate jmp end-code \ branch ?branch 20Nov87 Code branch ( -- ) Label >branch IP H mvx M E mov H inx M D mov H dcx D dad H IP mvx Next end-code Code ?branch ( fl -- ) H pop H A mov L ora >branch jz IP inx IP inx Next end-code \\ : branch r> dup @ + >r ; \ loop primitives 11Jun86 20Nov87 Code bounds ( start count -- limit start ) H pop D pop D dad H push D push Next end-code Code endloop RP lhld 6 D lxi D dad RP shld next end-code restrict \\ dodo puts "index | limit | adr.of.DO" on return-stack : bounds ( start count -- limit start ) over + swap ; | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; : (do ( limit start -- ) over - dodo ; restrict : (?do ( limit start -- ) over - ?dup IF dodo THEN r> dup @ + >r drop ; restrict \ loop primitives 20Nov87 Code (do ( limit start -- ) H pop D pop Label >do L A mov E sub A L mov H A mov D sbb A H mov H push IP inx IP inx RP lhld H dcx IP M mov H dcx IP' M mov H dcx D M mov H dcx E M mov D pop H dcx D M mov H dcx E M mov RP shld Next end-code restrict Code (?do ( limit start -- ) H pop D pop H A mov D cmp >do jnz L A mov E cmp >do jnz >branch jmp end-code restrict \ (loop (+loop 14May86 20Nov87 Code (loop RP lhld M inr 0= ?[ H inx M inr >next jz ]? Label doloop RP lhld 4 D lxi D dad M IP' mov H inx M IP mov Next end-code restrict Code (+loop RP lhld D pop M A mov E add A M mov H inx M A mov D adc A M mov rar D xra doloop jp Next end-code restrict \ loop indices 06May86 20Nov87 Code I ( -- n ) RP lhld Label >I M E mov H inx M D mov D push H inx M E mov H inx M D mov H pop D dad hpush jmp end-code Code J ( -- n ) RP lhld 6 D lxi D dad >I jmp end-code \ interpretive conditionals UH 25Jan88 | Create: remove>> r> rp! ; | : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp! swap >r remove>> >r swap >r dup >r swap cmove r> ; | Variable saved-dp 0 saved-dp ! | Variable level 0 level ! | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit 1 level ! here saved-dp ! ] ; | : -level ( -- ) state @ 0= Abort" unstructured" level @ 0=exit -1 level +! level @ ?exit compile unnest [compile] [ saved-dp @ here over dp ! over - >>r >r ; \ resolve loops and branches UH 25Jan88 : >mark ( -- addr ) here 0 , ; : +>mark ( acf -- addr ) +level , >mark ; : >resolve ( addr -- ) here over - swap ! -level ; : mark 1 ; immediate : THEN abs 1 ?pairs >resolve ; immediate : ELSE 1 ?pairs ['] branch +>mark swap >resolve -1 ; immediate : BEGIN mark -2 2swap ; immediate | : (reptil resolve REPEAT ; : REPEAT 2 ?pairs compile branch (reptil ; immediate : UNTIL 2 ?pairs compile ?branch (reptil ; immediate \ Loops UH 25Jan88 : DO ['] (do +>mark 3 ; immediate : ?DO ['] (?do +>mark 3 ; immediate : LOOP 3 ?pairs compile (loop compile endloop >resolve ; immediate : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; immediate Code LEAVE RP lhld 4 D lxi D dad M E mov H inx M D mov H inx RP shld xchg H dcx M D mov H dcx M E mov D dad H IP mvx Next end-code restrict \\ Returnstack: calladr | index limit | adr of DO : LEAVE endloop r> 2- dup @ + >r ; restrict \ um* 16May86Label (um* 0 H lxi ( 0=Teil-Produkt ) 4 C mvi ( Schleifen-Zaehler ) [[ H dad ( Schiebe HL 24 bits nach links ) ral cs ?[ D dad 0 aci ]? H dad ral cs ?[ D dad 0 aci ]? C dcr 0= ?] ret Code um* ( u1 u2 -- ud ) D pop H pop B push H B mov L A mov (um* call H push A H mov B A mov H B mov (um* call D pop D C mov B dad 0 aci L D mov H L mov A H mov B pop dpush jmp end-code \ m* * 2* 2/ 16May86 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN swap dup 0< IF negate r> not >r THEN um* r> IF dnegate THEN ; : * ( n1 n2 - prod ) um* drop ; Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code Code 2/ ( n -- n/2 ) H pop H A mov rlc rrc rar A H mov L A mov rar A L mov hpush jmp end-code \\ : 2* ( n -- 2*n ) 2 * ; : 2/ ( n -- n/2 ) 2 / ; \ um/mod 14May86Label usl0 A E mov H A mov C sub A H mov E A mov B sbb cs ?[ H A mov C add A H mov E A mov D dcr rz Label usla H dad ral usl0 jnc A E mov H A mov C sub A H mov E A mov B sbb ]? L inr D dcr usla jnz ret Label usbad -1 H lxi B pop H push hpush jmp Code um/mod ( d1 n1 -- rem quot ) IP H mvx B pop D pop xthl xchg L A mov C sub H A mov B sbb usbad jnc H A mov L H mov D L mov 8 D mvi D push usla call D pop H push E L mov usla call A D mov H E mov B pop C H mov B pop D push hpush jmp end-code \ m/mod 16May86 : m/mod ( d n -- mod quot) dup >r abs over 0< IF under + swap THEN um/mod r@ 0< IF negate over IF swap r@ + swap 1- THEN THEN rdrop ; \ /mod / mod */mod */ u/mod ud/mod 16May86 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; : / ( n1 n2 -- quot ) /mod nip ; : mod ( n1 n2 -- rem ) /mod drop ; : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; : */ ( n1 n2 n3 -- quot ) */mod nip ; : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r um/mod r> ; \ cmove cmove> 16May86 18Nov87 Code cmove ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove [[ B A mov C ora 0= not ?[[ M A mov H INX D stax D inx B dcx ]]? IPsave lhld H IP mvx Next end-code Code cmove> ( from to count -- ) IP H mvx IPsave shld B pop D pop H pop Label (cmove> B dad H dcx xchg B dad H dcx xchg [[ B A mov C ora 0= not ?[[ M A mov H dcx D stax D dcx B dcx ]]? IPsave lhld H IP mvx Next end-code \ move place count 17Oct86 18Nov87 Code move ( from to quan -- ) IP H mvx Ipsave shld B pop D pop H pop Label domove (u< call (cmove jnc (cmove> jmp end-code | Code (place ( addr len to -- len to ) IP H mvx Ipsave shld D pop B pop H pop B push D push D inx domove jmp end-code : place ( addr len to -- ) (place c! ; Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi H inx H push D push Next end-code \ fill erase 18Nov87 Code fill ( addr quan 8b -- ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora 0<> ?[[ E M mov H inx B dcx ]]? IPsave lhld H IP mvx Next end-code : erase ( addr quan --) 0 fill ; \\ : fill ( addr quan 8b -- ) swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; : count ( adr -- adr+1 len ) dup 1+ swap c@ ; : move ( from to quan -- ) >r 2dup u< IF r> cmove> exit THEN r> cmove ; : place ( addr len to --) over >r rot over 1+ r> move c! ; \ here allot , c, pad compile 11Jun86 18Nov87 Code here ( -- addr ) user' dp D lxi UP lhld D dad fetch jmp end-code Code allot ( n -- ) user' dp D lxi UP lhld D dad +store jmp end-code : , ( 16b -- ) here ! 2 allot ; : c, ( 8b -- ) here c! 1 allot ; : pad ( -- addr ) here $42 + ; : compile r> dup 2+ >r @ , ; restrict \ : here ( -- addr ) dp @ ; \ : allot ( n -- ) dp +! ; \ input strings 11Jun86 Variable #tib 0 #tib ! Variable >tib here >tib ! $50 allot Variable >in 0 >in ! Variable blk 0 blk ! Variable span 0 span ! : tib ( -- addr ) >tib @ ; : query ( -- ) tib $50 expect span @ #tib ! >in off blk off ; \\ scan skip /string 16May86 18Nov87 : scan ( addr0 len0 char -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT rdrop ; : skip ( addr len del -- addr1 len1 ) >r BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT rdrop ; : /string ( addr0 len0 +n - addr1 len1 ) over umin rot over + -rot - ; \ skip scan 18Nov87Label done H push B push IPsave lhld H IP mvx Next Code skip ( addr len del -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jnz H inx B dcx ]] end-code Code scan ( addr len chr -- addr1 len1 ) IP H mvx IPsave shld D pop B pop H pop [[ B A mov C ora done jz M A mov E cmp done jz H inx B dcx ]] end-code Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl L A mov E sub A L mov H A mov D sbb A H mov Hpush jmp end-code \ capitalize ohne Umlaute !! 16May86UH 25Jan88Variable caps 0 caps ! Label ?capital caps lda A ana rz Label (capital ( e --> A,E ) E A mov Ascii a cpi rc Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret Code capital ( char -- char') D pop (capital call D push Next end-code Code upper ( addr len -- ) D pop E D mov H pop D inr [[ D dcr >next jz M E mov (capital call E M mov H inx ]] end-code \\ : capital ( char -- char') dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit [ Ascii a Ascii A - ] Literal - ; : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; \ (word 16May86 Code (word ( char adr0 len0 -- addr ) IP H mvx IPsave shld B pop B dcx D pop >in lhld D dad xchg xthl xchg H push >in lhld C A mov L sub A L mov B A mov H sbb A H mov cs ?[ B inx C A mov >in sta B A mov >in 1+ sta D pop H pop D push ][ H inx H B mvx H pop [[ B A mov C ora 0<> ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]? H push [[ B A mov C ora 0<> ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]? xchg H pop xthl E A mov L sub A L mov D A mov H sbb A H mov \ (word Part2 16May86 B A mov C ora 0<> ?[ H inx ]? >in shld ]? H pop E A mov L sub A C mov D A mov H sbb A B mov H push user' dp D lxi UP lhld D dad M A mov H inx M H mov A L mov D pop H push C M mov H inx [[ B A mov C ora 0<> ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi IPsave lhld H IP mvx Next end-code \\ : (word ( char adr0 len0 -- addr ) rot >r over swap >in @ /string r@ skip over swap r> scan >r rot over swap - r> 0<> - >in ! over - here dup >r place bl r@ count + c! r> ; \ source word parse name 20Oct86UH 25Jan88 Variable loadfile : source ( -- addr len ) blk @ ?dup IF loadfile @ (block b/blk exit THEN tib #tib @ ; : word ( char -- addr ) source (word ; : parse ( char -- addr len ) >r source >in @ /string over swap r> scan >r over - dup r> 0<> - >in +! ; : name ( -- addr ) bl word dup count upper exit ; \ state Ascii ," "lit (" " 18Nov87 Variable state 0 state ! : Ascii ( char -- n ) bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate Code "lit RP lhld M E mov H inx M D mov H dcx D push D ldax D inx E add A M mov H inx D A mov 0 aci A M mov Next end-code : ," Ascii " parse here over 1+ allot place ; : (" "lit ; restrict : " compile (" ," align ; immediate restrict \ : "lit r> r> under count + even >r >r ; restrict \ ." ( .( \ \\ hex decimal 07Oct87 : (." "lit count type ; restrict : ." compile (." ," align ; immediate restrict : ( ascii ) parse 2drop ; immediate : .( ascii ) parse type ; immediate : \ >in @ negate c/l mod >in +! ; immediate : \\ b/blk >in ! ; immediate : \needs name find nip 0=exit [compile] \ ; : hex $10 base ! ; : decimal $0A base ! ; \ number conversion: digit? 16May86 18Nov87 Code digit? ( char -- n true : false ) user' base D lxi UP lhld D dad D pop E A mov Ascii 0 sui no jc $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc Ascii A Ascii 9 - 1- sui ]? M cmp no jnc 0 H mvi A L mov H push yes jmp end-code \\ : digit? ( char -- digit true/ false ) dup Ascii 9 > IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN Ascii 0 - dup base @ u< dup ?exit nip ; \ number conversion: accumulate convert 11Jun86 | : end? ( -- flag ) >in @ 0= ; | : char ( addr0 -- addr1 char ) count -1 >in +! ; | : previous ( addr0 -- addr0 char ) 1- count ; : accumulate ( +d0 adr digit - +d1 adr ) swap >r swap base @ um* drop rot base @ um* d+ r> ; : convert ( +d1 addr0 -- +d2 addr2 ) 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; \ number conversion: ?nonum punctuation? 07Oct87 | : ?nonum ( flag -- exit if true ) 0=exit rdrop 2drop drop rdrop false ; | : punctuation? ( char -- flag ) Ascii , over = swap Ascii . = or ; \ number conversion: fixbase? 07Oct87 | : fixbase? ( char - char false / newbase true ) capital Ascii & case? IF $0A true exit THEN Ascii $ case? IF $10 true exit THEN Ascii H case? IF $10 true exit THEN Ascii % case? IF 2 true exit THEN false ; \ number conversion: ?num ?dpl 07Oct87 Variable dpl -1 dpl ! | : ?num ( flag -- exit if true ) 0=exit rdrop drop r> IF dnegate THEN rot drop dpl @ 1+ ?dup ?exit drop true ; | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; \ number conversion: number? number 11Jun86 : number? ( string - string false / n 0< / d 0> ) base push >in push dup count >in ! dpl on 0 >r ( +sign) 0.0 rot end? ?nonum char Ascii - case? IF rdrop true >r end? ?nonum char THEN fixbase? IF base ! end? ?nonum char THEN BEGIN digit? 0= ?nonum BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL previous punctuation? 0= ?nonum dpl off end? ?num char REPEAT ; : number ( string -- d ) number? ?dup 0= Abort" ?" 0< IF extend THEN ; \ hide reveal immediate restrict 11Jun86 Variable last 0 last ! | : last? ( -- false / acf true) last @ ?dup ; : hide last? IF 2- @ current @ ! THEN ; : reveal last? IF 2- current @ ! THEN ; : Recursive reveal ; immediate restrict | : flag! ( 8b --) last? IF under c@ or over c! THEN drop ; : immediate $40 flag! ; : restrict $80 flag! ; \ clearstack hallot heap heap? 04Sep86 Code clearstack user' s0 D lxi UP lhld D dad M E mov H inx M D mov xchg sphl Next end-code : hallot ( quan -- ) s0 @ over - swap sp@ 2+ dup rot - dup s0 ! 2 pick over - di move clearstack ei s0 ! ; : heap ( -- addr ) s0 @ 6 + ; : heap? ( addr -- flag ) heap up@ uwithin ; | : heapmove ( from -- from ) dup here over - dup hallot heap swap cmove heap over - last +! reveal ; \ Does> ; 11Jun86 20Nov87 Label (dodoes> IP rpush IP pop W inx W push Next end-code : (;code r> last @ name> ! ; : Does> compile (;code $CD ( 8080-Call ) c, compile (dodoes> ; immediate restrict \ ?head | alignments 20Oct86 18Nov87 Variable ?head 0 ?head ! : | ?head @ ?exit -1 ?head ! ; \ machen nichts beim 8080: : even ( addr -- addr1 ) ; immediate : align ( -- ) ; immediate : halign ( -- ) ; immediate Variable warning 0 warning ! | : exists? warning @ ?exit last @ current @ (find nip 0=exit space last @ .name ." exists " ?cr ; \ warning Create 20Oct86 18Nov87 Defer makeview ' 0 Is makeview : (create ( string -- ) align here swap count $1F and here 4+ place makeview , current @ @ , here last ! here c@ 1+ allot align exists? ?head @ IF 1 ?head +! dup , \ Pointer to Code halign heapmove $20 flag! dup dp ! THEN drop reveal 0 , ;Code W inx W push Next end-code : Create name count 1 $20 uwithin not Abort" invalid name" 1- (create ; \ nfa? 30Jun86 Code nfa? ( thread cfa -- nfa / false ) D pop H pop [[ M A mov H inx M H mov A L mov H ora Hpush jz H push H inx H inx H push D push M A mov H inx $1F ani A E mov 0 D mvi D dad D pop xthl M A mov H pop $20 ani 0<> ?[ M A mov H inx M H mov A L mov ]? H A mov D cmp 0= ?[ L A mov E cmp ]? H pop 0= ?] H inx H inx Hpush jmp end-code \\ : nfa? ( thread cfa -- nfa / false) >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ = UNTIL 2+ rdrop ; \ >name name> >body .name 30Jun86 07Oct87 : >name ( cfa -- nfa / false ) voc-link BEGIN @ dup WHILE 2dup 4 - swap nfa? ?dup IF -rot 2drop exit THEN REPEAT nip ; Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani A E mov 0 D mvi D dad hpush jmp end-code \ : (name> ( nfa -- cfa ) count $1F and + ; : name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ; : >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ; : .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN count $1F and type ELSE ." ???" THEN space ; \ : ; Constant Variable 07Nov87 : Create: Create hide current @ context ! 0 ] ; : : Create: ;Code IP rpush W inx W IP mvx Next end-code : ; 0 ?pairs compile unnest [compile] [ reveal ; immediate restrict : Constant ( n -- ) Create , ;Code W inx xchg M E mov H inx M D mov D push Next end-code : Variable Create 0 , ; \ uallot User Alias Defer 11Jun86 18Nov87: uallot ( quan -- offset ) even dup udp @ + $FF u> Abort" Userarea full" udp @ swap udp +! ; : User Create 2 uallot c, ;Code W inx W ldax A E mov 0 D mvi UP lhld D dad hpush jmp end-code : Alias ( cfa -- ) Create last @ dup c@ $20 and IF -2 allot ELSE $20 flag! THEN (name> ! ; | : crash true Abort" crash" ; : Defer Create ['] crash , ;Code W inx xchg M E mov H inx M D mov xchg >next1 jmp end-code \ vp current context also toss 11Jun86 Create vp $10 allot Variable current : context ( -- adr ) vp dup @ + 2+ ; | : thru.vocstack ( -- from to ) vp 2+ context ; \ "Only Forth also Assembler" gives \ vp: countword = 6 | Only | Forth | Assembler | : also vp @ $0A > Error" Vocabulary stack full" context @ 2 vp +! context ! ; : toss vp @ IF -2 vp +! THEN ; \ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87 : Vocabulary Create 0 , 0 , here voc-link @ , voc-link ! Does> context ! ; \ | Name | Code | Thread | Coldthread | Voc-link | Vocabulary Forth Vocabulary Root : Only vp off Root also ; : Onlyforth Only Forth also definitions ; \ definitions order words 10Oct87 20Nov87 | : init-vocabularys voc-link @ BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; : definitions context @ current ! ; | : .voc ( adr -- ) @ 2- >name .name ; : order vp 4+ context DO I .voc -2 +LOOP 2 spaces current .voc ; : words context @ BEGIN @ dup stop? 0= and WHILE ?cr dup 2+ .name space REPEAT drop ; \ found -text 11Jun86| : found ( nfa -- cfa n ) dup c@ >r (name> r@ $20 and IF @ THEN -1 r@ $80 and IF 1- THEN r> $40 and IF negate THEN ; \\ : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1r count $1F and strlen ! string ! BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ = IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN THEN drop REPEAT string @ 1- false ; \ (find 11Jun86 Code (find ( str thr - str false/ NFA true ) H pop D pop IP push D ldax $1F ani A C mov D inx Label findloop M A mov H inx M H mov A L mov H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]? H push H inx H inx M A mov $1F ani C cmp 0<> ?[ H pop findloop jmp ]? D push H inx C B mov B inr [[ B dcr 0<> ?[[ D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]? H inx D inx ]]? D pop H pop H inx H inx IP pop H push yes jmp end-code \\ HL: thread, nfa DE: string C: strlen B: counter \ find ' [compile] ['] nullstring? 18Nov87 : find ( string -- cfa n / string false ) context dup @ over 2- @ = IF 2- THEN BEGIN under @ (find IF nip found exit THEN over vp 2+ u> WHILE swap 2- REPEAT nip false ; : ' ( -- cfa ) name find ?exit Error" ?" ; : [compile] ' , ; immediate restrict : ['] ' [compile] Literal ; immediate restrict : nullstring? ( string -- string false / true ) dup c@ 0= dup 0=exit nip ; \ notfound 17Oct86UH 25Jan88 : no.extensions ( string -- ) state @ IF Abort" ?" THEN Error" ?" ; Defer notfound ' no.extensions Is notfound \ interpret interpreter compiler parser UH 25Jan88Defer parser : interpret ( -- ) BEGIN ?stack name nullstring? ?exit parser REPEAT ; | : interpreter ( str -- ) find ?dup IF 1 and IF execute exit THEN Error" compile only" THEN number? ?exit notfound ; ' interpreter Is parser | : compiler ( str -- ) find ?dup IF 0> IF execute exit THEN , exit THEN number? ?dup IF 0> IF swap [compile] Literal THEN [compile] Literal exit THEN notfound ; \ [ ] UH 25Jan88 : [ ['] interpreter Is Parser state off ; immediate : ] ['] compiler Is Parser state on ; \ Is 09May86UH 25Jan88 : (is r> dup 2+ >r @ ! ; | : def? ( cfa -- ) @ [ ' notfound @ ] Literal - Abort" not deferred" ; : Is ( adr -- ) ' dup def? >body state @ IF compile (is , exit THEN ! ; immediate \ ?stack 30Jun86| : stackfull ( -- ) depth $20 > Abort" tight stack" reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN true Abort" Dictionary full" ; Code ?stack UP lhld user' dp D lxi D dad M E mov H inx M D mov 0 H lxi SP dad L A mov E sub H A mov D sbb 0= ?[ ;c: stackfull ; Assembler ]? H push UP lhld user' s0 D lxi D dad M E mov H inx M D mov H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]? >next jnc ;c: true abort" Stack empty" ; \\ : ?stack sp@ here - 100 u< IF stackfull THEN sp@ s0 @ u> Abort" Stack empty" ; \ .status push load 20Oct86 Defer .status ' noop Is .status | Create: pull r> r> ! ; : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; restrict : (load ( blk offset -- ) isfile push loadfile push fromfile push blk push >in push >in ! blk ! isfile@ loadfile ! .status interpret ; : load ( blk --) ?dup 0=exit 0 (load ; \ +load thru +thru --> rdepth depth 20Oct86 : +load ( offset --) blk @ + load ; : thru ( from to --) 1+ swap DO I load LOOP ; : +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; : --> 1 blk +! >in off .status ; immediate : rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; : depth ( -- +n) sp@ s0 @ swap - 2/ ; \ quit (quit abort UH 25Jan88 : (prompt ( -- ) state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; Defer prompt ' (prompt Is prompt : (quit BEGIN prompt query interpret REPEAT ; Defer 'quit ' (quit Is 'quit : quit r0 @ rp! level off [compile] [ 'quit ; : standardi/o [ output ] Literal output 4 cmove ; Defer 'abort ' noop Is 'abort : abort end-trace clearstack 'abort standardi/o quit ; \ (error Abort" Error" 20Oct86 18Nov87 Variable scr 1 scr ! Variable r# 0 r# ! : (error ( string -- ) standardi/o space here .name count type space ?cr blk @ ?dup IF scr ! >in @ r# ! THEN quit ; ' (error errorhandler ! : (abort" "lit swap IF >r clearstack r> errorhandler perform exit THEN drop ; restrict | : (err" "lit swap IF errorhandler perform exit THEN drop ; restrict : Abort" compile (abort" ," align ; immediate restrict : Error" compile (err" ," align ; immediate restrict \ -trailing 30Jun86 18Nov87 Code -trailing ( addr n1 -- addr n2 ) D pop H pop H push D dad xchg D dcx Label -trail H A mov L ora hpush jz D ldax BL cpi hpush jnz H dcx D dcx -trail jmp end-code \\ : -trailing ( addr n1 -- addr n2) 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; \ space spaces 30Jun86 $20 Constant bl : space bl emit ; : spaces ( u --) 0 ?DO space LOOP ; \ hold <# #> sign # #s 17Oct86 | : hld ( -- addr) pad 2- ; : hold ( char -- ) -1 hld +! hld @ c! ; : <# hld hld ! ; : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; : sign ( n -- ) 0< IF Ascii - hold THEN ; : # ( +d1 -- +d2) base @ ud/mod rot 9 over < IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; \ print numbers 24Dec83 : d.r -rot under dabs <# #s rot sign #> rot over max over - spaces type ; : .r swap extend rot d.r ; : u.r 0 swap d.r ; : d. 0 d.r space ; : . extend d. ; : u. 0 d. ; \ .s list c/l l/s 05Oct87 : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; $40 Constant c/l \ Screen line length $10 Constant l/s \ lines per screen : list ( blk -- ) scr ! ." Scr " scr @ u. l/s 0 DO cr I 2 .r space scr @ block I c/l * + c/l -trailing type LOOP cr ; \ multitasker primitives 20Nov87 Code end-trace \ patch Next to its original state $0A A mvi ( IP ldax ) >next sta $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code Code pause >next here 2- ! end-code : lock ( addr -- ) dup @ up@ = IF drop exit THEN BEGIN dup @ WHILE pause REPEAT up@ swap ! ; : unlock ( addr -- ) dup lock off ; Label wake H pop H dcx UP shld 6 D lxi D dad M A mov H inx M H mov A L mov sphl H pop RP shld IP pop Next end-code \ buffer mechanism 20Oct86 07Oct87 User isfile 0 isfile ! \ addr of file control block Variable fromfile 0 fromfile ! Variable prev 0 prev ! \ Listhead | Variable buffers 0 buffers ! \ Semaphor $408 Constant b/buf \ physikalische Groesse $400 Constant b/blk \\ Struktur eines Buffers: 0 : link 2 : file 4 : blocknummer 6 : statusflags 8 : Data ... 1 Kb ... Statusflag bits : 15 1 -> updated file : -1 -> empty buffer, 0 -> no fcb, direct access else addr of fcb ( system dependent ) \ search for blocks in memory 30Jun86| Variable pred \ DE:blk BC:file HL:bufadr Label thisbuffer? ( Zero = this buffer ) H push H inx H inx M A mov C cmp 0= ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret Code (core? ( blk file -- adr\blk file ) IP H mvx Ipsave shld user' offset D lxi UP lhld D dad M E mov H inx M D mov B pop H pop H push B push D dad xchg prev lhld thisbuffer? call 0= ?[ \ search for blocks in memory 30Jun86 Label blockfound D pop D pop 8 D lxi D dad H push ' exit @ jmp ]? [[ pred shld M A mov H inx M H mov A L mov H ora 0= ?[ IPsave lhld H IP mvx Next ]? thisbuffer? call 0= ?] xchg pred lhld D ldax A M mov H inx D inx D ldax A M mov D dcx prev lhld xchg E M mov H inx D M mov H dcx prev shld blockfound jmp end-code \ (core? 29Jun86\\ | : this? ( blk file bufadr -- flag ) dup 4+ @ swap 2+ @ d= ; | : (core? ( blk file -- dataaddr / blk file ) BEGIN over offset @ + over prev @ this? IF rdrop 2drop prev @ 8 + exit THEN 2dup >r offset @ + >r prev @ BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN dup r> r> 2dup >r >r rot this? 0= WHILE nip REPEAT dup @ rot ! prev @ over ! prev ! rdrop rdrop REPEAT ; \ (diskerr 29Jul86 07Oct87 : (diskerr ." error! r to retry " key $FF and capital Ascii R = not Abort" aborted" ; Defer diskerr ' (diskerr Is diskerr Defer r/w \ backup emptybuf readblk 20Oct86 | : backup ( bufaddr -- ) dup 6+ @ 0< IF 2+ dup @ 1+ \ buffer empty if file = -1 IF input push output push standardi/o BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w WHILE ." write " diskerr REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ; : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; | : readblk ( blk file addr -- blk file addr ) dup emptybuf input push output push standardi/o >r BEGIN over offset @ + over r@ 8 + -rot 1 r/w WHILE ." read " diskerr REPEAT r> ; \ take mark updates? core? 10Mar86 19Nov87 | : take ( -- bufaddr) prev BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL buffers lock dup backup ; | : mark ( blk file bufaddr -- blk file ) 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off buffers unlock ; | : updates? ( -- bufaddr / flag) prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; : core? ( blk file -- addr /false ) (core? 2drop false ; \ block & buffer manipulation 20Oct86 18Nov87 : (buffer ( blk file -- addr ) BEGIN (core? take mark REPEAT ; : (block ( blk file -- addr ) BEGIN (core? take readblk mark REPEAT ; Code isfile@ ( -- addr ) user' isfile D lxi UP lhld D dad fetch jmp end-code : buffer ( blk -- addr ) isfile@ (buffer ; : block ( blk -- addr ) isfile@ (block ; \ : isfile@ ( -- addr ) isfile @ ; \ block & buffer manipulation 05Oct87 : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; Defer save-dos-buffers : save-buffers ( -- ) buffers lock BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers buffers unlock ; : empty-buffers ( -- ) buffers lock prev BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; : flush save-buffers empty-buffers ; \ Allocating buffers 10Oct87$10000 Constant limit Variable first : allotbuffer ( -- ) first @ r0 @ - b/buf 2+ u< ?exit b/buf negate first +! first @ dup emptybuf prev @ over ! prev ! ; : freebuffer ( -- ) first @ limit b/buf - u< IF first @ backup prev BEGIN dup @ first @ - WHILE @ REPEAT first @ @ swap ! b/buf first +! THEN ; : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; | : init-buffers prev off limit first ! all-buffers ; \ endpoints of forget 01Jul86 | : |? ( nfa -- flag ) c@ $20 and ; | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? name> under 1+ u< swap heap? or ; | : endpoints ( addr -- addr symb ) heap voc-link @ >r BEGIN r> @ ?dup \ through all Vocabs WHILE dup >r 4- >r \ link on returnstack BEGIN r> @ >r over 1- dup r@ u< \ until link or swap r@ 2+ name> u< and \ code under adr WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap r@ 2+ |? IF over r@ 2+ forget? IF r@ 2+ (name> 2+ umax THEN \ then update symb THEN REPEAT rdrop REPEAT ; \ remove, -words, -tasks 20Oct86 : remove ( dic sym thread - dic sym ) BEGIN dup @ ?dup \ unlink forg. words WHILE dup heap? IF 2 pick over u> ELSE 3 pick over 1+ u< THEN IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; | : remove-words ( dic sym -- dic sym ) voc-link BEGIN @ ?dup WHILE dup >r 4- remove r> REPEAT ; | : remove-tasks ( dic -- ) up@ BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin IF dup @ 2+ @ over ! 2- ELSE @ THEN REPEAT 2drop ; \ remove-vocs trim 20Oct86 07Oct87 | : remove-vocs ( dic symb -- dic symb ) voc-link remove thru.vocstack DO 2dup I @ -rot uwithin IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP 2dup current @ -rot uwithin IF [ ' Forth 2+ ] Literal current ! THEN ; Defer custom-remove ' noop Is custom-remove | : trim ( dic symb -- ) over remove-tasks remove-vocs remove-words custom-remove heap swap - hallot dp ! 0 last ! ; \ deleting words from dict. 01Jul86 18Nov87 : clear here dup up@ trim dp ! ; : (forget ( adr --) dup heap? Abort" is symbol" endpoints trim ; : forget ' dup [ dp ] Literal @ u< Abort" protected" >name dup heap? IF name> ELSE 4- THEN (forget ; : empty [ dp ] Literal @ up@ trim [ udp ] Literal @ udp ! ; \ save bye stop? ?cr 18Nov87 : save here up@ trim voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL up@ origin $100 cmove ; : bye flush empty (bye ; | : end? key #cr = IF true rdrop THEN ; : stop? ( -- flag ) key? IF end? end? THEN false ; : ?cr col c/l u> 0=exit cr ; \ in/output structure 07Jun86 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; : Output: Create: Does> output ! ; 0 Out: emit Out: cr Out: type Out: del Out: page Out: at Out: at? drop : row ( -- row) at? drop ; : col ( -- col) at? nip ; | : In: Create dup c, 2+ Does> c@ input @ + perform ; : Input: Create: Does> input ! ; 0 In: key In: key? In: decode In: expect drop \ Alias only definitionen 18Nov87 Root definitions Forth : seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab. ' Only Alias Only ' Forth Alias Forth ' words Alias words ' also Alias also ' definitions Alias definitions Host Target \ 'restart 'cold 22Oct86 10Oct87 Defer 'restart ' noop Is 'restart | : (restart ['] (quit Is 'quit drvinit 'restart [ errorhandler ] Literal @ errorhandler ! ['] noop Is 'abort clearstack standardi/o interpret quit ; Defer 'cold ' noop Is 'cold | : (cold origin up@ $100 cmove $80 count $50 umin >r tib r@ move r> #tib ! >in off blk off init-vocabularys init-buffers flush 'cold Onlyforth page &24 spaces logo count type cr (restart ; \ cold bootsystem 20Oct86 Code cold here >cold ! s0 lhld 6 D lxi D dad origin D lxi $3F C mvi [[ D ldax A M mov H inx D inx C dcr 0= ?] ' (cold >body IP lxi Label bootsystem s0 lhld 6 D lxi D dad UP shld user' s0 D lxi D dad M E mov H inx M D mov xchg sphl user' r0 D lxi UP lhld D dad M E mov H inx M D mov xchg RP shld $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker ) Next end-code \ restart boot 20Oct86 Code restart here >restart ! ' (restart >body IP lxi bootsystem jmp end-code Label boot here >boot ! \ find link to Main: s0 lhld 6 D lxi D dad H B mvx origin D lxi [[ [[ xchg H inx H inx M E mov H inx M D mov D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx 6 lhld 0 L mvi ' limit >body shld -$1100 D lxi D dad r0 shld \ set initial RP -$400 D lxi D dad s0 shld \ set initial SP 6 D lxi D dad xchg B H mvx D M mov H dcx E M mov \ set link to Maintask >cold 2- jmp end-code \ "search 05Mar88 Label notfound H pop H pop IPsave lhld H IP mvx False H lxi hpush jmp Code "search ( text tlen buf blen -- addr tf / ff ) IP H mvx IPsave shld D pop H pop xthl H A mov L ora notfound jz E A mov L sub A C mov D A mov H sbb A B mov notfound jc B inx D pop xthl M A mov xthl H push xchg Label scanfirst A E mov ?capital call E D mov [[ M E mov H inx B A mov C ora notfound jz B dcx ?capital call E A mov D cmp 0= ?] B D mvx B pop xchg xthl xchg H push B push D push \ "search part 2 27Nov87 Label match B dcx B A mov C ora 0<> ?[ D inx D ldax D push A E mov ?capital call E D mov M E mov H inx ?capital call E A mov D cmp D pop match jz H pop B pop D pop M A mov xthl B push H B mvx xchg scanfirst jmp ]? D pop D pop H pop D pop H dcx H push IPsave lhld H IP mvx True H lxi hpush jmp end-code \ Rest of Standard-System 04Oct87 07Oct87 2 +load \ Operating System Host ' Transient 8 + @ Transient Forth Context @ 6 + ! Target Forth also definitions Vocabulary Assembler Assembler definitions Transient Assembler >Next Constant >Next hpush Constant hpush dpush Constant dpush Target Forth also definitions : forth-83 ; \ last word in Dictionary \ System patchup 04Oct87 $EF00 r0 ! $EB00 s0 ! s0 @ 6 + origin 2+ ! \ link Maintask to itself \ s0 und r0 werden beim Booten neu an die Speichergroesse \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask here dp ! Host Tudp @ Target udp ! Host Tvoc-link @ Target voc-link ! Host move-threads \ System dependent Load-Screen 20Nov87 1 +load \ CP/M interface 2 4 +thru \ Character IO 5 7 +thru \ Default Disk IO 8 +load \ Postlude \ 9 +load \ Index \ CP/M-Interface 05Oct87Vocabulary Dos Dos definitions also Label >bios pchl Code biosa ( arg fun -- res ) 1 lhld D pop D dcx D dad D dad D dad D pop IP push D IP mvx >bios call Label back IP pop 0 H mvi A L mov Hpush jmp end-code Code bdosa ( arg fun -- res ) H pop D pop IP push L C mov 5 call back jmp end-code : bios ( arg fun -- ) biosa drop ; : bdos ( arg fun -- ) bdosa drop ; \ Character-IO Constants Character input 05Oct87 Target Dos also $08 Constant #bs $0D Constant #cr $0A Constant #lf $1B Constant #esc $09 Constant #tab $7F Constant #del $07 Constant #bel $0C Constant #ff : con! ( c -- ) 4 bios ; : (key? ( -- ? ) 0 2 biosa 0= not ; : getkey ( -- c ) 0 3 biosa ; : (key ( -- c ) BEGIN pause (key? UNTIL getkey ; \ Character output 07Oct87 UH 27Feb88 | Code ?ctrl ( c -- c' ) H pop L A mov $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code : (emit ( c -- ) ?ctrl con! pause ; : (cr #cr con! #lf con! ; : (del #bs con! bl con! #bs con! ; : (at? ( -- row col ) 0 0 ; : tipp ( addr len -- ) 0 ?DO count emit LOOP drop ; Output: display [ here output ! ] (emit (cr tipp (del noop 2drop (at? ; \ Line input 04Oct87 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ; : (decode ( addr pos1 key -- addr pos2 ) #bs case? IF backspace exit THEN #del case? IF backspace exit THEN #cr case? IF dup span ! space exit THEN dup emit >r 2dup + r> swap c! 1+ ; : (expect ( addr len -- ) span ! 0 BEGIN span @ over u> WHILE key decode REPEAT 2drop ; Input: keyboard [ here input ! ] (key (key? (decode (expect ; \ Default Disk Interface: Constants and Primitives 18Nov87 $80 Constant b/rec b/blk b/rec / Constant rec/blk Dos definitions ' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb : dos-error? ( n -- f ) $FF = ; $5C Constant fcb : reset ( -- ) 0 &13 bdos ; : openfile ( fcb -- f ) &15 bdosa dos-error? ; : closefile ( fcb -- f ) &16 bdosa dos-error? ; : dma! ( dma -- ) &26 bdos ; : rec@ ( fcb -- f ) &33 bdosa ; : rec! ( fcb -- f ) &34 bdosa ; \ Default Disk Interface: open and close 20Nov87 Target Dos also Defer drvinit Dos definitions | Variable opened : default ( -- ) opened off fcb 1+ c@ bl = ?exit $80 count here place #tib off fcb dup dosfcb> dup isfile ! fromfile ! openfile Abort" default file not found!" opened on ; ' default Is drvinit : close-default ( -- ) opened @ not ?exit fcb closefile Abort" can't close default-file!" ; ' close-default Is save-dos-buffers \ Default Disk Interface: read/write 14Feb88 Target Dos also | : rec# ( 'dosfcb -- 'rec# ) &33 + ; : (r/w ( adr blk file r/wf -- flag ) >r dup 0= Abort" no Direct Disk IO supported! " >dosfcb swap rec/blk * over rec# 0 over 2+ c! ! r> rot b/blk bounds DO I dma! 2dup IF rec@ drop ELSE rec! IF 2drop true endloop exit THEN THEN over rec# 0 over 2+ c! 1 swap +! b/rec +LOOP 2drop false ; ' (r/w Is r/w \ Postlude 20Nov87 Defer postlude | : (bye ( -- ) postlude 0 0 bdos ; | : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ; : .size ( -- ) base push decimal cr ." Size: &" #pages u. ." Pages" ; ' .size Is postlude \ index findex 20Nov87 | : range ( from to -- to+1 from ) 2dup > IF swap THEN 1+ swap ; : index ( from to --) range DO cr I 4 .r I space block c/l type stop? IF LEAVE THEN LOOP ; \ No newline at end of file diff --git a/disks/images/f/startup.fb b/disks/images/f/startup.fb new file mode 100644 index 0000000..a68c375 --- /dev/null +++ b/disks/images/f/startup.fb @@ -0,0 +1 @@ +\\ Startup: Load Standard System UH 11Nov86 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87include ass8080.fb include xinout.fb \ extended I/O \ include terminal.fb save \ Terminal include copy.fb cr .( copy and convey loaded) cr include savesys.fb cr .( Savesystem loaded) cr include editor.fb cr .( Editor loaded) cr include tools.fb cr .( Tools loaded) cr \ include see.fb cr .( Decompiler loaded) cr \ include tasker.fb cr .( Multitasker loaded) cr \ include printer.fb cr .( Printer Interface loaded) cr include relocate.fb cr .( Relocating loaded) cr .( May the volksFORTH be with you ...) cr decimal caps on scr off r# off savesystem volks4th.com UH 22Oct86 \ No newline at end of file diff --git a/disks/images/f/target.fb b/disks/images/f/target.fb new file mode 100644 index 0000000..3513652 --- /dev/null +++ b/disks/images/f/target.fb @@ -0,0 +1 @@ + \ 05Jul86 \ Target compiler loadscr UH 07Jun86\ Idea and first Implementation by ks/bp \ Implemented on 6502 by ks/bp \ ultraFORTH83-Version by bp/we \ Atari 520 ST - Version by we \ CP/M 2.2 Version by UH Onlyforth hex Assembler nonrelocate Vocabulary Ttools Vocabulary Defining 1 10 +thru \ Target compiler 11 13 +thru \ Target Tools 14 16 +thru \ Redefinitions save 17 20 +thru \ Predefinitions Onlyforth \ Target header pointers UH 26Mar88 Create lastname $20 allot Variable tdp : there tdp @ ; Variable displace Variable image Variable ?thead ?thead off Variable tlast tlast off Variable glast' glast' off Variable tdoes> Variable >in: Variable tvoc tvoc off Variable tvoc-link tvoc-link off 0 | Constant 0 | Constant | : Is> ( cfa -- ) [compile] Does> here 3 - swap >body ! 0 ] ; \ Image and byteorder UH 26Mar88 Code c+! ( 8b addr -- ) H pop D pop E A mov M add A M mov Next end-code Code /block ( addr -- +n blk ) H pop L E mov H A mov 3 ani A D mov H A mov $FC ani rrc rrc A L mov 0 H mvi dpush jmp end-code : >image ( addr1 - addr2 ) displace @ ( - /block image @ + block ) + ; : >heap ( from quan - ) dup hallot heap swap cmove ; \\ : c+! ( 8b addr -- ) dup c@ rot + swap c! ; : /block ( addr -- +n blk ) b/blk /mod ; \ Ghost-creating UH 26Mar88 | : (make.ghost ( str -- cfa.ghost ) dp push count dup 1 $1F uwithin not Abort" invalid Ghostname" here 2+ place here state @ \ address of link field IF context @ ELSE current THEN @ under @ , \ link 1 here c+! here c@ allot bl c, \ name here over - swap \ offset to codefield , 0 , 0 , \ code and parameter field here over - >heap \ move to heap heap rot ! \ link heap + ; \ codefield address | : Make.Ghost ( -- cfa.ghost ) name (make.ghost ; \ ghost words UH 28Apr88 : gfind ( string - cfa tf / string ff ) >r bl r@ count + c! 1 r@ c+! r@ find -1 r> c+! ; : (ghost ( string -- cfa ) gfind ?exit (make.ghost ; : ghost ( -- cfa ) name (ghost ; : gdoes> ( cfa.ghost - cfa.does ) dp push 4+ dup @ IF @ exit THEN \ defined here , 0 , 4 >heap \ forward-chain heap dup rot ! ; \ forward-link \ ghost utilities 2UH 26Mar88 : g' ( -- cfa.ghost ) name gfind 0= abort" ?" ; | : .ghost-type ( cfa.ghost -- ) @ case? IF ." forward" exit THEN - Abort" type unknown" ." resolved " ; | : .does-type ( cfa.does -- ) @ case? IF ." forward-define" exit THEN - Abort" does-type unknown" ." resolved-define" ; : '. ( -- ) g' dup .ghost-type dup 2+ @ 5 u.r 4+ @ ?dup 0=exit dup .does-type 2+ @ 5 u.r ; ' ' Alias h' \ .unresolved UH 26Mar88 | : forward? ( cfa -- f ) dup @ = swap 2+ @ and ; | : ghost? ( nfa -- f ) count $1F and + 1- c@ bl = ; | : unresolved? ( addr - f ) 2+ dup ghost? not IF drop false exit THEN name> dup forward? IF drop true exit THEN 4+ @ forward? ; | : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ; : .unresolved ( -- ) voc-link @ BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; \ Extending Vocabularys for Target-Compilation 2UH 26Mar88 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; Vocabulary Transient tvoc off Root definitions : T Transient ; immediate : H Forth ; immediate OnlyForth \ Transient primitives UH 26Mar88 Code byte> ( 8bl 8bh -- 16b ) D pop H pop E H mov hpush jmp end-code Code >byte ( 16b -- 8bh 8bl ) H pop H E mov 0 H mvi H D mov dpush jmp end-code Transient definitions : c@ ( addr -- 8b ) H >image c@ ; : c! ( 8b addr -- ) H >image c! ( update ) ; : @ ( addr -- n ) dup T c@ H swap 1+ T c@ H byte> ; : ! ( n addr -- ) >r >byte r@ T c! H r> 1+ T c! H ; : cmove ( from.mem to.target quan -) bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; : on ( addr -- ) true swap T ! H ; : off ( addr -- ) false swap T ! H ; \ Transient primitives UH 26Mar88 : here ( -- taddr ) there ; : allot ( n -- ) Tdp +! ; : c, ( c -- ) T here c! 1 allot H ; : , ( n -- ) T here ! 2 allot H ; : ," ( -- ) Ascii " parse dup T c, under here swap cmove allot H ; : fill ( addr len c -- ) -rot bounds ?DO dup I T c! H LOOP drop ; : erase ( addr len -- ) 0 T fill H ; : blank ( addr len -- ) bl T fill H ; : here! ( addr -- ) H tdp ! ; \ Resolving UH 26Mar88 Forth definitions : resolve ( cfa.ghost cfa.target -- ) 2dup swap >body dup @ >r ! over @ = IF drop >name space .name ." exists" ?cr rdrop exit THEN r> swap >r rot ! ?dup 0= IF rdrop exit THEN BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! H ?dup 0= UNTIL rdrop ; : resdoes> ( cfa.ghost cfa.target -- ) swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; ' Is> ( -- ) dup @ there rot ! T , H ; \ forward link ' Is> ( -- ) @ T , H ; \ compile target.cfa \ move-threads UH 26Mar88 : move-threads Tvoc @ Tvoc-link @ BEGIN over ?dup WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT error" some undef. Target-Vocs left" drop ; | : tlatest ( - addr) Current @ 6 + ; : save-target \ filename $100 dup >image there rot - savefile ; \ compiling names into targ. UH 26Mar88 | : viewfield ( -- n ) H blk @ $200 + ; \ in File #1 : (theader ( -- ) ?thead @ IF 1 ?thead +! exit THEN >in push name dup c@ 1 $20 uwithin not abort" invalid Targetname" viewfield T , H there tlatest @ T , H tlatest ! \ link there dup tlast ! over c@ 1+ dup T allot cmove H ; : Theader ( -- ) tlast off (theader Ghost dup glast' ! there resolve ; \ prebuild defining words bp2UH 26Mar88 | : executable? ( adr - adr f ) dup ; | : tpfa, there , ; | : (prebuild ( cfa.adr -- ) >in push Create here 2- ! ; : prebuild ( adr 0.from.: - 0 ) 0 ?pairs executable? dup >r IF [compile] Literal compile (prebuild ELSE drop THEN compile Theader Ghost gdoes> , r> IF compile tpfa, THEN 0 ; immediate restrict \ code portion of def.words bp2UH 26Mar88 : dummy 0 ; : DO> ( - adr.of.jmp.dodoes> 0 ) [compile] Does> here 3 - compile @ 0 ] ; \ The Target-Assembler UH 26Mar88 Forth definitions | Create relocate ] T c, , c@ here allot ! c! H [ Transient definitions : Assembler H [ Assembler ] relocate >codes ! Assembler ; : >label ( 16b -) H >in @ name gfind rot >in ! IF over resolve dup THEN drop Constant ; : Label H there T >label Assembler H ; : Code H Theader there 2+ T , Assembler H ; \ immed. restr. ' \ compile bp2UH 26Mar88 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; : >mark ( - addr) H there T 0 , H ; : >resolve ( addr -) H there over - swap T ! H ; : - cfa) H g' dup @ - abort" ?" 2+ @ ; : | H ?thead @ ?exit ?thead on ; : compile H Ghost , ; immediate restrict \ Target tools UH 26Mar88Onlyforth Ttools also definitions | : ttype ( adr n -) bounds ?DO I T c@ H dup bl > IF emit ELSE drop ascii . emit THEN LOOP ; : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype ELSE ." ??? " THEN space ?cr ; | : nfa? ( cfa lfa - nfa / cfa ff) BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ = IF 2+ nip exit THEN T @ H REPEAT ; : >name ( cfa - nfa / ff) Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN swap REPEAT nip ; \ Ttools for decompiling ks29jun85we | : ?: dup 4 u.r ." :" ; | : @? dup T @ H 6 u.r ; | : c? dup T c@ H 3 .r ; : s ( adr - adr+) ?: space c? 3 spaces dup 1+ over T c@ H ttype dup T c@ H + 1+ ; : n ( adr - adr+2) ?: @? 2 spaces dup T @ H [ Ttools ] >name .name H 2+ ; : d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot ttype ; \ Tools for decompiling bp204dec85we : l ( adr - adr+2) ?: 5 spaces @? 2+ ; : c ( adr - adr+1) 1 d ; : b ( adr - adr+1) ?: @? dup T @ H over + 5 u.r 2+ ; : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; : view T ' H [ Ttools ] >name ?dup IF 4 - T @ H list THEN ; \ reinterpretation def.-words UH 26Mar88 Onlyforth : redefinition ( -- ) tdoes> @ 0=exit >in push [ ' parser >body ] Literal push state push context push >in: @ >in ! name [ ' Transient 2+ ] Literal (find nip ?exit cr ." Redefinition: " here .name >in: @ >in ! : Defining interpret tdoes> off ; \ Create..does> structure 27Apr86 | : (;tcode Tlast @ dup T c@ + 1+ ! H rdrop ; | : changecfa compile lit tdoes> @ , compile (;tcode ; Defining definitions : ;code 0 ?pairs changecfa reveal rdrop rdrop ; immediate restrict Defining ' ;code Alias does> immediate restrict : ; [compile] ; rdrop rdrop ; immediate restrict \ redefinition conditionals bp27jun85we ' DO Alias DO immediate restrict ' ?DO Alias ?DO immediate restrict ' LOOP Alias LOOP immediate restrict ' IF Alias IF immediate restrict ' THEN Alias THEN immediate restrict ' ELSE Alias ELSE immediate restrict ' BEGIN Alias BEGIN immediate restrict ' UNTIL Alias UNTIL immediate restrict ' WHILE Alias WHILE immediate restrict ' REPEAT Alias REPEAT immediate restrict \ clear Liter. Ascii ['] ." UH 26Mar88 Onlyforth Transient definitions : clear True abort" There are ghosts" ; : Literal ( n -) H dup $FF00 and IF T compile lit , H exit THEN T compile clit c, H ; immediate : Ascii H bl word 1+ c@ state @ 0=exit T [compile] Literal H ; immediate : ['] T ' [compile] Literal H ; immediate restrict : " T compile (" ," H ; immediate restrict : ." T compile (." ," H ; immediate restrict : even H ; immediate \ machen nichts beim 8080 : align H ; immediate : halign H ; immediate \ Target compilation ] [ bp0UH 26Mar88 Forth definitions : tcompile ( str -- ) count lastname place lastname find ?dup IF 0> IF execute exit THEN drop lastname THEN gfind IF execute exit THEN number? ?dup IF 0> IF swap T [compile] Literal THEN [compile] Literal H exit THEN (ghost execute ; Transient definitions : ] H State on ['] tcompile is parser ; \ Target conditionals bp27jun85we : IF T compile ?branch >mark H 1 ; immediate restrict : THEN abs 1 T ?pairs >resolve H ; immediate restrict : ELSE T 1 ?pairs compile branch >mark swap >resolve H -1 ; immediate restrict : BEGIN T mark -2 H 2swap ; immediate restrict | : (repeat T 2 ?pairs resolve H REPEAT ; : UNTIL T compile ?branch (repeat H ; immediate restrict : REPEAT T compile branch (repeat H ; immediate restrict \ Target conditionals bp27jun85we : DO T compile (do >mark H 3 ; immediate restrict : ?DO T compile (?do >mark H 3 ; immediate restrict : LOOP T 3 ?pairs compile (loop compile endloop >resolve H ; immediate restrict : +LOOP T 3 ?pairs compile (+loop compile endloop >resolve H ; immediate restrict \ predefinitions bp27jun85we : abort" T compile (abort" ," H ; immediate : error" T compile (err" ," H ; immediate Forth definitions Variable torigin Variable tudp 0 tudp ! : >user T c@ H torigin @ + ; \ Datatypes bp2UH 07Nov87 Transient definitions : origin! H torigin ! ; : user' ( - 8b) T ' 2 + c@ H ; : uallot ( n -) H tudp @ swap tudp +! ; DO> >user ; : User prebuild User 2 T uallot c, ; DO> ; : Create prebuild (create ; DO> T @ H ; : Constant prebuild Constant T , ; : Variable Create 2 T allot ; \ Datatypes UH 07Nov87 dummy : Vocabulary H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , here H tvoc-link @ T , H tvoc-link ! ; dummy : (create prebuild (create ; \ target defining words 27Apr86 Do> ; : Defer prebuild Defer 2 T allot ; : Is T ' H >body State @ IF T compile (is , H ELSE T ! H THEN ; immediate | : dodoes> T compile (;code H Glast' @ there resdoes> there tdoes> ! ; : ;code 0 T ?pairs dodoes> Assembler H [compile] [ redefinition ; immediate restrict : does> T dodoes> $CD c, compile (dodoes> H ; immediate restrict \ : Alias ; bUH 07Jun86 dummy : : H tdoes> off >in @ >in: ! T prebuild : H current @ context ! T ] H 0 ; : Create: Create H current @ context ! T ] H 0 ; : Alias ( n -- ) H Tlast off (theader Ghost over resolve tlast @ T c@ H 20 or tlast @ T c! , H ; : ; T 0 ?pairs compile unnest [compile] [ H redefinition ; immediate restrict \ predefinitions UH 26Mar88 : compile T compile compile H ; immediate restrict : Host H Onlyforth Ttools also ; : Compiler T Host H Transient also definitions ; : [compile] H ghost execute ; immediate restrict \ : Onlypatch H there 3 - 0 tdoes> ! 0 ; Onlyforth : Target Onlyforth Transient also definitions ; Transient definitions Ghost c, drop \ No newline at end of file diff --git a/disks/images/f/tasker.fb b/disks/images/f/tasker.fb new file mode 100644 index 0000000..c148f80 --- /dev/null +++ b/disks/images/f/tasker.fb @@ -0,0 +1 @@ +\\ Multitasker 11Nov86 Dieses File enthaelt den Multitasker des volksFORTHs. Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt die Kontrolle ueber den Prozessor solange, bis sie sie ausdruecklich abgibt. Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet auf den Massenspeicher und auf den Drucker zugreifen. In Verbindung mit dem Printer-Interface ist es moeglich Files im Hintergrund auszudrucken. (SPOOL) \ Multitasker Loadscreen 27Jun86 20Nov87 Onlyforth \needs multitask 1 +load 02 05 +thru \ Tasker \ stop singletask multitask 28Aug86 20Nov87 Code stop UP lhld 0 ( nop ) M mvi Label taskpause IP push RP lhld H push UP lhld 6 D lxi D dad xchg H L mov SP dad xchg E M mov H inx D M mov UP lhld H inx pchl end-code : singletask [ ' pause @ ] Literal ['] pause ! ; : multitask [ taskpause ] Literal ['] pause ! ; \ pass activate 28Aug86 : pass ( n0 ... nr-1 Taddr r -- ) BEGIN [ rot ( Trick !! ) ] swap $F7 over c! \ awake Task ( rst 6 ) r> -rot \ Stack: IP r addr 8 + >r \ s0 of Task r@ 2+ @ swap \ Stack: IP r0 r 2+ 2* \ bytes on Taskstack incl. r0 & IP r@ @ over - \ new SP dup r> 2- ! \ into Ssave swap bounds ?DO I ! 2 +LOOP ; restrict : activate ( Taddr -- ) 0 [ -rot ( Trick !! ) ] REPEAT ; restrict \ sleep wake taskerror 28Aug86 20Nov87 : sleep ( Taddr -- ) $00 ( nop ) swap c! ; : wake ( Taddr -- ) $F7 ( rst 6 ) swap c! ; | : taskerror ( string -- ) standardi/o singletask ." Task error : " count type multitask stop ; \ Task 20Nov87 : Task ( rlen slen -- ) 0 Constant here 2- >r \ addr of task constant here -rot \ here for Task dp even allot even \ allot dictionary area here r@ ! \ set task constant addr up@ here $100 cmove \ init user area here dup $C300 , \ nop-jmp opcode to sleep task up@ 2+ dup @ , ! \ link task r> , \ spare used for pointer to header dup 6 - dup , , \ ssave and s0 2dup + , \ here + rlen = r0 rot , \ dp under + dp ! 0 , \ allot rstack ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; \ rendezvous 's tasks 27Jun86 20Nov87 : rendezvous ( semaphoraddr -- ) dup unlock pause lock ; | : statesmart state @ IF [compile] Literal THEN ; : 's ( Taddr -- adr.of.tasks.userarea ) ' >body c@ + statesmart ; immediate : tasks ( -- ) ." Main " cr up@ dup 2+ @ BEGIN 2dup - WHILE dup 4+ @ body> >name .name dup c@ 0= ( nop ) IF ." sleeping" THEN cr 2+ @ REPEAT 2drop ; \ No newline at end of file diff --git a/disks/images/f/terminal.fb b/disks/images/f/terminal.fb new file mode 100644 index 0000000..6510bca --- /dev/null +++ b/disks/images/f/terminal.fb @@ -0,0 +1 @@ +\\ Terminal-Anpassung UH 08OCt87 In diesem File wird volksFORTH an das benutzte Terminal angepasst. Ueber folgende Faehigkeiten muss das Terminal verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt werden koennen: curon, curoff \ Ein- bzw. Ausschalten des Cursors rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellungdark \ Loeschen des Bildschirms locate \ Positionieren des Cursors auf eine \ bestimmte Position auf dem Bildschirm In der Version 3.80a nicht mehr in der Terminal-Anpassung: curleft, currite \ Cursor nach links bzw. rechts bewegen \ Anpassung fuer ANSI-Terminal uho 09May2005| : ccon!! ( addr len -- ) bounds ?DO I C@ con! LOOP ; | : con!! ( addr -- ) count ccon!! ; | : ## ( n -- ) base push decimal 0 <# #S #> ccon!! ; | : csi ( -- ) #esc con! Ascii [ con! ; | : ANSIcuron ( -- ) csi " ?25h" con!! ; | : ANSIcuroff ( -- ) csi " ?25l" con!! ; | : ANSIrvson ( -- ) csi " 7m" con!! ; | : ANSIrvsoff ( -- ) csi " 0m" con!! ; | : ANSIdark ( -- ) csi " 2J" con!! csi " ;H" con!! ; | : ANSIlocate ( row col -- ) csi swap 1+ ## ascii ; con! 1+ ## ascii H con! ; Terminal: ANSI noop noop ANSIrvson ANSIrvsoff ANSIdark ANSIlocate ; ANSI page rvson .( ANSI Terminal installiert. ) rvsoff cr cr \ No newline at end of file diff --git a/disks/images/f/times.fb b/disks/images/f/times.fb new file mode 100644 index 0000000..c4c42c3 --- /dev/null +++ b/disks/images/f/times.fb @@ -0,0 +1 @@ +\\ Times Often: interactive loops 11Nov86 Dieses File enthaelt die Definitionen der beiden Utility-Worte TIMES, OFTEN, die interaktiv benutzt werden koennen, was normalerweise mit BEGIN WHILE ... nicht moeglich ist. Benutzung: nur interaktiv! a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal, \ oder bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt, a b ... often \ Wiederhole die Befehlsfolge "a b ..." \ so oft, bis eine Taste gedrueckt wird, oder \ bis ein Fehler auftritt. \ Times, Often 02feb86 also Forth definitions : often stop? ?exit >in off ; | Variable #times #times off : times ( n --) ?dup IF #times @ 2+ u< stop? or IF #times off exit THEN 1 #times +! ELSE stop? ?exit THEN >in off ; toss definitions \ No newline at end of file diff --git a/disks/images/f/tools.fb b/disks/images/f/tools.fb new file mode 100644 index 0000000..ab14892 --- /dev/null +++ b/disks/images/f/tools.fb @@ -0,0 +1 @@ +\\ Tools 11Nov86Dieses File enthaelt die wichtigsten Werkzeuge zur Programm- entwicklung: - den einfachen Decompiler - der DUMP-Befehl - den Tracer Der einfache Decompiler wird benutzt, um neue Defining-Words zu ueberpruefen. Der automatische Decompiler kann ja dafuer nicht benutzt werden, da ihm diese Strukturen unbekannt sind. (Benutzung: addr und dann, je nach Art: S N D L C oder B) DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP) Der Tracer erlaubt Einzelschrittausfuehrung von Worten. Er ist unentbehrliches Hilfsmittel bei der Fehlersuche. (Benutzung: DEBUG und END-TRACE) \ Programming-Tools word set / tracer cas 19july2020 Onlyforth Vocabulary Tools Tools also definitions 01 05 +thru &15 &16 +thru 06 +load \ Tracer Onlyforth : internal \ start headerless definitions 1 ?head ! ; : external \ end headerless definitions ?head off ; \ Tools for decompiling 22feb86 | : ?: dup 4 u.r ." :" ; | : @? dup @ 6 u.r ; | : c? dup c@ 3 .r ; : s ( adr - adr+ ) ?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ; : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ; : d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; \ Tools for decompiling 22feb86 : l ( adr - adr+2 ) ?: 5 spaces @? 2+ ; : c ( adr - adr+1) 1 d ; : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; \\ : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; \ General Dump Utility - Output UH 07Jun86 | : .2 ( n -- ) 0 <# # # #> type space ; | : .6 ( d -- ) <# # # # # # # #> type ; | : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ; | : emit. ( char -- ) $7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ; | : dln ( addr --- ) cr dup 6 u.r 2 spaces 8 2dup d.2 space over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ; | : ?.n ( n1 n2 -- n1 ) 2dup = IF ." \/" drop ELSE 2 .r THEN space ; | : ?.a ( n1 n2 -- n1 ) 2dup = IF ." V" drop ELSE 1 .r THEN ; \ .head UH 03Jun86 | : .head ( addr len -- addr' len' ) swap dup -$10 and swap $0F and cr 8 spaces 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP space $10 0 DO I ?.a LOOP rot + ; \ Dump and Fill Memory Utility UH 25Aug86 Forth definitions : dump ( addr len -- ) base push hex .head bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; Tools definitions : du ( addr -- addr+$40 ) dup $40 dump $40 + ; : dl ( line# -- ) c/l * scr @ block + c/l dump ; Forth definitions \ Trace Loadscreen 29Jun86 Onlyforth \needs Tools Vocabulary Tools Tools also definitions 1 8 +thru Onlyforth \ clear \ don't forget END-TRACE after using DEBUG \ Variables do-trace UH 04Nov86 | Variable Wsave \ Variable for saving W | Variable \ end of trace trap range | Variable 'ip \ holds IP (preincrement!) | Variable nest? \ True if NEST shall be performed | Variable newnext \ Address of new Next for tracing | Variable #spaces \ for indenting nested trace | Variable tracing \ true if trace mode active \ install Tracer UH 18Nov87 Tools definitions | Code do-trace \ patch Next to new definition $C3 A mvi ( jmp ) >next sta newnext lhld >next 1+ shld Next end-code \ throw status on Return-Stack 29Jun86 | Create: npull rp@ count 2dup + even rp! r> swap cmove ; : npush ( addr len --) r> -rot over >r rp@ over 1+ - even dup rp! place npull >r >r ; | : oneline .status space query interpret -&82 allot rdrop ( delete quit from tracenext ) ; \ reenter tracer 04Nov86 | Code (step true H lxi tracing shld IP rpop Wsave lhld H W mvx Label fnext xchg M E mov H inx M D mov xchg pchl end-code | Create: nextstep (step ; | : (debug ( addr --) \ start tracing at addr dup ! ; \ check trace conditions 04Nov86 Label tracenext tracenext newnext ! IP ldax IP inx A L mov IP ldax IP inx A H mov xchg tracing lhld H A mov L ora fnext jz nest? 1+ lda A ana 0= ?[ lhld H A mov IP cmp fnext jc 0= ?[ L A mov IP' cmp fnext jc ]? ][ A xra nest? 1+ sta ]? \ low byte still set \ one trace condition satisfied W H mvx Wsave shld false H lxi tracing shld \ tracer display UH 25Jan88 ;c: nest? @ IF nest? off r> ip> push r THEN r@ nextstep >r input push output push standardi/o cr #spaces @ spaces dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces >name .name $1C col - 0 max spaces .s state push blk push >in push ['] 'quit >body push [ ' parser >body ] Literal push span push #tib push tib #tib @ npush r0 push rp@ r0 ! &82 allot ['] oneline Is 'quit quit ; \ DEBUG with errorchecking 28Nov86 | : traceable ( cfa -- cfa' ) recursive dup @ ['] : @ case? ?exit ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN ['] r/w @ case? IF >body traceable exit THEN dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN drop >name .name ." can't be DEBUGged" quit ; also Forth definitions : debug ( -- ) \ reads a word ' traceable (debug Tools nest? off #spaces off tracing on do-trace ; \ misc. words for tracing 28Nov86Tools definitions : nest \ trace next high-level word executed 'ip @ 2- @ traceable drop nest? on ; : unnest \ ends tracing of actual word off ; \ clears trap range : endloop \ stop tracing loop 'ip @ R NR> cr : N>R ( i * n +n -- ) ( R: -- j * x +n ) \ Transfer N items and count to the return stack. DUP BEGIN DUP WHILE ROT R> SWAP >R >R 1- REPEAT DROP R> SWAP >R >R ; : NR> ( -- i * x +n ) ( R: j * x +n -- ) \ Pull N items and count off the return stack. R> R> SWAP >R DUP BEGIN DUP WHILE R> R> SWAP >R -ROT 1- REPEAT DROP ; \ ? : ? ( a-addr -- ) \ Display the value stored at a-addr. @ . ; \ No newline at end of file diff --git a/disks/images/f/volks4th.cnf b/disks/images/f/volks4th.cnf new file mode 100644 index 0000000..81afdc8 --- /dev/null +++ b/disks/images/f/volks4th.cnf @@ -0,0 +1,12 @@ +# config file for tnylpo +drive a = "." +printer file = "./printer.txt" +printer mode = text +logfile = "./.tnylpo.log" +loglevel = 0 +console = full +lines = 24 +columns = 80 +application cursor = true +screen delay = 2 + diff --git a/disks/images/f/volks4th.com b/disks/images/f/volks4th.com new file mode 100644 index 0000000..a7d2060 Binary files /dev/null and b/disks/images/f/volks4th.com differ diff --git a/disks/images/f/xinout.fb b/disks/images/f/xinout.fb new file mode 100644 index 0000000..364659e --- /dev/null +++ b/disks/images/f/xinout.fb @@ -0,0 +1 @@ +\ Erweiterte I/O-Funktionen 3.80a UH 08Oct87 Dieses File enthaelt Definitionen, die eine erweiterte Bild- schirmdarstellung ermoeglichen: - Installation eines Terminals mit Hilfe des Wortes "Terminal:" - Editieren von Eingabezeilen In der Version 3.80a sind diese Teile aus dem Kern genommen worden, um diesen einfacher zu gestalten. \ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87 1 3 +thru \ Erweiterte Ausgabe 4 6 +thru \ Erweiterte Eingabe ' curon Is postlude \ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87| Variable terminal : Term: ( off -- off' ) Create dup c, 2+ Does> c@ terminal @ + perform ; : Terminal: Create: Does> terminal ! ; 0 Term: curon Term: curoff Term: rvson Term: rvsoff Term: dark Term: locate drop : curleft ( -- ) at? 1- at ; : currite ( -- ) at? 1+ at ; Terminal: dumb noop noop noop noop noop 2drop ; dumb \ Erweiterte Ausgabe: UH 06Mar88 &80 Constant c/row &24 Constant c/col | Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col : (at ( row col -- ) c/row 1- min swap c/col 1- min swap 2dup 'at 2! locate ; : (at? ( -- row col ) 'at 2@ ; : (page ( -- ) 0 0 'at 2! dark ; : (type ( addr len -- ) dup 'col +! 0 ?DO count (emit LOOP drop ; : (emit ( c -- ) 1 'col +! (emit ; \ Erweiterte Ausgabe: UH 04Mar88 : (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ; : (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ; ' (emit ' display 2+ ! ' (cr ' display 4 + ! ' (type ' display 6 + ! ' (del ' display 8 + ! ' (page ' display &10 + ! ' (at ' display &12 + ! ' (at? ' display &14 + ! \ Erweiterte Eingabe UH 08OCt87| Variable maxchars | Variable oldspan oldspan off | : redisplay ( addr pos -- ) at? 2swap under + span @ rot - type space at ; | : del ( addr pos1 -- ) dup >r + dup 1+ swap span @ r> - 1- cmove -1 span +! ; | : ins ( addr pos1 -- ) dup >r + dup dup 1+ span @ r> - cmove> bl swap c! 1 span +! ; | : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ; | : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ; | : (back ( a p1 -- a p2 ) 1- curleft (del ; | : (recall ( a p1 -- a p2 ) ?dup ?exit oldspan @ span ! 0 2dup redisplay ; \ Tastenbelegung fuer Zeilen-Editor CP/M UH 18Mar88: (decode ( addr pos1 key -- addr pos2 ) 4 case? IF dup span @ < 0=exit currite 1+ exit THEN &19 case? IF dup 0=exit curleft 1- exit THEN &22 case? IF dup span @ = ?exit (ins exit THEN #bs case? IF dup 0=exit (back exit THEN #del case? IF dup 0=exit (back exit THEN 7 case? IF span @ 2dup < and 0=exit (del exit THEN $1B case? IF (recall exit THEN #cr case? IF span @ dup maxchars ! oldspan ! dup at? rot span @ - - at space exit THEN dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ; : (expect ( addr len -- ) maxchars ! span off 0 BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ; \ Patch UH 08Oct87 : (key ( -- char ) curon BEGIN pause (key? UNTIL curoff getkey ; ' (key ' keyboard 2+ ! ' (decode ' keyboard 6 + ! ' (expect ' keyboard 8 + ! \ No newline at end of file diff --git a/disks/images/g/ZORK1.COM b/disks/images/g/ZORK1.COM new file mode 100644 index 0000000..8a7bec1 Binary files /dev/null and b/disks/images/g/ZORK1.COM differ diff --git a/disks/images/g/ZORK1.DAT b/disks/images/g/ZORK1.DAT new file mode 100644 index 0000000..b2eb461 Binary files /dev/null and b/disks/images/g/ZORK1.DAT differ diff --git a/disks/images/g/ZORK2.COM b/disks/images/g/ZORK2.COM new file mode 100644 index 0000000..e4eac0e Binary files /dev/null and b/disks/images/g/ZORK2.COM differ diff --git a/disks/images/g/ZORK2.DAT b/disks/images/g/ZORK2.DAT new file mode 100644 index 0000000..d14dc8c Binary files /dev/null and b/disks/images/g/ZORK2.DAT differ diff --git a/disks/images/g/ZORK3.COM b/disks/images/g/ZORK3.COM new file mode 100644 index 0000000..9b248ed Binary files /dev/null and b/disks/images/g/ZORK3.COM differ diff --git a/disks/images/g/ZORK3.DAT b/disks/images/g/ZORK3.DAT new file mode 100644 index 0000000..1aed086 Binary files /dev/null and b/disks/images/g/ZORK3.DAT differ diff --git a/disks/images/g/hitch.com b/disks/images/g/hitch.com new file mode 100644 index 0000000..4822bc2 Binary files /dev/null and b/disks/images/g/hitch.com differ diff --git a/disks/images/g/hitchhik.dat b/disks/images/g/hitchhik.dat new file mode 100644 index 0000000..3a3e338 Binary files /dev/null and b/disks/images/g/hitchhik.dat differ diff --git a/disks/images/g/planet.com b/disks/images/g/planet.com new file mode 100644 index 0000000..9b346ae Binary files /dev/null and b/disks/images/g/planet.com differ diff --git a/disks/images/g/planetfa.dat b/disks/images/g/planetfa.dat new file mode 100644 index 0000000..0ee7114 Binary files /dev/null and b/disks/images/g/planetfa.dat differ diff --git a/disks/images/p/mc.hlp b/disks/images/p/mc.hlp new file mode 100644 index 0000000..9e4e1fa --- /dev/null +++ b/disks/images/p/mc.hlp @@ -0,0 +1,144 @@ + INTRODUCTION + +MicroCalc is a tiny spread sheet program a la VisiCalc. It is +provided with the TURBO-Pascal system as an example program. + +Since MicroCalc is only a demonstation program it has its limita- +tions (which you may have fun eliminating): + + * You cannot copy formulas from one cell to others. + * You cannot insert and delete lines or columns. + +In spite of its limitations MicroCalc does provide some interest- +ing features among which are: + + * 11 digits floating point reals (Thanks to TURBO Pascal!) + * Full set of mathematical functions (SIN,COS,LN,EXP etc.) + * Built in line editor for text and formula editing. + * Text can be entered across cells. + * Once entered a formula is protected from accidental erasure. +.PA + + +In addition to this MicroCalc offers all the usual features of a +spread sheet program: + + + * Load a spread sheet from the disk. + * Save a spread sheet on the disk. + * Automatic recalculation after each entry. (May be disabled). + * Print the spread sheet on the printer. + * Clear the current spread sheet. + +The spread sheet is an electronic piece of paper on which you can +enter text, numbers and formulas and have MicroCalc do calcula- +tions automatically. + +The next page shows the electronic spread sheet. +.PA +---------------------------------------------------------------- + A B C D .... + 1 22.00 + 2 1.00 + 3 2.00 + 4 3.00 + 5 28.00 + . + . +A 5 Formula: +(A1+A2+A3+A4+A5) +----------------------------------------------------------------- + +In the example the next last line shows that the active cell is +cell A5 and that A5 contains a formula: (A1+A2+A3+A4) which +means that the numbers in A1,A2,A3 and A4 should be added and +placed in A5. + +The formula can be abbreviated to: (A1>A4) meaning: add all cells +from A1 to A4. +.PA + +You move the cursor around just like you do in the TURBO editor: + + (Up) + Ctrl-E + (Left) Ctrl-S Ctrl-G (Right) + Ctrl-X + (Down) + +A cell may contain a number, a formula or some text. The type of of the cell +and its coordinates are shown in the bottom left corner of the screen: + +A 5 Formula: (Means that the current cell is A5 and that it + contains a formula) + +A 1 Text (Cell A1 contains text) + +A 2 Numeric (Cell A2 contains a number and no cell references) + +.PA + Summary of MicroCalc + Cells are denoted A1 through G21 giving a total of 147 cells. + +Summary of standard functions and operators: +SIN, COS, ARCT, ABS, FACT, EXP, LN, +,-,/,* +Futhermore the operator '>' can be used to denote a range of cells to add. + +Entering data +To enter data in any field move the cursor to the cell and enter the +data. MicroCalc automatically determines if the field is numeric or a +a text field. + + +When moving between fields: +^S,^D,^E,^X move left right up and down. + +When editing a field +^S,^D moves left and right. ^A,^F moves to beginning/end of line. +DEL,^G deletes left or right character. +ESC makes it possible to regret changes and to edit an existing cell. +.PA + + + Summary of commands + + + / will restore the screen + Q will Quit MicroCalc + L will Load a spread sheet from the disk. + S will Save a spread sheet on the disk. + R will Recalculate + P will Print the spread sheet. + F makes it possible to change the output format for numbers. + A switches Autocalc ON and OFF + +Note: to use scientific notation use the the F command and enter minus one + -1 for the number of decimals. + +.PA + + EXAMPLES + +The following are examples of valid cell formulas: + +A1+(B2-C7) subtract cell C7 from B2 and add the result to cell A1 +(A1>A23) the sum of cells: A1,A2,A3..A23 +(A1>B5) the sum of cells: A1..A5 and B1..B5 + +The formulas may be as complicated as you want:  + +SIN(A1)*COS(A2)/((1.2*A8)+LN(FACT(A8)+8.9E-3))+(C1>C5) + +To edit an existing formula or text simply move to the cell and +press ESC, make your changes and press . If you make +a mistake you may press ESC again, the old value of the cell will +then be restored. + +To try MicroCalc now you may use the /L command and load the file: +CALCDEMO. + + + try MicroCalc now you may use the /L command and load the file: +CALCDEMO. + + diff --git a/disks/images/p/read.me b/disks/images/p/read.me new file mode 100644 index 0000000..91664e0 --- /dev/null +++ b/disks/images/p/read.me @@ -0,0 +1,180 @@ + + Welcome to TURBO PASCAL Version 3.0! + ------------------------------------ + + In spite of all efforts, some errors have found their way into + the new TURBO 3.0 manual. This file contains all the necessary + corrections and additions, and we apologize for any inconvenience + this may cause you. + + Please make a working copy of your TURBO disk and store the ori- + ginal in a safe place. For help making a backup copy, please + refer to appendix M of the TURBO PASCAL Reference Manual. + + NOTEє  Youт  TURBП  PASCAМ disл haу beeо pre-installeд  foт  youт Ќ +    Microbeе disл system¬ paщ nп attentioо tп thе manuaм witи regardу Ќ +    to installing TURBO PASCAL. + + + ******************************************* + * * + * Need help with TURBO? Please see * + * Appendix N in your Reference Manual * + * for answers to common questions. * + * * + ******************************************* + + + ------------------- + + + Contents of the READ.ME File + ---------------------------- + 1. CORRECTIONS to the 3.0 Reference Manual [ All versions ] + 2. OMMISSIONS from the 3.0 Reference Manual [ All versions ] + 3. New FEATURES [ CP/M-80 ] + 4. ADDITIONAL FILE LIST [ CP/M-80 ] + + + ------------------- + + + CORRECTIONS + ----------- + + +Page 253 - MOV AL,[BP-1] +------------------------ + The correct statement is: MOV AL,[BP+4] + + +Page 293 - TURBO-BCD will compile and run any program +----------------------------------------------------- + Well - almost. The Real functions Sin, Cos, ArcTan, Ln, Exp, + and Sqrt and the pre-declared constant Pi are not available + in TURBOBCD. Љ + + ------------------- + + + OMISSIONS + --------- + + +User Written Error Handlers +--------------------------- + In Turbo Pascal 3.0 you may write your own error handler, + which is called in case of an I/O or Run-time error. The + procedure must have the following header: + + procedure Error(ErrNo, ErrAddr: Integer); + + The name of the procedure and its parameters are unim- + portant, as long as it is a procedure with two value + parameters of type Integer. + + The value passed in ErrNo is the error type and number. The + most significant byte, i.e. "Hi(ErrNo)", contains the error + type, and the least significant byte, i.e. "Lo(ErrNo)", + contains the error number (see Appendix F or G in the Turbo + Pascal Manual). + + The following error types are defined: + + 0 User Break (Ctrl-C). + 1 I/O error. + 2 Run-time error. + + In case of a user interrupt (Ctrl-C), the low byte of + "ErrNo" is always 1. "ErrAddr" contains the address (offset + in Code Segment for 16 bit versions) of the error. + + To activate the error handler, assign its offset address + to the standard variable "ErrorPtr", i.e. + + ErrorPtr:=Ofs(Error); { 16 bit } or + ErrorPtr:=Addr(Error); { 8 bit } + + There are no limits to what an error handler may do. Typi- + cally it will close all open files, output an error mes- + sage, and call the Halt standard procedure to terminate the + program. If an error handler returns, i.e. if it does + not call Halt, or if an error occurs within an error + handler, Turbo Pascal will itself output the error message + and terminate the program. + + + + + ------------------- Љ + + NEW FEATURES OF CP/M-80 IMPLEMENTATION OF + TURBO 3.0 + - AN OVERVIEW - + ----------------------------------------- + +Inline +------ + A constant identifier used in an INLINE statement does not + always generate two bytes of code. + +Files +----- + New FIB formats. + Optional 4th parameter on Blockread/Write returns number of + blocks actually read. + SeekEoln function. + SeekEof function. + + +Misc. +----- + Exit procedure - To exit the current block + OvrDrive procedure - To specify the drive on which to find overlays + ParamCount function - Gives number of characters in the command buffer + ParamStr function - Gives the string of characters in the command line + +Overlays +-------- + + Overlay files are opened and closed every time they are + accessed. Therefore, there is never a need to specifically + close an overlay file. + + The Y compiler directive is no longer supported. Instead, + the OvrPath (MS-DOS) or OvrDrive (CP/M) standard proce- + dures may be used to specify the drive and subdirectory + in which overlay files reside. + + Please note that run-time error F0 indicates that your over- + lay file is missing or is called recursively. (This error + number is omitted from the Reference Manual but is included + elsewhere in this file.) + + + ------------------- + + TURBO PASCAL Version 3.0 + CP/M-80 + Additional File List + + In addition to the list of files mentioned in Chapter 1 of + your TURBO Reference Manual, the following files are included + on your TURBO disk: Љ + Sample programs + --------------- + LISTER PAS - simple program to list your Pascal source + CMDLIN PAS - get parameters from the command line + + MC PAS - sample spreadsheet program - MAIN MODULE + MC-MOD00 INC - sample spreadsheet program - INCLUDE MODULE 00 + MC-MOD01 INC - sample spreadsheet program - INCLUDE MODULE 01 + MC-MOD02 INC - sample spreadsheet program - INCLUDE MODULE 02 + MC-MOD03 INC - sample spreadsheet program - INCLUDE MODULE 03 + MC-MOD04 INC - sample spreadsheet program - INCLUDE MODULE 04 + MC-MOD05 INC - sample spreadsheet program - INCLUDE MODULE 05 + MC HLP - spreadsheet help file + MCDEMO MCS - spreadsheet data file (not for use with TURBO-87) + + --------------------------------------------------------------------- + diff --git a/disks/images/p/tinst.com b/disks/images/p/tinst.com new file mode 100644 index 0000000..fa7756a Binary files /dev/null and b/disks/images/p/tinst.com differ diff --git a/disks/images/p/tinst.dta b/disks/images/p/tinst.dta new file mode 100644 index 0000000..d27687b Binary files /dev/null and b/disks/images/p/tinst.dta differ diff --git a/disks/images/p/tinst.msg b/disks/images/p/tinst.msg new file mode 100644 index 0000000..3578520 --- /dev/null +++ b/disks/images/p/tinst.msg @@ -0,0 +1,122 @@ +1 TURBO Pascal installation menu. +2 Choose installation item from the following: +3 +4 [S]creen installation | [C]ommand installation | [Q]uit +5 +6 Enter S, C, or Q: +10 Duplicate definition. Error occurred between question +11 Commands starting with the same letter must have the same length. + Error occurred between question +12 The total maximum length of commands are execeeded +13 -> + + +14 CURSOR MOVEMENTS: + +20 Character left +21 Alternative +22 Character right +23 Word left +24 Word right +25 Line up +26 Line down +27 Scroll down +28 Scroll up +29 Page up +30 Page down +31 To left on line +32 To right on line +33 To top of page +34 To bottom of page +35 To top of file +36 To end of file +37 To begining of block +38 To end of block +39 To last cursor position + + +15 INSERT & DELETE: + +40 Insert mode on/off +41 Insert line +42 Delete line +43 Delete to end of line +44 Delete right word +45 Delete character under cursor +46 Delete left character +47 Alternative + + +16 BLOCK COMMANDS: + +48 Mark block begin +49 Mark block end +50 Mark single word +51 Hide/display block +52 Copy block +53 Move block +54 Delete block +55 Read block from disk +56 Write block to disk + + +17 MISC. EDITING COMMANDS: + +57 End edit +58 Tab +59 Auto tab on/off +60 Restore line +61 Find +62 Find & replace +63 Repeat last find +64 Control character prefix + +101 Nothing + ^Q: Quit, ^R: Last page, ^C: Next page, : Select terminal: + Wait Sorting Definitions + Change to: + (Y/N)? + y + n + Text file name: + Command: + Numeric entry expected + Legal range is + , please re-enter: + Choose one of the following terminals: + None of the above ( Max. 20 Characters ) + Delete a definition ( Max. 20 Characters ) + Which terminal? (Enter no. or ^Q to exit): + Delete terminal? (Enter no. or ^Q to exit): + Do you want to modify this definition before installation? + Terminal type: + Send an initialization string to the terminal? + Initializaion defined as a command string? (No = a file) + Send a reset string to the terminal + Reset defined as a command? (No = a file) + CURSOR LEAD-IN command: + CURSOR POSITIONING COMMAND to send between line and column: + CURSOR POSITIONING COMMAND to send after both line and column: + Column first + OFFSET to add to LINE: + OFFSET to add to COLUMN: + Binary address + Number of ASCII digits (2 or 3): + CLEAR SCREEN command: + Does CLEAR SCREEN also HOME cursor + HOME command: + DELETE LINE command: + INSERT LINE command: + ERASE TO END OF LINE command: + START HIGHLIGHTING command: + END HIGHLIGHTING command: + Number of rows (lines) on your screen: + Number of columns on your screen: + Delay after CURSOR ADDRESS (0-255 ms): + Delay after CLEAR, DELETE and INSERT (0-255 ms): + Delay after ERASE TO END OF LINE and HIGHLIGHT (0-255 ms): + Is this definition correct? + Hardware dependent information + Operating frequency of your microprocessor in MHz (for delays): +pendent information + Operating frequency of your microprocessor in MHz (for delays): diff --git a/disks/images/p/turbo.com b/disks/images/p/turbo.com new file mode 100644 index 0000000..1b050b7 Binary files /dev/null and b/disks/images/p/turbo.com differ diff --git a/disks/images/p/turbo.msg b/disks/images/p/turbo.msg new file mode 100644 index 0000000..72d478c --- /dev/null +++ b/disks/images/p/turbo.msg @@ -0,0 +1,101 @@ + are not allowed + can not be + constant + does not + expression + identifier + file + here + Integer + File +Illegal + or +Undefined + match + real +String +Textfile + out of range + variable + overflow + expected + type +Invalid + pointer +01';' +02':' +03',' +04'(' +05')' +06'=' +07':=' +08'[' +09']' +10'.' +11'..' +12BEGIN +13DO +14END +15OF +17THEN +18TO DOWNTO +20Boolean +21  +22  +23  +24  +25  +26  +27  +28Pointer +29Record +30Simple +31Simple +32 +33 +34 +35 +36Type +37Untyped +40 label +41Unknown syntax error +42 in preceding definitions +43Duplicate label +44Type mismatch +45 +46 and CASE selector +47Operand(s) operator +48 result +49  length +50 length +51 subrange base +52Lower bound > upper bound +53Reserved word +54 assignment +55 exceeds line +56Error in integer +57Error in +58 character in +60s +61 s ands +62Structureds +63s +64s and untypeds +65Untypeds +66I/O +67 s must be parameters +68 componentss +69dering of fields +70Set base +71 GOTO +72Label not within current block +73 FORWARD procedure(s) +74INLINE error +75 use of ABSOLUTE +90 not found +91Unexpected end of source +97Too many nested WITH's +98Memory +99Compilerd WITH's +98Memory +99Compiler \ No newline at end of file diff --git a/disks/images/p/turbo.ovr b/disks/images/p/turbo.ovr new file mode 100644 index 0000000..bd9292e Binary files /dev/null and b/disks/images/p/turbo.ovr differ diff --git a/sources/bios/boot.asm b/sources/bios/boot.asm index 8ab6d76..cb310c5 100644 --- a/sources/bios/boot.asm +++ b/sources/bios/boot.asm @@ -49,11 +49,9 @@ int_handler: message: db "CP/M version 2.2", 13, 10 - db "1979 (c) Digital Research", 13, 10 - db "With patches", 13,10 - db "2023 (c) Aleksandr Sharikhin", 13, 10, 13, 10 + db "1979 (c) Digital Research", 13, 10, 13, 10 db "Agon Quark BIOS", 13, 10 - db "2023 (c) Aleksandr Sharikhin", 13, 10 + db "2023 (c) Aleksandr Sharikhin", 13, 10, 13, 10 db "BIOS built: ", __DATE__, ' ' , __TIME__ db 13, 10, 13, 10 db 0