Author Topic: Steve's Oldies  (Read 1426 times)

0 Members and 1 Guest are viewing this topic.

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Steve's Oldies
« on: September 17, 2018, 04:12:41 PM »
Going through my drive, just cleaning things up, and I'm running across some old BAS programs which seem interesting, and which I thought I'd share.  Rather than post each of these in their own topic, and clutter up the forums with random stuff, I thought I'd just make one topic and share them all in it. 

IF you guys want one of them separated from the pile, into its own topic, for commenting/searching/finding/highlighting/whatnot, just let me know and I'll do so for it.  Otherwise, as I play around and say, "Hey, this old thing was kinda neat", I'll just share it here for comment and consumption.

First entry -- RainbowText:

Code: QB64: [Select]
  1. fg& = _NEWIMAGE(1280, 720, 32)
  2. white& = _RGB32(255, 255, 255)
  3. SCREEN fg&
  4. PRINT "This is a demostration of a simple RainbowText routine."
  5. PRINT "One Command is being used to generate all the text which follows."
  6. PRINT "Press any key to see some quick samples."
  7. junk$ = INPUT$(1)
  8.  
  9. text$ = "This is sample text"
  10. RainbowText text$, 0, 0, 380, 220, 0, 0, 0, 0, 0
  11. RainbowText text$, 0, 180, 380, 380, 0, 0, 100, 100, 100
  12. RainbowText text$, 0, 90, 300, 300, 0, 0, 150, 150, 150
  13. RainbowText text$, 0, 270, 460, 300, 0, 0, 50, 100, 150
  14. RainbowText text$, 1, 0, 100, 100, 0, 0, 10, 200, 0
  15. RainbowText text$, -1, 0, 300, 100, 0, 0, 200, 200, 0
  16.  
  17. LOCATE 35, 40: PRINT "Press any key to watch what else you can do!"
  18.  
  19. junk$ = INPUT$(1)
  20.  
  21. COLOR , _RGB32(0, 0, 255)
  22. direction = .25
  23.  
  24.     CLS
  25.     i = i + direction
  26.     RainbowText text$, 0, i, 500, 500, 0, 0, r, g, b
  27.     IF i > 360 OR i < 0 THEN direction = -direction
  28. LOCATE 10, 10: PRINT "HA!  Rotating text, and all from 1 simple routine."
  29.  
  30.  
  31.  
  32. f& = _LOADFONT("times.ttf", 100)
  33.     RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b
  34.  
  35.  
  36.  
  37.  
  38. SUB RainbowText (text$, slant%, angle%, x%, y%, font&, b&, r, g, b)
  39.     A = _AUTODISPLAY: F = _FONT: D = _DEST
  40.     dc& = _DEFAULTCOLOR: bg& = _BACKGROUNDCOLOR
  41.     slant% = slant% + 1 'This keeps slant 0 as neutral
  42.     bgi& = _NEWIMAGE(100, 100, 32): _DEST bgi& 'temporary for sizing
  43.     IF font& <> 0 THEN _FONT font&
  44.     length% = _PRINTWIDTH(text$): height% = _FONTHEIGHT
  45.     _FREEIMAGE bgi&
  46.     bgi& = _NEWIMAGE(length%, height%, 32) 'screen to draw to, the proper size
  47.     _DEST bgi&: IF font& <> 0 THEN _FONT font&
  48.     COLOR _RGB32(255, 255, 255), b&
  49.     _PRINTSTRING (0, 0), text$
  50.     TLC$ = "BL" + STR$(length% \ 2) + "BU" + STR$(height% \ 2)
  51.     RET$ = "BD BL" + STR$(length%)
  52.     _SOURCE bgi&
  53.     _DEST D
  54.     DRAW "BM" + STR$(x%) + "," + STR$(y%) + "TA=" + VARPTR$(angle%) + TLC$
  55.     FOR y = 0 TO height% - slant%
  56.         FOR x = 0 TO length% - slant%
  57.             IF POINT(x, y) <> b& THEN
  58.                 r = r + 5
  59.                 IF r > 255 THEN r = 0: g = g + 5
  60.                 IF g > 255 THEN g = 0: b = b + 5
  61.                 IF b > 255 THEN b = 0: r = 0
  62.                 DRAW "C" + STR$(_RGB32(r, g, b)) + "R1" 'color and DRAW each pixel
  63.             ELSE
  64.                 DRAW "B R1" 'color and DRAW each pixel
  65.             END IF
  66.         NEXT
  67.         DRAW RET$
  68.     NEXT
  69.     IF NOT A THEN _DISPLAY: _AUTODISPLAY 'Remark this line out if you want to manually use _DISPLAY to show the text
  70.     _FREEIMAGE bgi&
  71.     IF font& <> 0 THEN _FONT F
  72.     COLOR dc&, bg&
  73.  

Note, the routine itself is only about 35 lines long, but what it does with such a small number of lines is ASTONISHING.  Slant text.  Rotate Text.  Color blend text...  Don't interfere with any local settings... 

Test it out, have fun with it, tell me what you think.  I'll add more junk as I come across it and find it suitable for sharing.  (A lot isn't, unless you have QB64 v 0.954h and StevesPrecompiler, which was an EXTERNAL precompiler to alter programs and automate a lot of repetitive tasks for me, in the past...)
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #1 on: September 17, 2018, 04:16:27 PM »
MOVETEXT:

