5748366 [rkeene@sledge /home/rkeene/devel/archive/quickbasic]$ cat -n 4q.bas
   1: DECLARE SUB arch (dd$)
   2: DECLARE SUB Hlppr ()
   3: DECLARE SUB connect ()
   4: DECLARE SUB MakFnt (f$)
   5: DECLARE SUB SCRNSVR ()
   6: DECLARE SUB GetFnt (a!, bg!, os!, f$)
   7: DECLARE SUB DCHK ()
   8: DECLARE FUNCTION FORO$ ()
   9: DECLARE SUB ListFls ()
  10: DECLARE SUB RestFat ()
  11: DECLARE SUB ExeC (oof$)
  12: DECLARE SUB UnloadFont ()
  13: DECLARE SUB LoadFont (f$)
  14: DECLARE SUB print2 (t$, cv!)
  15: DECLARE SUB Font (t$, cl!)
  16: DECLARE SUB Errorr (Msg$)
  17: DECLARE FUNCTION ReadLn$ (ln!)
  18: DECLARE SUB Comport (port$)
  19: DECLARE SUB ClrBot ()
  20: DECLARE SUB Corr (n$)
  21: DECLARE SUB ReadKey (prm$, t$, chrs!, brd$, rd!)
  22: DECLARE FUNCTION GetPrmt$ (pt$)
  23: DIM SHARED ENV(1 TO 500) AS STRING
  24: DIM SHARED ENV1(1 TO 500) AS STRING
  25: DIM SHARED mxenv AS INTEGER
  26: DIM SHARED wt$
  27: DIM SHARED LastTyped AS STRING
  28: DIM SHARED LstLn AS INTEGER
  29: DIM SHARED HRes AS INTEGER
  30: DIM SHARED txt(255) AS STRING
  31: DIM SHARED CPort$
  32: DIM SHARED CMM
  33: DIM SHARED DFnt
  34: DIM SHARED CMmPrt
  35: DIM SHARED tmrr
  36: DIM SHARED Egaa
  37: 
  38: tmrr = 30
  39: LoadFont "C:\ASCIN.FNT"
  40: 'IF UCASE$(LTRIM$(RTRIM$(COMMAND$))) <> "EGA" THEN SCREEN 12: HRes = 1: DFnt = 1: Lstln = 30 ELSE Egaa = 1
  41: 'IF UCASE$(LTRIM$(RTRIM$(COMMAND$))) = "EGA" THEN SCREEN 9: HRes = 1: DFnt = 1: Lstln = 25: Egaa = 1
  42: 'IF UCASE$(LTRIM$(RTRIM$(COMMAND$))) = "TEXT" THEN SCREEN 0: HRes = 0: DFnt = 0: Lstln = 25
  43: HRes = 1: SCREEN 12: LstLn = 30: DFnt = 1
  44: ver$ = "1.00"
  45: PRINT
  46: print2 "  RK-DOS Version " + ver$, 15
  47: PRINT
  48: ENV(1) = "$ $L$P$G"
  49: ENV1(1) = "PATH"
  50: mxenv = 1
  51: nn = 0
  52: 'OPEN "C:\YOUNICKS.FAT" FOR INPUT AS #4
  53: wt$ = curdir$
  54: 10 ReadKey GetPrmt(ENV(1)), cmd$, 70, Msg$, nn
  55: wt$ = curdir$
  56: cmd$ = LTRIM$(cmd$)
  57: IF cmd$ = "" GOTO 10
  58: IF MID$(cmd$, 1, INSTR(cmd$, " ")) = "" THEN ff$ = cmd$: cmdlne$ = "" ELSE ff$ = MID$(cmd$, 1, INSTR(cmd$, " ") - 1): cmdlne$ = MID$(cmd$, INSTR(cmd$, " ") + 1, LEN(cmd$) - INSTR(cmd$, " "))
  59: IF UCASE$(ff$) = "EXIT" THEN UnloadFont: END
  60: IF UCASE$(ff$) = "FREE" THEN print2 "Memmory left:" + STR$(FRE(-1)) + " bytes", 15: PRINT : GOTO 10
  61: IF UCASE$(ff$) = "SEND" THEN IF cmdlne$ = "" THEN print2 "Syntax: SEND msg", 7: PRINT : GOTO 10 ELSE IF CMM = 1 THEN PRINT #3, cmdlne$: GOTO 10 ELSE print2 "Com port not open", 7: PRINT "": GOTO 10
  62: IF UCASE$(ff$) = "CLS" OR UCASE$(ff$) = "CLEAR" THEN CLS : GOTO 10
  63: IF UCASE$(ff$) = "PROMPT" THEN IF cmdlne$ = "" THEN print2 ENV(1), 7: PRINT : GOTO 10 ELSE ENV(1) = cmdlne$: GOTO 10
  64: IF UCASE$(ff$) = "NOWAIT" THEN nn = 0: GOTO 10
  65: IF UCASE$(ff$) = "WAIT" THEN IF cmdlne$ = "" THEN print2 "WAIT message is" + Msg$, 7: PRINT : GOTO 10 ELSE nn = 1: Corr cmdlne$: Msg$ = cmdlne$: GOTO 10
  66: IF UCASE$(ff$) = "DOS" THEN IF cmdlne$ = "" THEN print2 "Syntax: DOS dos_prog", 7: PRINT : GOTO 10 ELSE ClrBot: SHELL (cmdlne$): wt$ = curdir$: GOTO 10
  67: IF UCASE$(ff$) = "COM_ON" THEN IF cmdlne$ = "" THEN print2 "Syntax: COM_ON comport#: speed", 7: PRINT : GOTO 10 ELSE Comport cmdlne$: CMM = 1: GOTO 10
  68: IF UCASE$(ff$) = "LINES" THEN IF cmdlne$ <> "" AND (VAL(cmdlne$) = 25 OR VAL(cmdlne$) = 43 OR VAL(cmdlne$) = 50) THEN SCREEN 0: WIDTH 80, VAL(cmdlne$): LstLn = VAL(cmdlne$): HRes = 0: GOTO 10 ELSE print2 "Syntax: LINES {25,43,50}", 7: PRINT : GOTO 10
  69: IF UCASE$(ff$) = "LOWRES" THEN LstLn = 25: SCREEN 0: WIDTH 80, 25: HRes = 0: GOTO 10
  70: IF UCASE$(ff$) = "HIRES" AND HRes = 0 THEN LstLn = 30: SCREEN 12: HRes = 1: GOTO 10
  71: IF UCASE$(ff$) = "VER" AND HRes = 1 THEN print2 "RK-DOS Version " + ver$, 15: PRINT : PRINT : GOTO 10
  72: IF UCASE$(ff$) = "VER" AND HRes = 0 THEN COLOR 15, 1: PRINT "RK-DOS Version " + ver$: PRINT : COLOR 7, 0: GOTO 10
  73: IF UCASE$(ff$) = "FONT" THEN IF cmdlne$ <> "" AND (RTRIM$(LTRIM$(cmdlne$)) = "ON" OR RTRIM$(LTRIM$(cmdlne$)) = "OFF") THEN ExeC RTRIM$(LTRIM$(cmdlne$)): GOTO 10 ELSE print2 "FONT is " + FORO$, 7: PRINT : GOTO 10
  74: IF UCASE$(ff$) = "LOADFONT" THEN IF cmdlne$ = "" THEN print2 "Syntax: LOADFONT fontname", 7: PRINT : GOTO 10 ELSE UnloadFont: LoadFont cmdlne$: GOTO 10
  75: IF UCASE$(ff$) = "UNLOADFONT" THEN UnloadFont: GOTO 10
  76: IF UCASE$(ff$) = "MOVE" THEN IF cmdlne$ = "" THEN print2 "X=" + STR$(CSRLIN - 1) + "  Y=" + STR$(POS(0)), 7: PRINT : GOTO 10 ELSE LOCATE VAL(MID$(cmdlne$, 1, INSTR(cmdlne$, " ") - 1)), VAL(MID$(cmdlne$, INSTR(cmdlne$, " ") + 1, LEN(cmdlne$) - INSTR(cmdlne$, " "))): GOTO 10
  77: IF UCASE$(ff$) = "TERM" THEN GOSUB CMPRT: GOTO 10
  78: IF UCASE$(ff$) = "COM_OFF" THEN IF CMM = 0 THEN print2 "Com port not open", 7: PRINT : GOTO 10 ELSE CLOSE #3: CMM = 0: COM(CMmPrt) OFF: GOTO 10
  79: IF UCASE$(ff$) = "TIMER" THEN IF cmdlne$ = "" THEN print2 "TIMER =" + STR$(tmrr), 7: PRINT : GOTO 10 ELSE tmrr = VAL(cmdlne$): GOTO 10
  80: IF UCASE$(ff$) = "DIR" THEN ListFls: GOTO 10          's$ = "dir " + cmdlne$: SHELL s$: s$ = "": GOTO 10
  81: IF UCASE$(MID$(ff$, 1, 3)) = "!AT" THEN IF CMM = 0 THEN print2 "Com port not open", 7: PRINT  ELSE PRINT #3, MID$(ff$, 2, LEN(ff$) - 1) + " " + cmdlne$: GOTO 10
  82: IF UCASE$(ff$) = "AR" THEN arch cmdlne$: GOTO 10
  83: IF UCASE$(ff$) = "//?" THEN Hlppr: GOTO 10
  84: print2 "Unkown command:" + ff$, 7
  85: PRINT
  86: GOTO 10
  87: 
  88: CMPRT:
  89: IF CMM = 0 THEN print2 "Com port not open", 7: PRINT : GOTO 121
  90: COM(CMmPrt) OFF
  91: connect
  92: FOR q = 1 TO 39
  93: print2 CHR$(219), 8
  94: print2 CHR$(219), 15
  95: NEXT q
  96: PRINT
  97: 121 RETURN
  98: 
  99: SUB arch (dd$)
 100: DIM b AS STRING * 1
 101: IF INSTR(dd$, "-") = 0 OR dd$ = "" OR INSTR(dd$, "A:") = 0 THEN print2 "Syntax: AR -{l|a|r} A:archive [F:file] ", 7: PRINT : EXIT SUB ELSE arcc$ = MID$(dd$, INSTR(dd$, "A:") + 2, LEN(dd$) - 2 - INSTR(INSTR(dd$, "A:"), dd$, " "))
 102: IF INSTR(dd$, "F:") = 0 THEN fspc$ = "*.*" ELSE fspc$ = MID$(dd$, INSTR(dd$, "F:") + 2, 12)
 103: 'crf$ = Dir$(fspc$)
 104: IF INSTR(arcc$, ".") = 0 THEN arcc$ = arcc$ + ".A"
 105: print2 "Opening archive " + arcc$, 7: PRINT
 106: OPEN arcc$ FOR RANDOM AS #5
 107: IF MID$(dd$, INSTR(dd$, "-") + 1, 1) = "A" THEN GOTO 12
 108: IF MID$(dd$, INSTR(dd$, "-") + 1, 1) = "L" THEN GOTO 13
 109: IF MID$(dd$, INSTR(dd$, "-") + 1, 1) = "R" THEN GOTO 14
 110: print2 "Invaild switch: " + MID$(dd$, INSTR(dd$, "-"), 2), 7: PRINT : CLOSE 5: EXIT SUB
 111: 12 DO UNTIL crf$ = ""
 112: print2 "Proccessing " + crf$, 7: PRINT
 113: OPEN crf$ FOR BINARY AS #6
 114: ff$ = crf$ + CHR$(175) + LTRIM$(RTRIM$(STR$(LOF(6)))) + CHR$(174)
 115: PUT #6, , ff$
 116: PRINT ff$
 117: FOR q = 1 TO LOF(6)
 118: GET #6, q, b
 119: PUT #5, , b
 120: NEXT q
 121: CLOSE 6
 122: crf$ = Dir$
 123: LOOP
 124: CLOSE 5
 125: EXIT SUB
 126: 13 PRINT "Not availble yet (L)"
 127: CLOSE 5
 128: EXIT SUB
 129: 14 PRINT "Not availble yet (R)"
 130: CLOSE 5
 131: END SUB
 132: 
 133: SUB ClrBot
 134: x% = CSRLIN: y% = POS(0)
 135: LOCATE LstLn, 1, 0
 136: PRINT STRING$(80, 32);
 137: LOCATE x%, y%, 1
 138: END SUB
 139: 
 140: SUB Comport (port$)
 141: CLOSE #3
 142: f$ = "COM" + RTRIM$(LTRIM$(port$))
 143: OPEN f$ FOR RANDOM AS #3
 144: COM(VAL(port$)) ON
 145: ON COM(VAL(port$)) GOSUB CMPRT
 146: CMmPrt = VAL(port$)
 147: CPort$ = port$
 148: END SUB
 149: 
 150: SUB connect
 151: IF CMM = 0 THEN print2 "Com port not open", 7: PRINT : EXIT SUB
 152: print2 "Terminal Emulation", 14: PRINT
 153: DO UNTIL ch$ = CHR$(27)
 154: ch$ = INKEY$
 155: IF ch$ = CHR$(13) THEN ch$ = CHR$(13) + CHR$(10)
 156: IF ch$ <> "" THEN PRINT #3, ch$;
 157: IF LOC(3) <> 0 THEN inchar$ = INPUT$(1, #3) ELSE inchar$ = ""
 158: IF inchar$ = CHR$(8) AND POS(0) > 1 THEN
 159: LOCATE CSRLIN, POS(0) - 1
 160: PRINT " ";
 161: LOCATE CSRLIN, POS(0) - 1
 162: ELSEIF inchar$ = CHR$(8) AND POS(0) = 1 AND CSRLIN > 1 THEN
 163: LOCATE CSRLIN - 1, 79
 164: PRINT " ";
 165: LOCATE , POS(0) - 1
 166: END IF
 167: IF inchar$ = CHR$(8) THEN inchar$ = ""
 168: IF POS(0) = 79 THEN PRINT
 169: IF inchar$ = CHR$(13) THEN LOCATE CSRLIN, 1 ELSE IF inchar$ = CHR$(10) THEN cxx% = POS(0): PRINT : LOCATE CSRLIN, cxx%: cxx% = 0 ELSE print2 inchar$, 14
 170: 'IF inchar$ = CHR$(168) THEN END
 171: LOOP
 172: PRINT #3, "+++"
 173: PRINT #3, "ATH"
 174: PRINT #3, "ATS0=0"
 175: PRINT
 176: print2 "Flushing com port buffer", 8: PRINT
 177: CLOSE #3
 178: CMM = 0
 179: CMM = 1
 180: 'delay 1
 181: Comport CPort$
 182: END SUB
 183: 
 184: SUB Corr (n$)
 185: lnn$ = UCASE$(MID$(n$, 1, 1))
 186: FOR q = 2 TO LEN(n$)
 187: IF MID$(n$, q, 1) = " " OR MID$(n$, q, 1) = CHR$(255) THEN lnn$ = lnn$ + " ": GOTO 122
 188: IF MID$(n$, q, 1) <> "&" AND cptl = 0 THEN lnn$ = lnn$ + LCASE$(MID$(n$, q, 1))
 189: IF cptl = 1 THEN lnn$ = lnn$ + UCASE$(MID$(n$, q, 1)): cptl = 0
 190: IF MID$(n$, q, 1) = "." OR MID$(n$, q, 1) = "&" THEN cptl = 1
 191: 122 NEXT q
 192: n$ = lnn$
 193: 
 194: END SUB
 195: 
 196: SUB DCHK
 197: 'IF CSRLIN = LstLn - 1 OR CSRLIN = LstLn THEN LOCATE LstLn, 1: PRINT : LOCATE LstLn - 1, 1
 198: END SUB
 199: 
 200: SUB Errorr (Msg$)
 201: print2 Msg$, 14
 202: END SUB
 203: 
 204: SUB ExeC (oof$)
 205: IF oof$ = "ON" THEN DFnt = 1
 206: IF oof$ = "OFF" THEN DFnt = 0
 207: END SUB
 208: 
 209: SUB Font (t$, cl)
 210: IF cl = -1 THEN  ELSE f$ = "C" + LTRIM$(RTRIM$(STR$(cl))): DRAW "X" + VARPTR$(f$)
 211: IF txt(32) = "" THEN LOCATE 1, 1: PRINT "System Error. Unable to continue.": END
 212: FOR qww = 1 TO LEN(t$)
 213: IF ASC(MID$(t$, qww, 1)) = 0 THEN DRAW "X" + VARPTR$(txt(32)) ELSE DRAW "X" + VARPTR$(txt(ASC(MID$(t$, qww, 1)))): DRAW "BL": GOTO 1011
 214: 1011 NEXT qww
 215: END SUB
 216: 
 217: FUNCTION FORO$
 218: IF DFnt = 1 THEN FORO$ = "on"
 219: IF DFnt = 0 THEN FORO$ = "off"
 220: END FUNCTION
 221: 
 222: SUB GetFnt (a, bg, os, f$)
 223: 'LINE (d * 8, m)-((d + 1) * 8, 15 + m), 1, B
 224: D = a - os: u = 15: r = 0
 225: FOR x = (D) * 8 TO (1 + D) * 8
 226: FOR y = 0 + m TO 15 + m
 227: u = u - 1
 228: IF POINT(x, y) = bg THEN  ELSE GOTO 310
 229: uh$ = LTRIM$(RTRIM$(STR$(u)))
 230: ur$ = LTRIM$(RTRIM$(STR$(u - 1)))
 231: lt$ = lt$ + "BU" + uh$ + "DBD" + ur$
 232: PSET (x, y), 14
 233: 310 NEXT y
 234: r = r + 1: u = 15
 235: lt$ = lt$ + "br"
 236: NEXT x
 237: f$ = lt$
 238: END SUB
 239: 
 240: FUNCTION GetPrmt$ (pt$)
 241: FOR q = 1 TO LEN(pt$)
 242: IF MID$(pt$, q, 1) = "$" AND UCASE$(MID$(pt$, q + 1, 1)) = "P" THEN q = q + 1: mm$ = mm$ + wt$: GOTO nextl
 243: IF MID$(pt$, q, 1) = "$" AND UCASE$(MID$(pt$, q + 1, 1)) = "G" THEN q = q + 1: mm$ = mm$ + ">": GOTO nextl
 244: IF MID$(pt$, q, 1) = "$" AND UCASE$(MID$(pt$, q + 1, 1)) = "_" THEN q = q + 1: mm$ = mm$ + CHR$(10) + CHR$(13): GOTO nextl
 245: IF MID$(pt$, q, 1) = "$" AND UCASE$(MID$(pt$, q + 1, 1)) = "T" THEN q = q + 1: mm$ = mm$ + TIME$: GOTO nextl
 246: IF MID$(pt$, q, 1) = "$" AND UCASE$(MID$(pt$, q + 1, 1)) = "D" THEN q = q + 1: mm$ = mm$ + DATE$: GOTO nextl
 247: IF MID$(pt$, q, 1) = "$" AND UCASE$(MID$(pt$, q + 1, 1)) = "L" THEN q = q + 1: mm$ = mm$ + "<": GOTO nextl
 248: mm$ = mm$ + MID$(pt$, q, 1)
 249: nextl:
 250: NEXT q
 251: GetPrmt$ = mm$
 252: END FUNCTION
 253: 
 254: SUB Hlppr
 255: print2 "-- COMMANDS --", 15: PRINT
 256: DCHK
 257: print2 "EXIT       -  Quits RK-DOS", 1: PRINT
 258: DCHK
 259: print2 "FREE       -  Displays the amount of free low memmory", 2: PRINT
 260: DCHK
 261: print2 "SEND       -  Sends text to an open com port", 3: PRINT
 262: DCHK
 263: print2 "CLS        -  Clears the screen", 4: PRINT
 264: DCHK
 265: print2 "NOWAIT     -  Turns off the reminder", 5: PRINT
 266: DCHK
 267: print2 "WAIT       -  Turns on the reminder", 6: PRINT
 268: DCHK
 269: print2 "PROMPT     -  Changes the prompt", 7: PRINT
 270: DCHK
 271: print2 "DOS        -  Runs a dos program", 8: PRINT
 272: DCHK
 273: print2 "LINES      -  Changes the number of lines on the screen", 9: PRINT
 274: DCHK
 275: print2 "COM_ON     -  Opens a com port", 10: PRINT
 276: DCHK
 277: print2 "LOWRES     -  Changes to text mode", 11: PRINT
 278: DCHK
 279: print2 "HIRES      -  Changes to VGA graphics mode", 12: PRINT
 280: DCHK
 281: print2 "VER        -  Displays the RK-DOS version", 13: PRINT
 282: DCHK
 283: print2 "FONT       -  Turns the Font on or off", 14: PRINT
 284: DCHK
 285: print2 "LOADFONT   -  Loads a font", 15: PRINT
 286: DCHK
 287: print2 "UNLOADFONT -  Unloads the font from memmory", 14: PRINT
 288: DCHK
 289: print2 "MOVE       -  Moves to a line and position on the screen", 13: PRINT
 290: DCHK
 291: print2 "TERM       -  Activates the terminal emulation", 12: PRINT
 292: DCHK
 293: print2 "COM_OFF    -  Closes the open com port", 11: PRINT
 294: DCHK
 295: print2 "TIMER      -  Sets the timer for the WAIT statement", 10: PRINT
 296: DCHK
 297: END SUB
 298: 
 299: SUB ListFls
 300: 'lbl$ = Dir$("*.*", 8)
 301: PRINT " Label in drive C is " + lbl$
 302: DO UNTIL EOF(4)
 303: LINE INPUT #4, ffm$
 304: FOR q = 12 TO 18
 305: IF MID$(ffm$, q, 1) = CHR$(219) THEN MID$(ffm$, q, 1) = CHR$(0)
 306: NEXT q
 307: f$ = MID$(ffm$, 1, 8)
 308: ext$ = MID$(ffm$, 9, 3)
 309: hh$ = RTRIM$(LTRIM$(STR$(ASC(MID$(ffm$, 12, 1)))))
 310: mm$ = RTRIM$(LTRIM$(STR$(ASC(MID$(ffm$, 13, 1)))))
 311: dd$ = RTRIM$(LTRIM$(STR$(ASC(MID$(ffm$, 14, 1)))))
 312: mn$ = RTRIM$(LTRIM$(STR$(ASC(MID$(ffm$, 15, 1)))))
 313: yy$ = RTRIM$(LTRIM$(STR$(ASC(MID$(ffm$, 16, 1)))))
 314: IF LEN(hh$) = 1 THEN hh$ = "0" + hh$
 315: IF LEN(mm$) = 1 THEN mm$ = "0" + mm$
 316: IF LEN(dd$) = 1 THEN dd$ = "0" + dd$
 317: IF LEN(mn$) = 1 THEN mn$ = "0" + mn$
 318: IF LEN(yy$) = 1 THEN yy$ = "0" + yy$
 319: 
 320: print2 f$ + " " + ext$ + " " + hh$ + ":" + mm$ + " " + dd$ + "/" + mn$ + "/" + yy$ + dr$, 7: PRINT
 321: LOOP
 322: RestFat
 323: PRINT
 324: END SUB
 325: 
 326: SUB LoadFont (f$)
 327: OPEN f$ FOR RANDOM AS #1
 328: IF LOF(1) = 0 THEN CLOSE 1: MakFnt f$ ELSE CLOSE 1
 329: IF Egaa = 1 THEN SCREEN 9 ELSE SCREEN 12
 330: OPEN f$ FOR INPUT AS #1: t = 0
 331: DO UNTIL EOF(1) OR t = 123
 332: LINE INPUT #1, a$
 333: txt(t) = a$
 334: t = t + 1
 335: LOOP
 336: CLOSE 1
 337: END SUB
 338: 
 339: SUB MakFnt (f$)
 340: SCREEN 9: CLS
 341: OPEN f$ FOR OUTPUT AS #1
 342: FOR c = 0 TO 31: PRINT #1, "": NEXT c
 343: FOR q = 32 TO 170
 344: IF q = 0 THEN D = 32 ELSE D = q
 345: LOCATE 1, 1: PRINT CHR$(D);
 346: GetFnt 33, 15, 33, lt$
 347: CLS
 348: tt = LEN(lt$) + tt
 349: IF tt > 25000 THEN CLOSE 1: EXIT SUB
 350: PRINT #1, lt$
 351: DRAW "X" + VARPTR$(lt$)
 352: NEXT q
 353: CLOSE 1
 354: END SUB
 355: 
 356: SUB print2 (t$, cv)
 357: IF HRes = 1 AND DFnt = 1 THEN  ELSE GOTO 2111
 358: x = -2: y = -2
 359: IF x = -2 THEN x = (POS(0) * 8) - 7: g = -2
 360: IF y = -2 THEN y = CSRLIN * 16: n = -2
 361: D$ = "BM" + LTRIM$(RTRIM$(STR$(x))) + "," + LTRIM$(RTRIM$(STR$(y))) + " C" + LTRIM$(RTRIM$(STR$(cv)))
 362: 3 DRAW "X" + VARPTR$(D$)
 363: Font t$, cv
 364: IF LEN(t$) >= 80 THEN EXIT SUB
 365: LOCATE CSRLIN, POS(0) + LEN(t$)
 366: IF CSRLIN = LstLn THEN ClrBot: PRINT : LOCATE LstLn - 1, 1
 367: IF POS(0) = 80 THEN PRINT
 368: EXIT SUB
 369: 2111 COLOR cv
 370: PRINT t$;
 371: END SUB
 372: 
 373: SUB ReadKey (prm$, t$, chrs, brd$, rd)
 374: brd$ = LTRIM$(RTRIM$(brd$))
 375: IF CSRLIN = LstLn THEN ClrBot: PRINT : LOCATE LstLn - 1, 1
 376: t$ = ""
 377: print2 prm$, 7
 378: DO UNTIL i$ = CHR$(13) OR i$ = CHR$(27)
 379: IF q = tmrr AND MID$(brd$, 1, 2) = "$$" THEN t$ = MID$(brd$, 3, LEN(brd$) - 2): print2 t$, 7: PRINT : ClrBot: EXIT SUB
 380: IF q = tmrr AND MID$(brd$, 1, 2) <> "$$" THEN IF POS(0) > 1 THEN PRINT : print2 "Computer>" + brd$, 7: PRINT : q = 0: print2 prm$ + t$, 7:  ELSE PRINT "IS2000>"; TAB(10); brd$: : q = 0: print2 prm$ + t$, 7
 381: IF i$ = CHR$(8) THEN IF LEN(t$) = 0 THEN i$ = "": GOTO 60 ELSE t$ = MID$(t$, 1, LEN(t$) - 1): LOCATE CSRLIN, POS(0) - 1: PRINT " "; : LOCATE CSRLIN, POS(0) - 1
 382: i$ = UCASE$(INKEY$)
 383: x% = CSRLIN: y% = POS(0)
 384: IF TIME$ <> oldtm$ AND HRes = 0 THEN COLOR 15, 1: LOCATE LstLn, 1, 0: PRINT TIME$; STRING$(80 - LEN(TIME$), 32); : COLOR 7, 0: LOCATE x%, y%, 1: oldtm$ = TIME$: IF q < tmrr AND rd = 1 THEN q = q + 1
 385: IF TIME$ <> oldtm$ AND HRes = 1 THEN COLOR 15: LOCATE LstLn, 1, 0: PRINT TIME$ + STRING$(80 - LEN(TIME$), 32); : COLOR 7: LOCATE x%, y%, 1: oldtm$ = TIME$: IF q < tmrr AND rd = 1 THEN q = q + 1
 386: 
 387: IF i$ = "" THEN GOTO 60
 388: IF i$ = CHR$(0) + "=" THEN GOSUB 1009
 389: IF i$ = CHR$(0) + ";" THEN SCRNSVR: CLS : print2 prm$ + t$, 7
 390: oldtm$ = TIME$
 391: q = 0
 392: IF (ASC(i$) > -1 AND ASC(i$) < 32) THEN GOTO 60
 393: IF i$ = CHR$(13) OR i$ = CHR$(27) THEN GOTO 70
 394: IF HRes = 1 THEN print2 UCASE$(i$), 7
 395: IF HRes = 0 THEN PRINT UCASE$(i$);
 396: t$ = t$ + i$
 397: IF LEN(t$) >= chrs THEN t$ = MID$(t$, 1, LEN(t$) - 1): LOCATE CSRLIN, POS(0) - 1: PRINT " "; : LOCATE CSRLIN, POS(0) - 1
 398: 60 LOOP
 399: 70 print2 "", 7
 400: LastTyped = t$
 401: IF CSRLIN = LstLn - 1 OR CSRLIN = LstLn THEN ClrBot: LOCATE LstLn, 1: PRINT : LOCATE LstLn - 1, 1 ELSE PRINT
 402: EXIT SUB
 403: 
 404: 1009 t$ = t$ + MID$(LastTyped, 1, chrs - LEN(t$) - 1)
 405: LOCATE CSRLIN, LEN(prm$) + 1, 1: print2 t$, 7
 406: RETURN
 407: END SUB
 408: 
 409: FUNCTION ReadLn$ (ln)
 410: FOR q = 1 TO 80
 411: mm$ = mm$ + CHR$(SCREEN(ln, q)) + CHR$(SCREEN(ln, q, 1))
 412: NEXT q
 413: ReadLn$ = mm$
 414: END FUNCTION
 415: 
 416: SUB RestFat
 417: CLOSE 4
 418: OPEN "C:\YOUNICKS.FAT" FOR INPUT AS #4
 419: END SUB
 420: 
 421: SUB SCRNSVR
 422: IF HRes = 1 THEN  ELSE GOTO 102
 423: CLS
 424: ROT = 240 - 45
 425: IF RTRIM$(LTRIM$(LCASE$(COMMAND$))) = "ega" THEN SCREEN 9: mma = 25: HT = 100 ELSE SCREEN 12: mma = 30: HT = 200
 426: SZ = 200
 427: 'HT = 200
 428: WZ = 0
 429: DO UNTIL INKEY$ = CHR$(13)
 430: QW = RND * 43 + 1
 431: QW = WZ * 5
 432: FOR AD = 0 TO 16
 433: LINE (320 - SZ + QW, ROT + HT + AD)-(320 + SZ - QW, 240 + HT + AD), 2
 434: NEXT AD
 435: IF WZ < 39 AND D = 0 THEN WZ = WZ + 1 ELSE D = 1
 436: IF WZ > 0 AND D = 1 THEN WZ = WZ - 1 ELSE D = 0
 437: LOCATE mma, 1: PRINT ""
 438: LOOP
 439: EXIT SUB
 440: 102 CLS
 441: a$ = CHR$(176) + CHR$(177) + CHR$(178) + CHR$(219) + CHR$(219) + CHR$(178) + CHR$(177) + CHR$(176)
 442: b$ = CHR$(219) + CHR$(178) + CHR$(177) + CHR$(176) + CHR$(176) + CHR$(177) + CHR$(178) + CHR$(219)
 443: FOR q = 1 TO 10
 444: f$ = f$ + a$
 445: g$ = g$ + b$
 446: NEXT q
 447: COLOR 15, 1
 448: LOCATE , , 0
 449: DO UNTIL INKEY$ = CHR$(13)
 450: PRINT f$;
 451: 'delay .1
 452: PRINT g$;
 453: 'delay .1
 454: LOOP
 455: COLOR 7, 0
 456: LOCATE , , 1
 457: END SUB
 458: 
 459: SUB UnloadFont
 460: FOR q = 0 TO 255
 461: txt(q) = ""
 462: NEXT q
 463: END SUB
 464: 
 465: SUB WriteFat (f$, ext$)
 466: hh = VAL(MID$(TIME$, 1, 2))
 467: mm = VAL(MID$(TIME$, 4, 2))
 468: dd = VAL(MID$(DATE$, 4, 2))
 469: mn = VAL(MID$(DATE$, 1, 2))
 470: yy = VAL(MID$(DATE$, 9, 2))
 471: f$ = f$ + STRING$(8, 32): f$ = MID$(f$, 1, 8)
 472: ext$ = ext$ + "   ": ext$ = MID$(ext$, 1, 3)
 473: tt$ = f$ + ext$ + CHR$(hh) + CHR$(mm) + CHR$(dd) + CHR$(mn) + CHR$(yy)
 474: CLOSE 4
 475: OPEN "C:\YOUNICKS.FAT" FOR INPUT AS #4
 476: DO UNTIL EOF(4)
 477: LINE INPUT #4, ff$
 478: IF UCASE$(ff$) = UCASE$(tt$) THEN exst = 1: CLOSE 4: GOTO 111
 479: LOOP
 480: CLOSE 4
 481: OPEN "C:\YOUNICKS.FAT" FOR APPEND AS #4
 482: PRINT #4, tt$
 483: CLOSE 4
 484: 111 OPEN "C:\YOUNICKS.FAT" FOR INPUT AS #4
 485: END SUB
 486: 
 487: SUB WriteLn (Msg$, ln, bg)
 488: x% = CSRLIN: y% = POS(0)
 489: IF ln = 0 OR ln > 25 THEN EXIT SUB
 490: LOCATE ln, 1, 0
 491: FOR q = 1 TO LEN(Msg$) STEP 2
 492: COLOR ASC(MID$(Msg$, q + 1, 1)), bg
 493: PRINT MID$(Msg$, q, 1);
 494: NEXT q
 495: LOCATE x%, y%, 1
 496: END SUB
 497: 
5748367 [rkeene@sledge /home/rkeene/devel/archive/quickbasic]$

Click here to go back to the directory listing.
Click here to download this file.
last modified: 2000-05-09 20:59:15