Menulis Program Saat Teduh

BY IN QBasic Comments Off on Menulis Program Saat Teduh

Sekali lagi program jadul, program ini saya tulis saat masih kuliah, pada intinya adalah program text editor. Semasa Windows masih belum seperti sekarang, program ini pernah saya pakai sampai 1 tahun dan cukup lumayan dengan adanya proses enkripsi teksnya. Perintah2nya juga sederhana yaitu tombol F1 sd F6. Mudah2an bisa dijadikan bahan pelajaran untuk belajar algoritma dan pemrograman.

‘**********************************************************’

‘ Program SAAT TEDUH
‘ Created & Modify by Yulius Candra Wahyu Kurniawan
‘ Copyright (C) 1997
‘ PRAISE THE LORD ANYTIME AND ANYWHERE

‘**********************************************************’

DECLARE SUB Box (Row!, Col!, Fore!, back!, Rowl!, Coll!)
DECLARE SUB ErrorBox ()
DECLARE SUB Center (Row!, Fore!, back!, Text$)
DECLARE SUB ClrEol (Row!)

CLEAR
SCREEN 0
WIDTH 80
DEFINT A-Z
OPTION BASE 1
ON ERROR GOTO error.trap
ON KEY(1) GOSUB dos
ON KEY(2) GOSUB new
ON KEY(3) GOSUB quit
ON KEY(4) GOSUB saving
ON KEY(5) GOSUB load
ON KEY(6) GOSUB printing
DEF fnr = 20 * page + rows – 1
DEF fnc (x$) = x$ < "0" OR (x$ > “9” AND x$ < "A") OR (x$ > “Z” AND x$ < "a") OR x$ > “z”
DIM array$(60), temp$(60), mark(60)
tab$ = SPACE$(80)
MID$(tab$, 8, 1) = “T”
MID$(tab$, 50, 1) = “T”
top = 0
mid = 1
bot = 2
lst = 3
flket$ = “UNKNOWN.STD”
pgnum = 1
GOSUB box.1st
init.screen:
FOR page = top TO bot
SCREEN 0, 0, page, 0
CLS
COLOR 9, 0
LOCATE 1, 71
PRINT “SAAT TEDUH”;
COLOR 3, 0
LOCATE 1, 1, 1, 7, 7
PRINT STRING$(70, 196);
LOCATE 22, 1, 1, 7, 7
PRINT STRING$(80, 196);
IF page = top THEN pgnum = 1
IF page = mid THEN pgnum = 2
IF page = bot THEN pgnum = 3
COLOR 10, 0
LOCATE 23, 72
PRINT “Page: “; pgnum;
NEXT
COLOR 15, 0
FOR i = 1 TO 60
array$(i) = SPACE$(80)
NEXT
init.page:
page = top
SCREEN 0, 0, page, page
init.row.col:
rows = 2
cols = 1
COLOR 10, 0
LOCATE 23, 1
PRINT flket$;
COLOR 15, 0

main.looping:
COLOR 15, 0
FOR i = 1 TO 6
KEY(i) ON
NEXT
WHILE pflag
LOCATE rows, 1
PRINT array$(fnr);
cols = INSTR(array$(fnr), ” “)
pflag = 0
WEND

IF insert = 0 THEN LOCATE rows, cols + (cols > 80), 1, 7, 7
IF insert = 1 THEN LOCATE rows, cols + (cols > 80), 1, 4, 6

sc.again:
k$ = INKEY$
IF k$ = “” THEN GOTO sc.again
k = ASC(k$)
IF k = 0 THEN GOTO alt.key
IF k <> 3 THEN GOTO back.arrow ‘(Ctrl-Break)
CLS
END

back.arrow: ‘(Back Arrow or Backspace)
IF k <> 8 THEN GOTO tab.key
IF cols = 1 THEN GOTO main.looping
cols = cols – 1
GOTO del.word