Code: QB64: [Select]
  1. fg& = _NEWIMAGE(1280, 720, 32)
  2. f& = 16
  3. SCREEN fg&
  4. COLOR , _RGB(0, 0, 255)
  5. text$ = "This is a sample of moving text"
  6. MoveText 100, 400, 1280, 400, text$, 0, _RGB(255, 255, 255), _RGB(100, 100, 100)
  7. MoveText 1280, 400, 100, 400, text$, 0, _RGB(255, 255, 255), _RGB(200, 200, 200)
  8. MoveText 100, 400, 1000, 100, text$, 0, _RGB(255, 255, 255), _RGB(0, 0, 0)
  9.  
  10.  
  11. SUB MoveText (x1%, y1%, x2%, y2%, text$, font&, tc&, btc&)
  12.  
  13.     dc& = _DEFAULTCOLOR: bg& = _BACKGROUNDCOLOR
  14.     length% = _PRINTWIDTH(text$): height% = _FONTHEIGHT
  15.     bgi& = _NEWIMAGE(length%, height%, 32)
  16.     obg& = _NEWIMAGE(ABS(x1% - x2%) + length%, ABS(y1% - y2%) + height%, 32)
  17.  
  18.     _DEST bgi&
  19.     COLOR tc&, btc&
  20.     IF font& <> 0 THEN _FONT font&
  21.     _PRINTSTRING (0, 0), text$
  22.     _DEST 0
  23.     hm = x1% - x2% 'hortizonal move
  24.     vm = y1% - y2% 'vertical move
  25.     hs = hm / ABS(hm) 'hortizontal step
  26.     IF hm <> 0 THEN vs = vm / ABS(hm) ELSE vs = vm / ABS(vm) 'vertical step
  27.     xstart = x1%: ystart = y1%
  28.     xend = x2%: yend = y2%
  29.  
  30.     'Get our original background
  31.     IF x1% < x2% THEN left = x1%: right = x2% ELSE left = x2%: right = x1%
  32.     IF y1% < y2% THEN top = y1%: bottom = y2% ELSE top = y2%: bottom = y1%
  33.     right = right + length%: bottom = bottom + height%
  34.     _PUTIMAGE (0, 0), 0, obg&, (left, top)-(right, bottom)
  35.     DO
  36.         _LIMIT 200
  37.         _PUTIMAGE (left, top), obg&, 0 'Put our background in place
  38.         _PUTIMAGE (xstart, ystart), bgi&, 0 'Put our text on the screen
  39.         xstart = xstart - hs: ystart = ystart - vs
  40.         IF hs >= 0 AND xstart <= xend THEN finish1 = 1
  41.         IF hs < 0 AND xstart >= xend THEN finish1 = 1
  42.         IF vs >= 0 AND vstart <= yend THEN finish2 = 1
  43.         IF vs < 0 AND vstart >= yend THEN finish2 = 1
  44.         _DISPLAY
  45.     LOOP UNTIL finish1 AND finish2
  46.     _FREEIMAGE bgi&: _FREEIMAGE obg&

** Doesn't look as Library friendly as it, as it doesn't track usage of _AUTODISPLAY, which is a newer function and wasn't available back when this was written.
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #2 on: September 17, 2018, 04:24:01 PM »
DBF2QB64 --  A program to convert DBF files (database files from Dbase/Foxpro days) to be usable for QB64:

