You are not logged in or registered. Please login or register to use the full functionality of this board...
SIGN IN Join Our Community For FREE


an old fb program i wrote
08-12-2017, 01:43 AM
Post: #1
 (Print Post)
an old fb program i wrote
Code Snippet: [Select]
'[[text2htm]] an old fb program
'probably only works in fb 0.14b
'#### license: creative commons cc0 1.0 (public domain)
'#### http://creativecommons.org/publicdomain/zero/1.0/
'SHELL "b:"

CLOSE

file$ = "text2htm.htm"
w = 80
h = 25

COLOR 7, 0: WIDTH , h: CLS

LOCATE 1, 1: PRINT "C:\FREEBA~1\HELLO.BAS(2) : error 256: Somehow it's your fault"


LOCATE 4, 1: PRINT "PRINT " + CHR$(34) + "Hello World!" + CHR$(34)
LOCATE 5, 1: PRINT "      ^"

'SHELL "dir"
'FOR y = 1 TO h
'FOR x = 1 TO w
'c = SCREEN(y, x)
'LOCATE y, x
'COLOR INT(RND * 15) + 1, INT(RND * 16)
'PRINT CHR$(c);
'NEXT x
'NEXT y: LOCATE 1, 1
'
'c = 0: SLEEP


FOR y = 1 TO h: FOR x = 1 TO w
c = SCREEN(y, x, 1)
f = c AND NOT (128 + 64 + 32 + 16)
COLOR f, (SCREEN(y, x, 1) - f) / 16
LOCATE y, x
q$ = q$ + CHR$(SCREEN(y, x))
f$ = f$ + HEX$(f)
b$ = b$ + HEX$((SCREEN(y, x, 1) - f) / 16)
'PRINT HEX$((SCREEN(y, x, 1) - f) / 16)
NEXT x: NEXT y ': SLEEP

OPEN file$ FOR OUTPUT AS #1: PRINT #1, "<pre style=" + CHR$(34) + "line-height:18px; font-size:18px; font-family: lucida console;" + CHR$(34) + "><span style=" + CHR$(34) + "color: #a8a8a8; background-color: #000000;" + CHR$(34) + ">";
COLOR 7, 0: CLS
cc = 0
FOR y = 1 TO h
FOR x = 1 TO w
LOCATE y, x
cc = cc + 1
qc = qc + 1
COLOR VAL("&h" + MID$(f$, cc, 1)), VAL("&h" + MID$(b$, cc, 1))
PRINT MID$(q$, cc, 1);
crlf$ = CHR$(13) + CHR$(10)

FOR fc = 1 TO 2
IF fc = 1 THEN qq$ = MID$(f$, cc, 1) ELSE qq$ = MID$(b$, cc, 1)
SELECT CASE VAL("&h" + qq$)
CASE 0: qq$ = "#000000;"
CASE 1: qq$ = "#0000a8;"
CASE 2: qq$ = "#00a800;"
CASE 3: qq$ = "#00a8a8;"
CASE 4: qq$ = "#a80000;"
CASE 5: qq$ = "#a800a8;"
CASE 6: qq$ = "#a85400;"
CASE 7: qq$ = "#a8a8a8;"
CASE 8: qq$ = "#545454;"
CASE 9: qq$ = "#5454fc;"
CASE 10: qq$ = "#54fc54;"
CASE 11: qq$ = "#54fcfc;"
CASE 12: qq$ = "#fc5454;"
CASE 13: qq$ = "#fc54fc;"
CASE 14: qq$ = "#fcfc54;"
CASE 15: qq$ = "#fcfcfc;"
END SELECT
IF fc = 1 THEN
span$ = "</span><span style=" + CHR$(34) + "color: " + qq$ + " background-color: "
ELSE
span$ = span$ + qq$ + CHR$(34) + ">"
IF span$ <> bspa$ THEN PRINT #1, span$; : bspa$ = span$
END IF
NEXT fc

SELECT CASE MID$(q$, cc, 1)
CASE CHR$(24): PRINT #1, "↑";
CASE CHR$(25): PRINT #1, "↓";
CASE CHR$(26): PRINT #1, "→";
CASE CHR$(27): PRINT #1, "←";
CASE CHR$(176): PRINT #1, "░";
CASE CHR$(179): PRINT #1, "│";
CASE CHR$(180): PRINT #1, "┤";
CASE CHR$(191): PRINT #1, "┐";
CASE CHR$(195): PRINT #1, "├";
CASE CHR$(196): PRINT #1, "─";
CASE CHR$(218): PRINT #1, "┌";
CASE CHR$(219): PRINT #1, "█";
CASE "<": PRINT #1, "&lt;";
CASE ">": PRINT #1, "&gt;";
CASE "&": PRINT #1, "&amp;";
CASE ELSE
PRINT #1, MID$(q$, cc, 1);
END SELECT
IF qc = w THEN qc = 0: PRINT #1, crlf$;
NEXT x
NEXT y
LOCATE 1, 1
COLOR 7, 0

