YOUR JOYFUL MEMBERSHIP CREDENTIALS HAVE NOT BEEN IDENTIFIED. PLEASE ENTER YOUR CREDENTIALS OR JOIN OUR JOYFUL COMMUNITY.
ENTER YOUR JOYFUL MEMBER CREDENTIALS REQUEST ACCESS TO OUR JOYFUL COMMUNITY


an old fb program i wrote
08-12-2017, 01:43 AM
Post: #1
 (Print Post)
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-18-2017, 09:56 AM
Post: #2
 (Print Post)
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: #3
 (Print Post)
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



Forum Jump:


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




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