tab.key: ‘(Tabulation key)
IF k <> 9 THEN GOTO enter.key
insert = 0
check.col:
cols = cols – (cols < 80) LOCATE rows, cols, 1, 7, 7 IF cols = 80 THEN GOTO main.looping IF MID$(tab$, cols, 1) = " " THEN GOTO check.col GOTO main.looping enter.key: '(Function of Return Carriage) IF k <> 13 THEN GOTO character
insert = 0
cols = 1
check.row:
rows = rows + 1
IF rows > 21 THEN
k$ = CHR$(0) + CHR$(81)
GOTO alt.key
END IF
GOTO main.looping

character: ‘(Write a Character)
IF k < 32 OR k > 126 THEN GOTO Click
IF insert = 0 THEN GOTO check.col1
array$(fnr) = LEFT$(array$(fnr), cols – 1) + k$ + MID$(array$(fnr), cols, 80 – cols)
LOCATE rows, 1, 0
PRINT array$(fnr);
GOTO add.col

check.col1:
IF cols < 81 THEN GOTO print.str IF fnr = 60 THEN GOTO check.col2 spp = 1 array$(fnr) = LEFT$(array$(fnr), 80) WHILE INSTR(spp, array$(fnr), " ") spp = INSTR(spp, array$(fnr), " ") + 1 WEND array$(fnr + 1) = MID$(array$(fnr), spp) + k$ + " " + LEFT$(array$(fnr + 1), spp - 3) array$(fnr) = LEFT$(array$(fnr), spp - 1) + SPACE$(81 - spp) LOCATE rows, 1, 0 PRINT array$(fnr); pflag = 1 GOTO check.row print.str: PRINT k$; MID$(array$(fnr), cols, 1) = k$ add.col: cols = cols + 1 IF cols = 72 THEN SOUND 999, 1 check.col2: IF cols = 80 THEN SOUND 777, 3 GOTO main.looping alt.key: k = ASC(RIGHT$(k$, 1)) IF k <> 15 THEN GOTO home
insert = 0
add.col1:
cols = cols + (cols > 1)
LOCATE rows, cols, 1, 7, 7
IF cols = 1 THEN GOTO main.looping
IF MID$(tab$, cols, 1) = ” ” THEN GOTO add.col1
GOTO main.looping

home:
IF k <> 71 THEN GOTO up.arrow
insert = 0
GOTO init.row.col

up.arrow:
IF k <> 72 THEN GOTO pgup
insert = 0
rows = rows – 1
IF rows < 2 THEN rows = 2 GOTO main.looping pgup: IF k <> 73 THEN GOTO left.arrow
insert = 0
IF page = top THEN SOUND 300, 2
IF page = mid THEN page = top
IF page = bot THEN page = mid
SCREEN 0, 0, page, page
GOTO init.row.col

left.arrow:
IF k <> 75 THEN GOTO right.arrow
insert = 0
cols = cols – 1
IF cols < 1 THEN cols = 1 GOTO main.looping right.arrow: IF k <> 77 THEN GOTO end.key
insert = 0
add.col2:
cols = cols + 1
IF cols > 80 THEN cols = 80
GOTO main.looping

end.key:
IF k <> 79 THEN GOTO dn.arrow
insert = 0
cols = 80
check.col3:
IF SCREEN(rows, cols) <> 32 THEN GOTO add.col2
cols = cols – 1
IF cols > 1 THEN GOTO check.col3
GOTO main.looping

dn.arrow:
IF k <> 80 THEN GOTO pgdn
insert = 0
rows = rows + 1
IF rows > 21 THEN rows = 21
GOTO main.looping

pgdn:
IF k <> 81 THEN GOTO insert.key
insert = 0
IF page = bot THEN SOUND 300, 2
IF page = mid THEN page = bot
IF page = top THEN page = mid
SCREEN 0, 0, page, page
GOTO init.row.col

insert.key:
IF k <> 82 THEN GOTO delete.key
insert = 1
GOTO main.looping

delete.key:
IF k <> 83 THEN GOTO Click
insert = 0
del.word:
array$(fnr) = LEFT$(array$(fnr), cols – 1) + MID$(array$(fnr), cols + 1) + ” “
LOCATE rows, 1, 0
PRINT array$(fnr);
GOTO main.looping