Code: QB64: [Select]
  1.  
  2. TYPE DBF_Header
  3.     FileType AS _UNSIGNED _BYTE
  4.     Year AS _UNSIGNED _BYTE
  5.     Month AS _UNSIGNED _BYTE
  6.     Day AS _UNSIGNED _BYTE
  7.     RecordNumber AS _UNSIGNED LONG
  8.     FirstRecord AS _UNSIGNED INTEGER
  9.     RecordLength AS _UNSIGNED INTEGER
  10.     ReservedJunk AS STRING * 16
  11.     TableFlag AS _UNSIGNED _BYTE
  12.     CodePageMark AS _UNSIGNED _BYTE
  13.     ReservedJunk1 AS STRING * 2
  14.  
  15. TYPE Field_Subrecord
  16.     FieldName AS STRING * 11
  17.     FieldType AS STRING * 1
  18.     Displacement AS _UNSIGNED LONG
  19.     FieldLength AS _UNSIGNED _BYTE
  20.     FieldDecimal AS _UNSIGNED _BYTE
  21.     FieldFlags AS _UNSIGNED _BYTE
  22.     AutoNext AS _UNSIGNED LONG
  23.     AutoStep AS _UNSIGNED _BYTE
  24.     ReservedJunk AS STRING * 8
  25.  
  26. 'The next two types really seem unimportant to us.
  27. 'I mainly put them in here so that no one would forget that our database has them.
  28. 'After the Field_Subrecords, there is a ENTER byte (CHR$(13)), for an End-of-Subrecord code.
  29. 'After that, there MAY be 263 bytes of information which FoxPro tosses into the dbd file.
  30. 'Honestly, it seems useless to me, but should be remembered just for documention sake if nothing else.
  31.  
  32.  
  33. TYPE DBF_HeaderTerminator
  34.     EndCode AS _UNSIGNED _BYTE 'Our End of Field Code is a CHR$(13), or 13 if we read it as a byte
  35.  
  36. TYPE DBF_VFPInfo
  37.     Info AS STRING * 263
  38.  
  39. DIM DataH AS DBF_Header
  40. DIM DataFS(1) AS Field_Subrecord
  41. 'Notice I didn't even bother to define a variable for our other two types?  That's how important they seem to me.  ;)
  42.  
  43.  
  44. file$ = "z:\tempdata.dbf"
  45. file2$ = "z:\converted.txt"
  46.  
  47. Get_Header file$, DataH
  48. 'Display_Header DataH 'You can unremark this line, if you want to see what the Header looks like itself.
  49. Get_Fields file$, DataFS()
  50. 'Display_Fields DataFS() ' Unremark this line to see how many fields we have, what types, and their properties, if you want.
  51. Print_Data file$, DataH, DataFS(), file2$
  52. PRINT "Your file has been converted."
  53. PRINT "The original file was: "; file$
  54. PRINT "The converted file is: "; file2$
  55.  
  56.  
  57.  
  58. SUB Display_Header (DataH AS DBF_Header)
  59.     PRINT "Data File Type: ";
  60.     SELECT CASE DataH.FileType
  61.         CASE 2: PRINT "FoxBASE"
  62.         CASE 3: PRINT "FoxBASE+/Dbase III plus, no memo"
  63.         CASE 48: PRINT "Visual FoxPro"
  64.         CASE 49: PRINT "Visual FoxPro, autoincrement enabled"
  65.         CASE 50: PRINT "Visual FoxPro with field type Varchar or Varbinary"
  66.         CASE 67: PRINT "dBASE IV SQL table files, no memo"
  67.         CASE 99: PRINT "dBASE IV SQL system files, no memo"
  68.         CASE 131: PRINT "FoxBASE+/dBASE III PLUS, with memo"
  69.         CASE 139: PRINT "dBASE IV with memo"
  70.         CASE 203: PRINT "dBASE IV SQL table files, with memo"
  71.         CASE 229: PRINT "HiPer-Six format with SMT memo file"
  72.         CASE 245: PRINT "FoxPro 2.x (or earlier) with memo"
  73.         CASE 251: PRINT "FoxBASE"
  74.         CASE ELSE: PRINT "Unknown File Type"
  75.     END SELECT
  76.     PRINT "Date: "; DataH.Month; "/"; DataH.Day; "/"; DataH.Year
  77.     PRINT "Number of Records: "; DataH.RecordNumber
  78.     PRINT "First Record: "; DataH.FirstRecord
  79.     PRINT "Record Length: "; DataH.RecordLength
  80.     PRINT "Reserved Junk: "; DataH.ReservedJunk
  81.     PRINT "Table Flags: ";
  82.     none = 0
  83.     IF DataH.TableFlag AND 1 THEN PRINT "file has a structural .cdx ";: none = -1
  84.     IF DataH.TableFlag AND 2 THEN PRINT "file has a Memo field ";: none = -1
  85.     IF DataH.TableFlag AND 4 THEN PRINT "file is a database (.dbc) ";: none = -1
  86.     IF none THEN PRINT ELSE PRINT "None"
  87.     PRINT "Code Page Mark: "; DataH.CodePageMark
  88.     PRINT "Reserved Junk: "; DataH.ReservedJunk1
  89.  
  90. SUB Display_Fields (DataH() AS Field_Subrecord)
  91.     FOR r = 1 TO UBOUND(DataH)
  92.         PRINT "Field Name :"; DataH(r).FieldName
  93.         PRINT "Field Type :"; DataH(r).FieldType
  94.         PRINT "Field Displacement :"; DataH(r).Displacement
  95.         PRINT "Field Length :"; DataH(r).FieldLength
  96.         PRINT "Field Decimal :"; DataH(r).FieldDecimal
  97.         PRINT "Field Flags :"; DataH(r).FieldFlags
  98.         PRINT "Field AutoNext :"; DataH(r).AutoNext
  99.         PRINT "Field SutoStep :"; DataH(r).AutoStep
  100.         PRINT "Field Reserved Junk :"; DataH(r).ReservedJunk
  101.         SLEEP
  102.         PRINT "**************************"
  103.     NEXT
  104.  
  105. SUB Get_Header (file$, DataH AS DBF_Header)
  106.     OPEN file$ FOR BINARY AS #1 LEN = LEN(DataH)
  107.     GET #1, 1, DataH
  108.     CLOSE
  109.  
  110. SUB Get_Fields (file$, DataFS() AS Field_Subrecord)
  111.     DIM databyte AS _UNSIGNED _BYTE
  112.     DIM temp AS Field_Subrecord
  113.     OPEN file$ FOR BINARY AS #1 LEN = 1
  114.     counter = -1: s = 33
  115.     DO
  116.         counter = counter + 1
  117.         GET #1, s, databyte
  118.         s = s + 32
  119.     LOOP UNTIL databyte = 13
  120.     REDIM DataFS(counter) AS Field_Subrecord
  121.     IF counter < 1 THEN BEEP: BEEP: PRINT "Database has no file records.": END
  122.     CLOSE
  123.     OPEN file$ FOR BINARY AS #1 LEN = 32
  124.     FOR r = 1 TO counter
  125.         GET #1, 32 * r + 1, DataFS(r) 'record 1 is our header info, so we need to start our field info at record 2
  126.     NEXT
  127.  
  128.     CLOSE
  129.  
  130. SUB Print_Data (file$, DataH AS DBF_Header, DataFS() AS Field_Subrecord, file2$)
  131.     DIM databyte AS _UNSIGNED _BYTE
  132.     OPEN file$ FOR BINARY AS #1
  133.     OPEN file2$ FOR OUTPUT AS #2
  134.     SEEK #1, DataH.FirstRecord + 1
  135.     FOR z = 1 TO DataH.RecordNumber
  136.         GET #1, , databyte 'This is the first byte which tells us if the record is good, or has been deleted.
  137.         IF databyte = 32 THEN WRITE #2, "Good Record", ELSE WRITE #2, "Deleted Record",
  138.         FOR i = 1 TO UBOUND(DataFS)
  139.             SELECT CASE DataFS(i).FieldType
  140.                 CASE "C", "0"
  141.                     'C is for Characters, or basically STRING characters.
  142.                     '0 is for Null Flags, which I have no clue what they're for.  I'm basically reading them here as worthless characters until I learn otherwise.
  143.                     temp$ = ""
  144.                     FOR j = 1 TO DataFS(i).FieldLength
  145.                         GET #1, , databyte
  146.                         temp$ = temp$ + CHR$(databyte)
  147.                     NEXT
  148.                 CASE "Y"
  149.                     'Y is for currency, which is an _INTEGER 64, with an implied 4 spaces for decimal built in.
  150.                     REDIM temp AS _INTEGER64
  151.                     GET #1, , temp
  152.                     temp$ = STR$(temp)
  153.                     l = LEN(temp$)
  154.                     temp$ = LEFT$(temp$, l - 4) + "." + RIGHT$(temp$, 4)
  155.                 CASE "N", "F", "M", "G"
  156.                     'N is for numberic, F is for Floating numbers, and both seem to work in the same manner.
  157.                     'M is for Memo's, which are stored in a different  DBT file.  What we have here is the block number of the memo location in that file, stored as a simple set of characters.
  158.                     'G is for OLE files.  We store the info for it just the same as we do for a Memo.
  159.                     'we read the whole thing as a string, which is an odd way for dBase to write it, but I don't make the rules.  I just convert them!
  160.                     temp$ = ""
  161.                     FOR j = 1 TO DataFS(i).FieldLength
  162.                         GET #1, , databyte
  163.                         temp$ = temp$ + CHR$(databyte)
  164.                     NEXT
  165.                 CASE "D"
  166.                     'D is for Date fields.
  167.                     'Dates are stored as a string, in the format YYYYMMDD
  168.                     temp$ = ""
  169.                     FOR j = 1 TO DataFS(i).FieldLength
  170.                         GET #1, , databyte
  171.                         temp$ = temp$ + CHR$(databyte)
  172.                     NEXT
  173.                     year$ = LEFT$(temp$, 4)
  174.                     month$ = MID$(temp$, 5, 2)
  175.                     day$ = RIGHT$(temp$, 2)
  176.                     temp$ = day$ + "/" + month$ + "/" + year$
  177.                 CASE "L"
  178.                     'L is our logical operator.  Basically, it's simply True or False Boolean logic
  179.                     GET #1, , databyte
  180.                     IF databyte = 32 THEN temp$ = "True" ELSE temp$ = "false"
  181.                 CASE "@", "O"
  182.                     '@ are Timestamps, which I'm too lazy to fully support at the moment.
  183.                     'They are 8 bytes - two longs, first for date, second for time.
  184.                     'The date is the number of days since  01/01/4713 BC.
  185.                     'Time is hours * 3600000L + minutes * 60000L + Seconds * 1000L
  186.                     'All I'm going to do is read both longs as a single _Integer64 and then write that data to the disk.
  187.                     'Be certain to convert it as needed to make use of the Timestamp.
  188.                     'I'm just lazy and don't wanna convert anything right now!  :P
  189.  
  190.                     'O are double long integers -- basically Integer 64s.  Since I'm reading a timestamp as an Int64, this routine works for them as well.
  191.                     REDIM temp1 AS _INTEGER64
  192.                     GET #1, , temp1
  193.                     temp$ = STR$(temp1)
  194.                 CASE "I", "+"
  195.                     'Long Integers.  Basically 4 byte numbers
  196.                     '+ are auto-increments.  Stored the same way as a Long.
  197.                     REDIM temp2 AS LONG
  198.                     GET #1, , temp2
  199.                     temp$ = STR$(temp2)
  200.             END SELECT
  201.             IF i = UBOUND(datafs) THEN WRITE #2, temp$ ELSE WRITE #2, temp$,
  202.         NEXT
  203.     NEXT
  204.     CLOSE