PRINT #1, "</span></pre>"
CLOSE

'SLEEP
Find all posts by this user
Like Post
08-12-2017, 01:50 AM
Post: #2
 (Print Post)
RE: an old fb program i wrote
Code Snippet: [Select]
[[80100res.bas]]
'#### license: creative commons cc0 1.0 (public domain)
'#### http://creativecommons.org/publicdomain/zero/1.0/

OPEN "80100res.rcc" FOR BINARY AS #1 'rcc = raw console color.
'each byte is the byte that represents the fg and bg of
'that position on the screen. about as raw a format as it gets.

FOR y = 1 TO 50
FOR x = 1 TO 80
IF LOC(1) = LOF(1) THEN EXIT FOR

NEXT x
IF LOC(1) = LOF(1) THEN EXIT FOR
NEXT y

WIDTH 80, 50

PRINT CHR$(220): END
FOR c = 0 TO 15
LOCATE 1, c + 1: COLOR c: PRINT CHR$(220)
i = ABS(INSTR("fedcba9876543210", LCASE$(HEX$(c))) - 1)
LOCATE 2, c + 1: COLOR i: PRINT CHR$(220)
NEXT

'FOR y = 1 TO h: FOR x = 1 TO w
'c = SCREEN(y, x, 1)
'f = c AND NOT (128 + 64 + 32 + 16)
'COLOR f, (SCREEN(y, x, 1) - f) / 16
'LOCATE y, x
'q$ = q$ + CHR$(SCREEN(y, x))
'f$ = f$ + HEX$(f)
'b$ = b$ + HEX$((SCREEN(y, x, 1) - f) / 16)
''PRINT HEX$((SCREEN(y, x, 1) - f) / 16)
'NEXT x: NEXT y ': SLEEP

CLOSE
Find all posts by this user
Like Post
08-18-2017, 09:56 AM
Post: #3
 (Print Post)
RE: an old fb program i wrote
I couldn't get your program to work in fb so i added some dim statements and removed the $ from each string variable. Also renamed a few string variables such as f$ to sf because f was also used as an integer.
Code Snippet: [Select]
'[[text2htm]] an old fb program
'probably only works in fb 0.14b
'#### license: creative commons cc0 1.0 (public domain)
'#### http://creativecommons.org/publicdomain/zero/1.0/
'SHELL "b:"

Dim As String filename,sq,sf,sb,crlsf,qsq,span,bspa
Dim As Integer w,h,x,y,f,c,cc,qc,fc


Close
filename = "text2htm.htm"
w = 80
h = 25

COLOR 7, 0: WIDTH , h: CLS

LOCATE 1, 1: PRINT "C:\FREEBA~1\HELLO.BAS(2) : error 256: Somehow it's your fault"


LOCATE 4, 1: PRINT "PRINT " + CHR$(34) + "Hello World!" + CHR$(34)
LOCATE 5, 1: PRINT "      ^"

'SHELL "dir"
'FOR y = 1 TO h
'FOR x = 1 TO w
'c = SCREEN(y, x)
'LOCATE y, x
'COLOR INT(RND * 15) + 1, INT(RND * 16)
'PRINT CHR$(c);
'NEXT x
'NEXT y: LOCATE 1, 1
'
'c = 0: SLEEP


FOR y = 1 TO h: FOR x = 1 TO w
c = SCREEN(y, x, 1)
f = c AND NOT (128 + 64 + 32 + 16)
COLOR f, (SCREEN(y, x, 1) - f) / 16
LOCATE y, x
sq = sq + Chr(SCREEN(y, x))
sf = sf + Hex(f)
sb = sb + Hex((SCREEN(y, x, 1) - f) / 16)
'PRINT HEX$((SCREEN(y, x, 1) - f) / 16)
NEXT x: NEXT y ': SLEEP

OPEN filename FOR OUTPUT AS #1: PRINT #1, "<pre style=" + CHR$(34) + "line-height:18px; font-size:18px; font-family: lucida console;" + CHR(34) + "><span style=" + Chr(34) + "color: #a8a8a8; background-color: #000000;" + Chr(34) + ">";
COLOR 7, 0: CLS
cc = 0
FOR y = 1 TO h
FOR x = 1 TO w
LOCATE y, x
cc = cc + 1
qc = qc + 1
COLOR VAL("&h" + MID$(sf, cc, 1)), VAL("&h" + MID$(sb, cc, 1))
PRINT MID$(sq, cc, 1);
crlsf = Chr(13) + CHR$(10)