Click:
FOR p = 1 TO 6
SOUND INT(p * 1000 / 3), .5
SOUND 5000, .05
NEXT
GOTO sc.again

‘Sub Routine Collections

write.str.array:
tline = 0
FOR apage = top TO bot
SCREEN 0, 0, apage, apage
FOR arow = 2 TO 21
tline = tline + 1
COLOR 15, 0
LOCATE arow, 1, 1, 7, 7
PRINT array$(tline);
NEXT
NEXT
RETURN

box.1st:
CLS
Box 3, 10, 3, 0, 2, 60
Center 4, 14, 0, “Program SAAT TEDUH”
Center 5, 10, 0, “Created by Yulius Candra Wahyu Kurniawan”
Center 6, 10, 0, “PRAISE THE LORD ANYTIME AND ANYWHERE”
Center 19, 15, 0, “Press any key to start”
a$ = INPUT$(1)
RETURN

dos:
PCOPY 0, 2
CLS
PRINT “Type EXIT to Return to Program”
PRINT “Copyright (C) 1997 Yulius Candra Wahyu Kurniawan”
SHELL
PCOPY 2, 0
LOCATE 2, 1
RETURN

new:
LOCATE 24, 1
INPUT ; “Create New File [Y/N] ? “, pil$
IF UCASE$(pil$) = “Y” THEN
flket$ = “UNKNOWN.STD”
GOTO init.screen
ELSE
LOCATE 24, 1
PRINT SPACE$(60);
SCREEN 0, 0, page, page
GOTO main.looping
END IF
RETURN

quit:
LOCATE 24, 1
INPUT ; “Quit Anyway ( Remember to save your file ) [Y/N] ? “, pil$
IF UCASE$(pil$) = “Y” THEN
LOCATE 24, 1
PRINT SPACE$(60);
COLOR 7, 0
CLS
FOR i = 1 TO 7
KEY(i) OFF
NEXT
LOCATE , , 0
END
ELSE
ClrEol (24)
SCREEN 0, 0, page, page
GOTO main.looping
END IF
RETURN

saving:
insert = 0
LOCATE 24, 1
INPUT ; “Enter File name : “, File$
IF File$ = “” THEN GOTO end.proc2
flket$ = UCASE$(File$) + “.STD”
ClrEol (23)
ClrEol (24)
COLOR 14, 0
LOCATE 23, 1
PRINT flket$;
OPEN File$ + “.STD” FOR OUTPUT AS #1
FOR i = 1 TO 60
IF LEFT$(array$(i), 1) = “%” THEN
PRINT #1, array$(i)
EXIT FOR
END IF
PRINT #1, array$(i)
NEXT
CLOSE #1
COLOR 5, 0
LOCATE 24, 1
PRINT “Please wait while saving file… “;
ClrEol (24)
flket$ = “UNKNOWN.STD”
GOTO init.screen
end.proc2:
ClrEol (24)
SCREEN 0, 0, page, page
GOTO main.looping
RETURN