Change the 2 lines with the files to point to where you want them to be, and it's all set to go:

file$ = "z:\tempdata.dbf"  <--- file to convert
file2$ = "z:\converted.txt"  <--- file to save the conversion to
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #3 on: September 17, 2018, 04:35:53 PM »
SAC -- Steve's Anorexic Code:

Code: QB64: [Select]
  1. 'Steve's Anorexic Code
  2. 'This code has a very unique value to us.
  3. '1) This allows us to append files to the end of our exe's very easily, and then extract them and clean them up afterwards.
  4. '2) This works at a command line level, and lets us shell out from inside a program itself.
  5.  
  6. 'To use this, first try it a few times with some BACKED UP copy of test files!!
  7. 'BACK EM UP!! BACK EM UP!! BACK EM UP!!
  8.  
  9. 'Got that?  Good.
  10.  
  11. 'Then run this as a standard program.
  12. 'Enter the name of the file you'd like to feed stuff to.
  13. 'And at first, -SET THE TABLE   Do this only once, as this sets us a counter for number of files "eatten"
  14. 'Then feed it something.  -GOBBLE filename$  <-- this is the file we tack to the end of our exe
  15. 'Feed it more files if you want.  Watch the exe grow in size as it absorbs the other files...
  16.  
  17. 'Is it fat?  Did you feed it enough?
  18. 'If so, then -PUKE or -BARF   Throw them files back up!
  19.  
  20. 'Phew!  Didn't that make a mess?
  21. 'Then -CLEAN UP
  22. 'See all them files go POOF and disappear again?  We clean up our mess afterwards.
  23.  
  24. 'But this is MAGIC Anorexic Code!   The exe still has all those files in it that it barfed up.
  25. 'Tell it to -PUKE again.
  26. 'All those files are back once more!!
  27.  
  28. 'Use this as a quick, easy way to tack needed files onto your exe to make certain that an user will always have them.
  29. 'I use this to  tack sound files, fonts, even images to my exe, and I extract them as needed.
  30.  
  31. 'NOTE however, that this isn't just limited to EXE files.  You can use this to assemble 100 map files into 1 map compendium,
  32. '   and then extract them when needed.   At the moment, we don't puke single files up -- we puke every file up -- but
  33. '   someone could modify this easily enough to extract single files from a larger collection.
  34.  
  35. 'To use as a shell command, use it like the following:
  36. '   Shell _hide "SAC.exe g.exe -gobble z:\test.txt"    <--- this would add the test.txt file to the end of the g.exe file'
  37. '   syntax is:   SAC.exe file1$ -command file2$
  38. '      file1$ would be the file we want to write to -- or feed.
  39. '      -command is the -command which we want to execute.   -SET THE TABLE, -GOBBLE, -BARF, -CLEAN UP
  40.  
  41. 'Simple, and useful as heck!   :D
  42.  
  43.  
  44. DIM SHARED SAC_FileName AS STRING
  45. parameter$ = LTRIM$(RTRIM$(COMMAND$))
  46. IF parameter$ <> "" THEN
  47.     dash = INSTR(parameter$, "-")
  48.     SAC_FileName = LTRIM$(RTRIM$(LEFT$(parameter$, dash - 1)))
  49.     parameter$ = RTRIM$(LTRIM$(RIGHT$(parameter$, LEN(parameter$) - dash + 1)))
  50.     PRINT SAC_FileName, parameter$
  51.     END
  52.     DoSAC parameter$
  53.     SYSTEM
  54.  
  55. PRINT "Give me the name of your file to stuff =>";
  56. INPUT SAC_FileName
  57.     CLS
  58.     PRINT SAC_FileName
  59.     PRINT
  60.     PRINT "1) Initialize"
  61.     PRINT "2) Gobble Something"
  62.     PRINT "3) Puke"
  63.     PRINT "4) Clean Up"
  64.     PRINT "5) End"
  65.     a$ = INPUT$(1)
  66.     a = VAL(a$)
  67.     SELECT CASE a
  68.         CASE 1: DoSAC "-INIT": PRINT "Initialized"
  69.         CASE 2:
  70.             PRINT "Name of file to eat:";
  71.             INPUT name$
  72.             name$ = "-GOBBLE " + name$
  73.             DoSAC name$
  74.         CASE 3: DoSAC "-BARF"
  75.         CASE 4: DoSAC "-CLEAN UP"
  76.         CASE 5: SYSTEM
  77.     END SELECT
  78.     SLEEP
  79.  
  80.  
  81. SUB DoSAC (t$)
  82.     DIM text AS STRING * 1
  83.     DIM SACfile AS STRING * 255
  84.     f = FREEFILE
  85.     SELECT CASE UCASE$(t$)
  86.         CASE "-SET THE TABLE", "-SET", "-INIT"
  87.             'initialize
  88.             OPEN SAC_FileName FOR BINARY AS #f
  89.             SEEK #f, LOF(f) + 1
  90.             b = 0
  91.             PUT #f, , b
  92.         CASE "-BARF", "-PUKE"
  93.             'puke it all up
  94.             OPEN SAC_FileName FOR BINARY AS #f
  95.             SEEK #f, LOF(f)
  96.             GET #f, , b
  97.             IF b < 1 THEN PRINT "No files have been gorged on by this program.  FEED ME SOME!!": BEEP: BEEP: END
  98.             PRINT b; "files to puke up!"
  99.             CurrentPos = LOF(f) + 1
  100.             AmountAte = b
  101.             FOR i&& = 1 TO AmountAte
  102.                 CurrentPos = CurrentPos - 256
  103.                 GET #f, CurrentPos, SACfile
  104.                 file$ = LTRIM$(RTRIM$(SACfile))
  105.                 PRINT file$; " barfed up!"
  106.                 CurrentPos = CurrentPos - 8
  107.                 GET #f, CurrentPos, l
  108.                 CurrentPos = CurrentPos - l
  109.                 g = FREEFILE
  110.                 SEEK #f, CurrentPos
  111.                 OPEN file$ FOR BINARY AS #g
  112.                 FOR j&& = 1 TO l
  113.                     GET #f, , b
  114.                     PUT #g, , b
  115.                 NEXT
  116.                 b = 0
  117.                 PUT #g, , b
  118.                 CLOSE #g
  119.             NEXT
  120.         CASE "-CLEAN UP"
  121.             'clean up the drive of all the puke
  122.             OPEN SAC_FileName FOR BINARY AS #f
  123.             SEEK #f, LOF(f)
  124.             GET #f, , b
  125.             IF b < 1 THEN PRINT "No files have been gorged on by this program.  FEED ME SOME!!": BEEP: BEEP: END
  126.             PRINT b; "puked up files to clean up!"
  127.             CurrentPos = LOF(f) + 1
  128.             AmountAte = b
  129.             FOR i&& = 1 TO AmountAte
  130.                 CurrentPos = CurrentPos - 256
  131.                 GET #f, CurrentPos, SACfile
  132.                 file$ = LTRIM$(RTRIM$(SACfile))
  133.                 PRINT file$; " cleaned up off the dinner table!"
  134.                 CurrentPos = CurrentPos - 8
  135.                 GET #f, CurrentPos, l
  136.                 CurrentPos = CurrentPos - l
  137.                 KILL file$
  138.             NEXT
  139.         CASE ELSE
  140.             IF LEFT$(t$, 8) = "-GOBBLE " THEN
  141.                 file$ = RIGHT$(t$, LEN(t$) - 8)
  142.                 IF _FILEEXISTS(file$) THEN
  143.                     PRINT "Eatting "; file$
  144.                     'eat stuff
  145.                     OPEN SAC_FileName FOR BINARY AS #f
  146.                     l(0) = LOF(f)
  147.                     SEEK #f, l(0)
  148.                     GET #f, , b
  149.                     AmountEat = b
  150.                     g = FREEFILE
  151.                     OPEN file$ FOR BINARY AS #g
  152.                     l(1) = LOF(g)
  153.                     FOR i&& = 1 TO l(1)
  154.                         GET #g, , b
  155.                         PUT #f, , b
  156.                     NEXT
  157.                     CLOSE #g
  158.                     PUT #f, , l(1)
  159.                     SACfile = file$
  160.                     PUT #f, , SACfile
  161.                     b = AmountEat + 1
  162.                     PUT #f, , b
  163.                     PRINT file$, " was tasty!"
  164.                 ELSE
  165.                     'Do nothing as the file doesn't exist.
  166.                     PRINT "WARNING: "; file$; " does not exist!"
  167.                     BEEP: BEEP
  168.                 END IF
  169.             END IF
  170.     END SELECT
  171.     CLOSE #f