FOR fc = 1 TO 2
IF fc = 1 THEN qsq = MID$(sf, cc, 1) ELSE qsq = MID(sb, cc, 1)
SELECT CASE VAL("&h" + qsq)
    CASE 0: qsq = "#000000;"
    CASE 1: qsq = "#0000a8;"
    CASE 2: qsq = "#00a800;"
    CASE 3: qsq = "#00a8a8;"
    CASE 4: qsq = "#a80000;"
    CASE 5: qsq = "#a800a8;"
    CASE 6: qsq = "#a85400;"
    CASE 7: qsq = "#a8a8a8;"
    CASE 8: qsq = "#545454;"
    CASE 9: qsq = "#5454fc;"
    CASE 10: qsq = "#54fc54;"
    CASE 11: qsq = "#54fcfc;"
    CASE 12: qsq = "#fc5454;"
    CASE 13: qsq = "#fc54fc;"
    CASE 14: qsq = "#fcfc54;"
    CASE 15: qsq = "#fcfcfc;"
END SELECT
IF fc = 1 THEN
span = "</span><span style=" + CHR(34) + "color: " + qsq + " background-color: "
ELSE
span = span + qsq + Chr(34) + ">"
IF span <> bspa THEN PRINT #1, span; : bspa = span
END IF
NEXT fc

SELECT CASE MID$(sq, cc, 1)
    CASE Chr(24): PRINT #1, "?";
    CASE Chr(25): PRINT #1, "?";
    CASE Chr(26): PRINT #1, "?";
    CASE Chr(27): PRINT #1, "?";
    CASE Chr(176): PRINT #1, "¦";
    CASE Chr(179): PRINT #1, "¦";
    CASE Chr(180): PRINT #1, "¦";
    CASE Chr(191): PRINT #1, "+";
    CASE Chr(195): PRINT #1, "+";
    CASE Chr(196): PRINT #1, "-";
    CASE Chr(218): PRINT #1, "+";
    CASE Chr(219): PRINT #1, "¦";
    Case "<": PRINT #1, "&lt;";
    Case ">": PRINT #1, "&gt;";
    Case "&": PRINT #1, "&amp;";
    Case ELSE
    Print #1, MID$(sq, cc, 1);
END SELECT
IF qc = w THEN qc = 0: PRINT #1, crlsf;
NEXT x
NEXT y
LOCATE 1, 1
COLOR 7, 0

PRINT #1, "</span></pre>"
CLOSE

'SLEEP
Find all posts by this user
Like Post
08-18-2017, 10:38 AM
Post: #4
 (Print Post)
RE: an old fb program i wrote
my bad. it took me a second to realize this was about a computer programming language (ease of use) thing.
Find all posts by this user
Like Post
08-18-2017, 04:49 PM
Post: #5
 (Print Post)
RE: an old fb program i wrote
Quote:
'probably only works in fb 0.14b

thats the version of fb that was new when i started with fb. from there, they did a number of things that broke compatibility here and there.

i thought going backwards in compatibility was a little bait-and-switch, and didnt take kindly to it. but that was over a decade ago.

the second program i posted probably only worked in qb-- but even if its an fb program, i did NOT follow the trends and changes that got away from qb compatibility. in fact i refused.

that said, -lang fblite is worth a try. i think fb deprecated practically everything i liked about it. i still think galleon did a better job at a true qb replacement-- with or without the ide.
Find all posts by this user
Like Post



Forum Jump:


User(s) browsing this thread: 1 Guest(s)




QB64 Member Project - Isolation
QB64 Member Project - Pivet version one
QB64 Member Project - Pivot version two
QB64 Member Project - Amazon
QB64 Member Project - Color Rotating Text
QB64 Member Project - Algeria Weather
QB64 Member Project - Full Color LED Sign
QB64 Member Project - Line Thickness
QB64 Member Project - Score 4
QB64 Member Project - Red Scrolling LED Sign
QB64 Member Project - Inside Moves
QB64 Member Project - RGB Color Wheel
QB64 Member Project - Overboard
QB64 Member Project - ARB Checkers
QB64 Member Project - Qubic
QB64 Member Project - STxAxTIC 3D World
QB64 Member Project - Color Triangles
QB64 Member Project - Kings Court
QB64 Member Project - Exit
QB64 Member Project - Kings Vallery version two
QB64 Member Project - Othello
QB64 Member Project - Martin Fractals version three
QB64 Member Project - Kings Valley verion one
QB64 Member Project - OpenGL Triangles
QB64 Member Project - Swirl
QB64 Member Project - Martin Fractals version one
QB64 Member Project - Basic Dithering
QB64 Member Project - Domain
QB64 Member Project - Foursight
QB64 Member Project - Martin Fractals version four
QB64 Member Project - Input
QB64 Member Project - Rubix's Magic
QB64 Member Project - Connect Four
QB64 Member Project - Quarto
QB64 Member Project - 9 Board
QB64 Member Project - Blokus
QB64 Member Project - Kobolts Monopoly
QB64 Member Project - Touche
QB64 Member Project - Rotating Background
QB64 Member Project - Bowditch curve
QB64 Member Project - Dakapo
QB64 Member Project - Dreamy Clock
QB64 Member Project - Splatter
QB64 Member Project - MAPTRIANGLE
QB64 Member Project - Point Blank
QB64 Member Project - Sabotage
QB64 Member Project - Martin Fractals version two
QB64 Member Project - Spiro Roses
QB64 Member Project - Spinning Color Wheel