load:
insert = 0
LOCATE 24, 1
INPUT ; “Load File [Y/N] ? “, pil$
IF UCASE$(pil$) = “Y” THEN
GOTO load.file
ELSE
ClrEol (24)
SCREEN 0, 0, page, page
GOTO main.looping
END IF
load.file:
ClrEol (24)
LOCATE 24, 1
INPUT ; “Enter File name : “, File$
IF File$ = “” THEN GOTO end.proc3
flket$ = UCASE$(File$) + “.STD”
ClrEol (23)
ClrEol (24)
COLOR 14, 0
LOCATE 23, 1
PRINT flket$;
COLOR 5, 0
LOCATE 24, 1
PRINT “Please wait while loading file…”;
ClrEol (24)
OPEN File$ + “.STD” FOR INPUT AS #1
FOR i = 1 TO 60
IF NOT EOF(1) THEN LINE INPUT #1, array$(i) ELSE array$(i) = “”
IF LEN(array$(i)) > 80 THEN array$(i) = LEFT$(array$(i), 80)
WHILE LEN(array$(i)) < 80 array$(i) = array$(i) + SPACE$(80 - LEN(array$(i))) WEND NEXT CLOSE #1 GOSUB write.str.array GOTO init.page end.proc3: SCREEN 0, 0, page, page GOTO init.screen RETURN printing: insert = 0 COLOR 5, 0 LOCATE 24, 1 PRINT "Printing..."; FOR i = 1 TO 60 IF LEFT$(array$(i), 1) = "%" THEN EXIT FOR LPRINT LEFT$(array$(i), 80); NEXT LPRINT CHR$(12); ClrEol (24) flket$ = "UNKNOWN.STD" POKE 106, 0 GOTO init.screen RETURN error.trap: PCOPY 0, 1 LOCATE , , 0 SELECT CASE ERR CASE 6 ErrorBox Center 11, 15, 4, "Stack Overflow" CASE 7 ErrorBox Center 11, 15, 4, "Out of Memory" CASE 11 ErrorBox Center 11, 15, 4, "Divide by Zero" CASE 25 ErrorBox Center 11, 15, 4, "Printer NOT Ready" CASE 27 ErrorBox Center 11, 15, 4, "Out of Paper" CASE 53 ErrorBox Center 11, 15, 4, "File NOT Found" CASE 57 ErrorBox Center 11, 15, 4, "Device I/O Failure" CASE 58 ErrorBox Center 11, 15, 4, "File Already Exists" CASE 61 ErrorBox Center 11, 15, 4, "No room free in Disk" CASE 64 ErrorBox Center 11, 15, 4, "Invalid File Name" CASE 67 ErrorBox Center 11, 15, 4, "Too many Files opened" CASE 68 ErrorBox Center 11, 15, 4, "Device Driver NOT Found" CASE 69 ErrorBox Center 11, 15, 4, "Internal Buffer ERROR" CASE 70 ErrorBox Center 11, 15, 4, "Access Denied" CASE 71 ErrorBox Center 11, 15, 4, "Disk Drive NOT Ready" CASE 72 ErrorBox Center 11, 15, 4, "Disk Drive ERROR" CASE 73 ErrorBox Center 11, 15, 4, "Feature unavailable" CASE 74 ErrorBox Center 11, 15, 4, "Rename Across Disk" CASE 75 ErrorBox Center 11, 15, 4, "Path / File Access ERROR" CASE 76 ErrorBox Center 11, 15, 4, "Path NOT Found" CASE ELSE ErrorBox Center 11, 15, 4, "Unknown ERROR has occured" COLOR 7, 0 CLS END END SELECT DO LOOP UNTIL INKEY$ = CHR$(13) PCOPY 1, 0 COLOR 15, 0 LOCATE , , 1 RESUME init.screen DEFSNG A-Z SUB Box (Row, Col, Fore, back, Rowl, Coll) a = 201: b = 205: c = 187: d = 186: e = 32: f = 186: g = 200: h = 205: i = 188 LOCATE Row, Col COLOR Fore, back PRINT CHR$(a); STRING$(Coll, b); CHR$(c); Row = Row + 1 FOR Counter = Row TO Row + Rowl LOCATE Counter, Col PRINT CHR$(d); STRING$(Coll, e); CHR$(f); NEXT LOCATE Row + Rowl + 1, Col PRINT CHR$(g); STRING$(Coll, h); CHR$(i); Col = Col + 2 COLOR 7, 0 FOR Counter = Col TO Col + Coll LOCATE Row + Rowl + 2, Counter PRINT CHR$(SCREEN(Row + Rowl + 2, Counter)); NEXT FOR Counter = Row TO Row + Rowl + 1 LOCATE Counter, Col + Coll PRINT CHR$(SCREEN(Counter, Col + Coll)); NEXT END SUB SUB Center (Row, Fore, back, Text$) Col = INT((80 - LEN(Text$)) / 2) LOCATE Row, Col COLOR Fore, back PRINT Text$; END SUB SUB ClrEol (Row!) LOCATE Row, 1 PRINT SPACE$(60); END SUB SUB ErrorBox BEEP Box 10, 20, 15, 4, 1, 40 Center 10, 14, 4, " ERROR " Center 12, 15, 4, "Press RETURN to Resume" END SUB




Comments are closed.