One of the weirdest little programs which I have ever written, and yet it was something a lot of folks enjoyed at the time.  What's it do, you ask...

It EATS files that we tell it to, making them disappear from our hard drive, as it gets ever fatter.... Then, when we've "fed" it enough, it sits there and feels miserable for itself until we tell it to BARF them back up for us.

It's basically a file stacking/restoration program at its heart, and useful for sticking dozens of resource files together and packaging them into one file, then extracting them as needed.
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #4 on: September 17, 2018, 04:48:39 PM »
SCREENGRAB and SCREENRESTORE -- grab a screen, save it to disk, load and restore it later when you want to in your program:

Code: QB64: [Select]
  1. InitializeScreen
  2. ScreenGrab "test.bin"
  3. _DELAY 2: CLS 'a pause to see the orignal screen, then clear it
  4. _DELAY 2 ' so we can see the blanked screen
  5. ScreenRestore "test.bin" 'and the restored one
  6.  
  7. SUB ScreenGrab (file$)
  8.     DIM m AS _MEM: m = _MEMIMAGE(0)
  9.     t$ = SPACE$(m.SIZE)
  10.     f = FREEFILE
  11.     OPEN file$ FOR OUTPUT AS #f: CLOSE #f
  12.     OPEN file$ FOR BINARY AS #f
  13.     _MEMGET m, m.OFFSET, t$
  14.     PUT #f, , t$
  15.     CLOSE #f
  16.     _MEMFREE m
  17.  
  18.  
  19. SUB InitializeScreen
  20.     SHARED s&
  21.     f& = _LOADFONT("OLDENGL.TTF", 76)
  22.     s& = _NEWIMAGE(1280, 720, 32)
  23.     SCREEN s&: _FONT f&
  24.     FOR i = 1 TO 100
  25.         LINE (RND * _WIDTH, RND * _HEIGHT)-(RND * 255, RND * 255), _RGB(RND * 255, RND * 255, RND * 255), BF
  26.     NEXT
  27.     COLOR _RGB32(255, 0, 0), 0
  28.     _PRINTSTRING ((_WIDTH - _PRINTWIDTH("Steve is awesome!")) / 2, 0), "Steve is awesome!"
  29.     _FONT 16: _FREEFONT f&
  30.  
  31.  
  32.  
  33. SUB ScreenRestore (file$)
  34.     DIM m AS _MEM: m = _MEMIMAGE(0)
  35.     t$ = SPACE$(m.SIZE)
  36.     f = FREEFILE
  37.     OPEN file$ FOR BINARY AS #f
  38.     GET #f, , t$
  39.     CLOSE #f
  40.     _MEMPUT m, m.OFFSET, t$
  41.     _MEMFREE m
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #5 on: September 17, 2018, 05:11:06 PM »
Ummm.... A demo of a bunch of different routines from my text library:

Code: QB64: [Select]
  1. DIM ColorArray(10) AS _UNSIGNED LONG
  2.  
  3. SCREEN _NEWIMAGE(1400, 1000, 32)
  4.  
  5.  
  6. ColorArray(0) = 3
  7. ColorArray(1) = _RGB32(255, 0, 0)
  8. ColorArray(2) = _RGB32(255, 255, 255)
  9. ColorArray(3) = _RGB32(0, 0, 255)
  10.  
  11. a& = _LOADIMAGE("qb64.png", 32)
  12. DisplayImage a&, 300, 500, 0, 0 'Show the original bee
  13.  
  14. RainbowImage a&, ColorArray(), 1, 0, 1 'Rainbow the Bee's background
  15. DisplayImage a&, 700, 500, 0, 0
  16. a& = _LOADIMAGE("qb64.png", 32) 'reload the image (we altered it before with the last RainbowImage call)
  17. RainbowImage a&, ColorArray(), 1, 0, 0 'Rainbow the Bee
  18. DisplayImage a&, 500, 500, 0, 0
  19.  
  20. b& = SaveBackground&
  21.  
  22. c& = TextToImage("This is moving rainbow text!", 16, _RGB32(255, 0, 0), 0, 0)
  23. ScaleImage c&, 3, 3
  24. ColorArray(0) = 0
  25. RainbowImage c&, ColorArray(), _RGB32(255, 0, 0), 0, 0
  26.  
  27. FOR i = 100 TO 700
  28.     RestoreBackground b&
  29.     DisplayImage a&, i, i, i, 0
  30.     DisplayImage a&, 800 - i, 800 - i, i, 1
  31.     DisplayImage c&, 300, i - 100, i, 0
  32.     _DISPLAY
  33.  
  34.  
  35.  
  36. SUB RainbowImage (Image AS LONG, c() AS _UNSIGNED LONG, fc AS _UNSIGNED LONG, bfc AS _UNSIGNED LONG, mode AS _BYTE)
  37.     'Image is our image handle created by TextToImage
  38.     'C() is our color array.  c(0) tells us how many colors to use to blend (from 0 - our color array limit)
  39.     'If 0, we go with the default rainbow color routine
  40.     'If 1, we get a solid color, whatever is c(1)
  41.     'If more than 1, we blend our colors from (c1) to c(2) to c(3) to c(4) to c(...up to our limit)
  42.     'fc is our foreground color (or font color if you're coloring text)
  43.     'bfc is our background color (or background font color, for text)
  44.     'mode is how we create our rainbow.  0 is for the foreground to be rainbow, 1 is for background
  45.  
  46.     w = _WIDTH(Image): h = _HEIGHT(Image)
  47.     _SOURCE Image
  48.     _DEST Image
  49.     IF c(0) < 1 THEN c(0) = 0
  50.     SELECT CASE c(0)
  51.         CASE 0
  52.             'This is the default, where we print a nice balanced rainbow
  53.  
  54.             r = 255: g = 0: b = 0
  55.             s = 1275 / _WIDTH(Image)
  56.             FOR i = 0 TO _WIDTH(Image) - 1
  57.                 DO
  58.                     IF r >= 255 AND g <= 0 AND b <= 0 THEN rc = 0: gc = s: bc = 0: EXIT DO 'Add a new color
  59.                     IF r >= 255 AND g >= 255 AND b <= 0 THEN rc = -s: gc = 0: bc = 0: EXIT DO 'subtract the old color
  60.                     IF g >= 255 AND b <= 0 AND r <= 0 THEN rc = 0: gc = 0: bc = s: EXIT DO 'Add a new color
  61.                     IF g >= 255 AND b >= 255 AND r <= 0 THEN rc = 0: gc = -s: bc = 0: EXIT DO 'subtract the old color
  62.                     IF b >= 255 AND r <= 0 AND g <= 0 THEN rc = s: gc = 0: bc = 0: EXIT DO 'Add a new color
  63.                     IF b >= 255 AND r >= 255 AND g <= 0 THEN rc = 0: gc = 0: bc = -s: EXIT DO 'subtract the old color
  64.                     EXIT DO
  65.                 LOOP
  66.                 r = r + rc: g = g + gc: b = b + bc
  67.                 IF r < 0 THEN r = 0
  68.                 IF r > 255 THEN r = 255
  69.                 IF g < 0 THEN g = 0
  70.                 IF g > 255 THEN g = 255
  71.                 IF b < 0 THEN b = 0
  72.                 IF b > 255 THEN b = 255
  73.                 FOR j = 0 TO _HEIGHT(Image) - 1
  74.                     IF mode = 1 THEN
  75.                         IF POINT(i, j) = bfc THEN
  76.                             PSET (i, j), _RGB32(r, g, b)
  77.                         END IF
  78.                     ELSE
  79.                         IF POINT(i, j) <> bfc THEN
  80.                             PSET (i, j), _RGB32(r, g, b)
  81.                         END IF
  82.                     END IF
  83.                 NEXT
  84.             NEXT
  85.         CASE 1
  86.             FOR i = 0 TO _WIDTH(Image) - 1
  87.                 FOR j = 0 TO _HEIGHT(Image) - 1
  88.                     IF mode = 1 THEN
  89.                         IF POINT(i, j) = bfc THEN
  90.                             PSET (i, j), c(1)
  91.                         END IF
  92.                     ELSE
  93.                         IF POINT(i, j) <> bfc THEN
  94.                             PSET (i, j), c(1)
  95.                         END IF
  96.                     END IF
  97.                 NEXT
  98.             NEXT
  99.         CASE ELSE
  100.             s = ((c(0) - 1) * 255) / _WIDTH(Image)
  101.             'our scale is going to depend on how many colors we blend.   It's 255 steps from 1 color to another in this process.
  102.             'c(0) is how many colors we blend
  103.             BlendOn = 1: counter = 0: counter2 = 1
  104.             FOR i = 0 TO _WIDTH(Image)
  105.                 counter = counter + s
  106.                 _SOURCE Image
  107.                 _DEST Image
  108.                 Reverse_RGB c(BlendOn), r1%, g1%, b1%
  109.                 Reverse_RGB c(BlendOn + 1), r2%, g2%, b2%
  110.                 rd = (r1% - r2%) / 255 * s
  111.                 gd = (g1% - g2%) / 255 * s
  112.                 bd = (b1% - b2%) / 255 * s
  113.                 ru = r1% - rd * (i - subtract)
  114.                 gu = g1% - gd * (i - subtract)
  115.                 bu = b1% - bd * (i - subtract)
  116.                 coloruse~& = _RGB32(ru, gu, bu)
  117.                 FOR j = 0 TO _HEIGHT(Image) - 1
  118.                     IF mode = 1 THEN
  119.                         IF POINT(i, j) = bfc THEN
  120.                             PSET (i, j), coloruse~&
  121.                         END IF
  122.                     ELSE
  123.                         IF POINT(i, j) <> bfc THEN
  124.                             PSET (i, j), coloruse~&
  125.                         END IF
  126.                     END IF
  127.                 NEXT
  128.                 IF counter \ 255 >= counter2 THEN
  129.                     BlendOn = BlendOn + 1
  130.                     counter2 = counter2 + 1
  131.                     subtract = i
  132.                 END IF
  133.  
  134.             NEXT
  135.  
  136.     END SELECT
  137.     _DEST 0
  138.  
  139. FUNCTION SaveBackground&
  140.     SaveBackground& = _COPYIMAGE(0)
  141.  
  142. SUB UpdateBackground (Image AS LONG)
  143.     _PUTIMAGE , 0, Image
  144.  
  145. SUB RestoreBackground (Image AS LONG)
  146.     _PUTIMAGE , Image, 0
  147.  
  148. SUB Reverse_RGB (c~&, r%, g%, b%)
  149.     h$ = HEX$(c~&)
  150.     a$ = LEFT$(h$, 2)
  151.     r$ = "&H" + MID$(h$, 3, 2)
  152.     g$ = "&H" + MID$(h$, 5, 2)
  153.     b$ = "&H" + MID$(h$, 7, 2)
  154.     r% = VAL(r$)
  155.     g% = VAL(g$)
  156.     b% = VAL(b$)
  157.  
  158.  
  159.  
  160. FUNCTION TextToImage& (text$, font&, fc&, bfc&, mode AS _BYTE)
  161.     'Mode 1 is print forwards
  162.     'Mode 2 is print backwards
  163.     'Mode 3 is print from top to bottom
  164.     'Mode 4 is print from bottom up
  165.  
  166.  
  167.     IF mode < 1 OR mode > 4 THEN mode = 1
  168.     dc& = _DEFAULTCOLOR: bgc& = _BACKGROUNDCOLOR
  169.     IF font& <> 0 THEN _FONT font&
  170.     IF mode < 3 THEN
  171.         'print the text lengthwise
  172.         w& = _PRINTWIDTH(text$): h& = _FONTHEIGHT
  173.     ELSE
  174.         'print the text vertically
  175.         FOR i = 1 TO LEN(text$)
  176.             IF w& < _PRINTWIDTH(MID$(text$, i, 1)) THEN w& = _PRINTWIDTH(MID$(text$, i, 1))
  177.         NEXT
  178.         h& = _FONTHEIGHT * (LEN(text$))
  179.     END IF
  180.     TextToImage& = _NEWIMAGE(w&, h&, 32)
  181.     _DEST TextToImage&
  182.     IF font& <> 0 THEN _FONT font&
  183.     COLOR fc&, bfc&
  184.  
  185.     SELECT CASE mode
  186.         CASE 1
  187.             'Print text forward
  188.             _PRINTSTRING (0, 0), text$
  189.         CASE 2
  190.             'Print text backwards
  191.             temp$ = ""
  192.             FOR i = 0 TO LEN(text$) - 1
  193.                 temp$ = temp$ + MID$(text$, LEN(text$) - i, 1)
  194.             NEXT
  195.             _PRINTSTRING (0, 0), temp$
  196.         CASE 3
  197.             'Print text upwards
  198.             'first lets reverse the text, so it's easy to place
  199.             temp$ = ""
  200.             FOR i = 0 TO LEN(text$) - 1
  201.                 temp$ = temp$ + MID$(text$, LEN(text$) - i, 1)
  202.             NEXT
  203.             'then put it where it belongs
  204.             FOR i = 1 TO LEN(text$)
  205.                 fx = (w& - _PRINTWIDTH(MID$(temp$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
  206.                 _PRINTSTRING (fx, _FONTHEIGHT * (i - 1)), MID$(temp$, i, 1)
  207.             NEXT
  208.         CASE 4
  209.             'Print text downwards
  210.             FOR i = 1 TO LEN(text$)
  211.                 fx = (w& - _PRINTWIDTH(MID$(text$, i, 1))) / 2 + .99 'This is to center any non-monospaced letters so they look better
  212.                 _PRINTSTRING (fx, _FONTHEIGHT * (i - 1)), MID$(text$, i, 1)
  213.             NEXT
  214.             _DISPLAY
  215.     END SELECT
  216.     _DEST 0
  217.     COLOR dc&, bgc&
  218.  
  219. SUB ScaleImage (Image AS LONG, xscale AS SINGLE, yscale AS SINGLE)
  220.     w = _WIDTH(Image): h = _HEIGHT(Image)
  221.     w2 = w * xscale: h2 = h * yscale
  222.     NewImage& = _NEWIMAGE(w2, h2, 32)
  223.     _PUTIMAGE , Image, NewImage&
  224.     _FREEIMAGE Image
  225.     Image = NewImage&
  226.  
  227. SUB DisplayImage (Image AS LONG, x AS INTEGER, y AS INTEGER, angle AS SINGLE, mode AS _BYTE)
  228.     DIM px(3) AS INTEGER, py(3) AS INTEGER, w AS INTEGER, h AS INTEGER
  229.     DIM sinr AS SINGLE, cosr AS SINGLE, i AS _BYTE
  230.     w = _WIDTH(Image): h = _HEIGHT(Image)
  231.     SELECT CASE mode
  232.         CASE 0 'center
  233.             px(0) = -w \ 2: py(0) = -h \ 2: px(3) = w \ 2: py(3) = -h \ 2
  234.             px(1) = -w \ 2: py(1) = h \ 2: px(2) = w \ 2: py(2) = h \ 2
  235.         CASE 1 'top left
  236.             px(0) = 0: py(0) = 0: px(3) = w: py(3) = 0
  237.             px(1) = 0: py(1) = h: px(2) = w: py(2) = h
  238.         CASE 2 'bottom left
  239.             px(0) = 0: py(0) = -h: px(3) = w: py(3) = -h
  240.             px(1) = 0: py(1) = 0: px(2) = w: py(2) = 0
  241.         CASE 3 'top right
  242.             px(0) = -w: py(0) = 0: px(3) = 0: py(3) = 0
  243.             px(1) = -w: py(1) = h: px(2) = 0: py(2) = h
  244.         CASE 4 'bottom right
  245.             px(0) = -w: py(0) = -h: px(3) = 0: py(3) = -h
  246.             px(1) = -w: py(1) = 0: px(2) = 0: py(2) = 0
  247.     END SELECT
  248.     sinr = SIN(angle / 57.2957795131): cosr = COS(angle / 57.2957795131)
  249.     FOR i = 0 TO 3
  250.         x2 = (px(i) * cosr + sinr * py(i)) + x: y2 = (py(i) * cosr - px(i) * sinr) + y
  251.         px(i) = x2: py(i) = y2
  252.     NEXT
  253.     _MAPTRIANGLE (0, 0)-(0, h - 1)-(w - 1, h - 1), Image TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
  254.     _MAPTRIANGLE (0, 0)-(w - 1, 0)-(w - 1, h - 1), Image TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
  255.  

Requires the image file attached below to work properly.
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #6 on: September 17, 2018, 05:13:42 PM »
And, I'm going to call that "it" for this first batch of stuff to share and post.  I'm off to get some food and spend some time with the wife.  Tomorrow, if I'm not busy doing anything else, I'll do some digging into the old folders and see what else is out there that I can share for those who might enjoy browsing a collection of weird and unusual junk.  :P

Feel free to comment, post any questions, or issues below.  A lot of this seems to have came from SDL days (back when I was still using SDL 0.954H), and I don't guarantee that any of it is 100% error free.  Heck, I don't even guarantee that this is the newest, bestest version of any of this stuff.   This is simply old programs which were sitting around in an aptly labeled QB64\SDL\Programs\STUFF folder, which I thought I'd test out and share for those who might be interested in any of it. 

A lot of this probably does have better, more up-to-date versions out there somewhere.  The issue would be finding where those versions might be hiding on my drive at....   ;D
« Last Edit: September 17, 2018, 05:17:17 PM by SMcNeill »
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline Pete

  • Forum Resident
  • Posts: 2567
  • Cuz I sez so, varmint!
Re: Steve's Oldies
« Reply #7 on: September 17, 2018, 05:15:40 PM »
How can RAINBOW TEXT be all that old? I don't have the newest QB64 version, because the line: A = _AUTODISPLAY: F = _FONT: D = _DEST was not accepted. I ran it and kept pressing the space bar, at which point it eventually crashed. I probably need the most updated version of QB64 to run what you call an oldie?

Anyway, I got some of the effects, and you're right, the statements are few for the output generated. That in itself is pretty cool. Now that I'm older I'm beginning to appreciated not having to code every little thing to get a desired result. In the beginning, it was fun, because you had to know your stuff to program but obviously the closer we can get to Star Trek computers the better our productivity, which is what computers were invented for in the first place, well, except for TOSHIBA computers, which were created to anchor small boats while in port.

OK, just saw you made a new pot for a screen image copy function. I have one of those from Fell I think, so I thought I'd try yours. I had to sub in LUCON fonts, I don't have oldenglish or whatever, anyway, I could not get it to pass the "test.bin" parameter to the file$ variable in the subroutine. I use CALL SUB, which is configured a bit differently, so I changed it a bit to this, and got it to work for me, cool!

file$ = "test.bin"
CALL ScreenGrab(file$)
_DELAY 2: CLS 'a pause to see the orignal screen, then clear it
_DELAY 2 ' so we can see the blanked screen
CALL ScreenRestore(file$) 'and the restored one

Anyway, Mr. awesome, you typed "original" wrong in the REM statement! Sorry, still working with my exorcist to stop channeling Clippy. :(

Pete

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #8 on: September 17, 2018, 05:21:12 PM »
How can RAINBOW TEXT be all that old?

It's an updated version of the old program, which I found and shared for folks who aren't still in the stone age like us.  :P

The actual SDL version would be this one, which runs MUCH slower (notice the direction variable is only 1 here, so 1/4th as much calculation, and it's STILL slow rotating the text).   I saw the updated version and posted it above, but this was the original, which should work for old dinosaurs like you and Clippy:

Code: QB64: [Select]
  1. fg& = _NEWIMAGE(1280, 720, 32)
  2. white& = _RGB32(255, 255, 255)
  3. SCREEN fg&
  4. PRINT "This is a demostration of a simple AlterText routine."
  5. PRINT "One Command is being used to generate all the text which follows."
  6. PRINT "Press any key to see some quick samples."
  7. junk$ = INPUT$(1)
  8.  
  9. text$ = "This is sample text"
  10. RainbowText text$, 0, 0, 380, 220, 0, 0, 0, 0, 0
  11. RainbowText text$, 0, 180, 380, 380, 0, 0, 100, 100, 100
  12. RainbowText text$, 0, 90, 300, 300, 0, 0, 150, 150, 150
  13. RainbowText text$, 0, 270, 460, 300, 0, 0, 50, 100, 150
  14. RainbowText text$, 1, 0, 100, 100, 0, 0, 10, 200, 0
  15. RainbowText text$, -1, 0, 300, 100, 0, 0, 200, 200, 0
  16. LOCATE 35, 40: PRINT "Press any key to watch what else you can do!"
  17.  
  18. junk$ = INPUT$(1)
  19.  
  20. COLOR , _RGB32(0, 0, 255)
  21. direction = 1
  22. 'direction = 10
  23.     CLS
  24.     i = i + direction
  25.     RainbowText text$, 0, i, 500, 500, 0, 0, r, g, b
  26.     'RainbowText text$, 0, i, 200, 200, _RGB32(255, 0, 0), _RGB32(255, 255, 0)
  27.     IF i > 360 OR i < -360 THEN direction = -direction
  28. LOCATE 10, 10: PRINT "HA!  Rotating text, and all from 1 simple routine."
  29.  
  30.  
  31.  
  32.  
  33.     f& = _LOADFONT("times.ttf", 100)
  34.     _FONT f&
  35.     RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b
  36.  
  37.  
  38.  
  39.  
  40. SUB RainbowText (text$, slant%, angle%, x%, y%, font&, b&, r, g, b)
  41.     dc& = _DEFAULTCOLOR: bg& = _BACKGROUNDCOLOR
  42.     slant% = slant% + 1 'This keeps slant 0 as neutral
  43.     length% = _PRINTWIDTH(text$): height% = _FONTHEIGHT
  44.     bgi& = _NEWIMAGE(length%, height%, 32)
  45.     _DEST bgi&
  46.     IF font& <> 0 THEN _FONT font&
  47.     COLOR _RGB32(255, 255, 255), b&
  48.     _PRINTSTRING (0, 0), text$
  49.     TLC$ = "BL" + STR$(length% \ 2) + "BU" + STR$(height% \ 2)
  50.     RET$ = "BD BL" + STR$(length%)
  51.     _SOURCE bgi&
  52.     _DEST 0
  53.     DRAW "BM" + STR$(x%) + "," + STR$(y%) + "TA=" + VARPTR$(angle%) + TLC$
  54.     FOR y = 0 TO height% - slant%
  55.         FOR x = 0 TO length% - slant%
  56.             IF POINT(x, y) <> b& THEN
  57.                 r = r + 5
  58.                 IF r > 255 THEN r = 0: g = g + 5
  59.                 IF g > 255 THEN g = 0: b = b + 5
  60.                 IF b > 255 THEN b = 0: r = 0
  61.                 DRAW "C" + STR$(_RGB32(r, g, b)) + "R1" 'color and DRAW each pixel
  62.             ELSE
  63.                 DRAW "B R1" 'color and DRAW each pixel
  64.             END IF
  65.         NEXT
  66.         DRAW RET$
  67.     NEXT
  68.     _FREEIMAGE bgi&: IF font& <> 0 THEN _FONT 16: _FREEFONT font&
  69.     COLOR dc&, bg&
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline Pete

  • Forum Resident
  • Posts: 2567
  • Cuz I sez so, varmint!
Re: Steve's Oldies
« Reply #9 on: September 17, 2018, 05:39:01 PM »
This line crashes my two GL versions:

RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b

But it does run in my older SDL version, albeit the rotating text is slower, as you indicated. I'm glad the SDL version displays the RainbowText text line. It was my favorite of the demo.

Now if you will excuse me, there's a large meteor shower coming my way, and I wouldn't want to miss it.

Pete


Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3572
    • Steve’s QB64 Archive Forum
Re: Steve's Oldies
« Reply #10 on: September 17, 2018, 05:44:28 PM »
This line crashes my two GL versions:

RainbowText text$, 0, 0, 500, 200, f&, 0, r, g, b

But it does run in my older SDL version, albeit the rotating text is slower, as you indicated. I'm glad the SDL version displays the RainbowText text line. It was my favorite of the demo.

Now if you will excuse me, there's a large meteor shower coming my way, and I wouldn't want to miss it.

Pete

Does it not find the font?  I'm kinda wondering what the crash issue might be with it.  It works here, for me, in SDL up...
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline Pete

  • Forum Resident
  • Posts: 2567
  • Cuz I sez so, varmint!
Re: Steve's Oldies
« Reply #11 on: September 17, 2018, 07:01:13 PM »
I already thought about the font possibility, too; so I searched for the direct path to my lucon.ttf path, and placed the absolute pathway in the code, and it worked in my GL versions.

C:\Windows\winsxs\amd64_microsoft-windows-f..etype-lucidaconsole_31bf3856ad364e35_6.1.7600.16385_none_(AND SO ON AND SO FORTH, GEESH!)

I think I have excluded some of the fonts packed with various QB version, so that's probably the problem I was experiencing.

Pete