Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.


Messages - Junior Librarian

Pages: [1] 2
1
2D/3D Graphics / Pi-in-the-Sky Graphics Demonstration Program (with 3D) by Qwerkey
« on: January 15, 2022, 07:38:31 am »
Pi-in-the-Sky Graphics Demonstration

Author: @Qwerkey
Source: qb64.org Forum
URL: https://qb64forum.alephc.xyz//index.php?topic=1969.0
Version: 15/01/22

Description:
This is a program which demonstrates the amazing graphics capabilities of QB64, using simple coding techniques and without resorting to the complexities of Open_GL.  Impressive 3D effects can be obtained using the QB64 _MAPTRIANGLE statement: the 3D _MAPTRIANGLE method gives a convincing 3D display along with perspective.

The program features a number of animations (some 2D and some 3D) enhanced with accompanying audio.  There is no interaction with the user, and the running display is an entertaining series of whimsical tableaux.  The program takes about 10 minutes before repeating.

You will need to go to the URL above to download the program.



screenshot.jpg

2
Interpreters / Symbolic Instruction Code Kit by Erik Jon Oredson
« on: December 27, 2021, 11:39:43 am »
Symbolic Instruction Code Kit (S.I.C.K.) Updated 2022-01-17

Author: @eoredson (eoredson@gmail.com)
URL: https://qb64forum.alephc.xyz/index.php?topic=4500.0
Version: v64.0a r5.5a

Description:
The Symbolic Instruction Code Kit, which contains a QB64 program named SIC64.BAS
and several smaller utility programs. The source code is public domain and can be
found on several sites, including, www.filegate.net and www.keepandshare.com

This program uses a recursive descent parser to interpret a psuedo-basic language
written in a line number oriented fashion and can be used for small programming chores.

The archive also contains some further imbedded .zip files which contain several
QB64 sample programs, and some .SIC programs which are used by the SIC engine.

Source Code:
See download(s) below, or follow this link:
https://bit.ly/EriksSICK

 

Commands:
Code: QB64: [Select]
  1. ENDIF  END IF  STOP  REM  MID$  LEFT$  RIGHT$  PRINT #  DPRINT
  2.  LPRINT USING  SPRINT  UPRINT  INPUT;  FORIF  FOR  NEXTIF  NEXT  CONTINUE FORIF  CONTINUE FOR
  3.  EXIT FORIF  EXIT FOR  DO UNTIL  LOOP WHILE  EXIT DO  CONTINUE DO  GOTO  GOSUB  RETURN  DO WHILE
  4.  DO  OFF  IF  ELSEIF  CASEIF ELSE  CASEIF  SELECT CASE  END SELECTIF  BEEP  SOUND
  5.  COLOR  LOCATE  CLS  SCREEN  WIDTH  WRITE #  LINE INPUT;  LINE INPUT #  INPUT #  WEND
  6.  WHILE  CONTINUE WHILE  EXIT WHILE  ELSE  LOOP UNTIL  LOOPIF  END LOOPIF  EXIT LOOPIF  LOOP  RANDOMIZE
  7.  POKE  INT86  DEFSEG  ABSOLUTE  OUT  WAIT  SLEEP  PAUSE  SELECTIF CASE  END SELECT
  8.  CASE ELSE  CASE  CONTINUE LOOPIF  END  CLEAR  SYSTEM  SWAP  ERROR  ON ERROR GOTO  ON ERROR RESUME PREVIOUS
  9.  ON ERROR RESUME SAME  ON ERROR RESUME NEXT  ON ERROR STOP  RESUME PREVIOUS  RESUME SAME  RESUME NEXT  RESUME  ON  DATE$  TIME$
  10.  CHDRIVE  CD  CHDIR  MD  MKDIR  RD  RMDIR  KILL  DELETE  RENAME
  11.  NAME  SHELL  CHAIN  LET  CLOSE #  OPEN #  FIELD #  WRITE  PRINT USING  INPUT
  12.  LINE INPUT  LSET #  RSET #  PUT #  GET #  READ #  DATA  READ  RESTORE  CIRCLE STEP
  15.  PSET  PRESET  GET  PUT  DIM  COMMON  DECLARE  LOCK #  UNLOCK #  PRINT
  16.  LPRINT  TRIANGLE  POLYGON

SICK.png


3
Utilities / Embedding files in programs (FileToDATA convertor) by RhoSigma
« on: October 31, 2021, 06:06:52 am »
Embedding files in programs (FileToDATA convertor)

Author: @RhoSigma
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=790.0
Version: October 04 2021


Description:
These two programs I use a lot.  These goodies got an complete overhaul and are now using the LZW packer/unpacker, which I've released. So this is a good opportunity to make it available again for everybody.  MakeDATA.bas Create a DATA block out of the given file, so you can embed it in your program and write it back when needed.  The DATAs are written into a .bm file.   MakeCARR.bas will do the whole thing in an array on C/C++ level, rather then in DATAs on the QB64 level. Although it's handling is a bit more tricky, as you get not only a .bm file, but also a .h file, and both must match (ie. the DECLARE LIBRARY path in the .bm must point to the .h), this approach has several advantages.

Both of the following tools require the 'lzwpacker.bm' file.

The .bm file is to be found in the author's Libraries Collection https://www.qb64.org/forum/index.php?topic=809

Source Code MakeDATA.bas:
Code: QB64: [Select]
  1.     '+---------------+---------------------------------------------------+
  2.     '| ###### ###### |     .--. .         .-.                            |
  3.     '| ##  ## ##   # |     |   )|        (   ) o                         |
  4.     '| ##  ##  ##    |     |--' |--. .-.  `-.  .  .-...--.--. .-.        |
  5.     '| ######   ##   |     |  \ |  |(   )(   ) | (   ||  |  |(   )       |
  6.     '| ##      ##    |     '   `'  `-`-'  `-'-' `-`-`|'  '  `-`-'`-      |
  7.     '| ##     ##   # |                            ._.'                   |
  8.     '| ##     ###### |  Sources & Documents placed in the Public Domain. |
  9.     '+---------------+---------------------------------------------------+
  10.     '|                                                                   |
  11.     '| === MakeDATA.bas ===                                              |
  12.     '|                                                                   |
  13.     '| == Create a DATA block out of the given file, so you can embed it |
  14.     '| == in your program and write it back when needed.                 |
  15.     '|                                                                   |
  16.     '| == The DATAs are written into a .bm file together with a ready to |
  17.     '| == use write back FUNCTION. You just $INCLUDE this .bm file into  |
  18.     '| == your program and call the write back FUNCTION somewhere.       |
  19.     '|                                                                   |
  20.     '| == This program needs the 'lzwpacker.bm' file available from the  |
  21.     '| == Libraries Collection here:                                     |
  22.     '| ==      https://www.qb64.org/forum/index.php?topic=809            |
  23.     '| == as it will try to pack the given file to keep the DATA block   |
  24.     '| == as small as possible. If compression is successful, then your  |
  25.     '| == program also must $INCLUDE 'lzwpacker.bm' to be able to unpack |
  26.     '| == the file data again for write back. MakeDATA.bas is printing   |
  27.     '| == a reminder message in such a case.                             |
  28.     '|                                                                   |
  29.     '+-------------------------------------------------------------------+
  30.     '| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
  31.     '| Find me in the QB64 Forum or mail to support&rhosigma-cw.net for  |
  32.     '| any questions or suggestions. Thanx for your interest in my work. |
  33.     '+-------------------------------------------------------------------+
  34.      
  35.     '--- if you wish, set any default paths, end with a backslash ---
  36.     srcPath$ = "" 'source path
  37.     tarPath$ = "" 'target path
  38.     '-----
  39.     IF srcPath$ <> "" THEN
  40.         COLOR 15: PRINT "Default source path: ": COLOR 7: PRINT srcPath$: PRINT
  41.     END IF
  42.     IF tarPath$ <> "" THEN
  43.         COLOR 15: PRINT "Default target path: ": COLOR 7: PRINT tarPath$: PRINT
  44.     END IF
  45.      
  46.     '--- collect inputs (relative paths allowed, based on default paths) ---
  47.     source:
  48.     LINE INPUT "Source Filename: "; src$ 'any file you want to put into DATAs
  49.     IF src$ = "" GOTO source
  50.     target:
  51.     LINE INPUT "Target Basename: "; tar$ 'write stuff into this file (.bm is added)
  52.     IF tar$ = "" GOTO target
  53.     '-----
  54.     ON ERROR GOTO abort
  55.     OPEN "I", #1, srcPath$ + src$: CLOSE #1 'file exist check
  56.     OPEN "O", #2, tarPath$ + tar$ + ".bm": CLOSE #2 'path exist check
  57.     ON ERROR GOTO 0
  58.      
  59.     '--- separate source filename part ---
  60.     FOR po% = LEN(src$) TO 1 STEP -1
  61.         IF MID$(src$, po%, 1) = "\" OR MID$(src$, po%, 1) = "/" THEN
  62.             srcName$ = MID$(src$, po% + 1)
  63.             EXIT FOR
  64.         ELSEIF po% = 1 THEN
  65.             srcName$ = src$
  66.         END IF
  67.     NEXT po%
  68.     '--- separate target filename part ---
  69.     FOR po% = LEN(tar$) TO 1 STEP -1
  70.         IF MID$(tar$, po%, 1) = "\" OR MID$(tar$, po%, 1) = "/" THEN
  71.             tarName$ = MID$(tar$, po% + 1)
  72.             EXIT FOR
  73.         ELSEIF po% = 1 THEN
  74.             tarName$ = tar$
  75.         END IF
  76.     NEXT po%
  77.     MID$(tarName$, 1, 1) = UCASE$(MID$(tarName$, 1, 1)) 'capitalize 1st letter
  78.      
  79.     '--- init ---
  80.     OPEN "B", #1, srcPath$ + src$
  81.     filedata$ = SPACE$(LOF(1))
  82.     GET #1, , filedata$
  83.     CLOSE #1
  84.     rawdata$ = LzwPack$(filedata$, 20)
  85.     IF rawdata$ <> "" THEN
  86.         OPEN "O", #1, tarPath$ + tar$ + ".lzw"
  87.         CLOSE #1
  88.         OPEN "B", #1, tarPath$ + tar$ + ".lzw"
  89.         PUT #1, , rawdata$
  90.         CLOSE #1
  91.         packed% = -1
  92.         OPEN "B", #1, tarPath$ + tar$ + ".lzw"
  93.     ELSE
  94.         packed% = 0
  95.         OPEN "B", #1, srcPath$ + src$
  96.     END IF
  97.     fl& = LOF(1)
  98.     cntL& = INT(fl& / 32)
  99.     cntB& = (fl& - (cntL& * 32))
  100.      
  101.     '--- .bm include file ---
  102.     OPEN "O", #2, tarPath$ + tar$ + ".bm"
  103.     PRINT #2, "'============================================================"
  104.     PRINT #2, "'=== This file was created with MakeDATA.bas by RhoSigma, ==="
  105.     PRINT #2, "'=== you must $INCLUDE this at the end of your program.   ==="
  106.     IF packed% THEN
  107.         PRINT #2, "'=== ---------------------------------------------------- ==="
  108.         PRINT #2, "'=== If your program is NOT a GuiTools based application, ==="
  109.         PRINT #2, "'=== then it must also $INCLUDE: 'lzwpacker.bm' available ==="
  110.         PRINT #2, "'=== from the Libraries Collection here:                  ==="
  111.         PRINT #2, "'===    https://www.qb64.org/forum/index.php?topic=809    ==="
  112.     END IF
  113.     PRINT #2, "'============================================================"
  114.     PRINT #2, ""
  115.     '--- writeback function ---
  116.     PRINT #2, "'"; STRING$(LEN(tarName$) + 18, "-")
  117.     PRINT #2, "'--- Write"; tarName$; "Data$ ---"
  118.     PRINT #2, "'"; STRING$(LEN(tarName$) + 18, "-")
  119.     PRINT #2, "' This function will write the DATAs you've created with MakeDATA.bas"
  120.     PRINT #2, "' back to disk and so it rebuilds the original file."
  121.     PRINT #2, "'"
  122.     PRINT #2, "' After the writeback call, only use the returned realFile$ to access the"
  123.     PRINT #2, "' written file. It's your given path, but with an maybe altered filename"
  124.     PRINT #2, "' (number added) in order to avoid the overwriting of an already existing"
  125.     PRINT #2, "' file with the same name in the given location."
  126.     PRINT #2, "'----------"
  127.     PRINT #2, "' SYNTAX:"
  128.     PRINT #2, "'   realFile$ = Write"; tarName$; "Data$ (wantFile$)"
  129.     PRINT #2, "'----------"
  130.     PRINT #2, "' INPUTS:"
  131.     PRINT #2, "'   --- wantFile$ ---"
  132.     PRINT #2, "'    The filename you would like to write the DATAs to, can contain"
  133.     PRINT #2, "'    a full or relative path."
  134.     PRINT #2, "'----------"
  135.     PRINT #2, "' RESULT:"
  136.     PRINT #2, "'   --- realFile$ ---"
  137.     PRINT #2, "'    - On success this is the path and filename finally used after all"
  138.     PRINT #2, "'      applied checks, use only this returned filename to access the"
  139.     PRINT #2, "'      written file."
  140.     PRINT #2, "'    - On failure this function will panic with the appropriate runtime"
  141.     PRINT #2, "'      error code which you may trap and handle as needed with your own"
  142.     PRINT #2, "'      ON ERROR GOTO... handler."
  143.     PRINT #2, "'---------------------------------------------------------------------"
  144.     PRINT #2, "FUNCTION Write"; tarName$; "Data$ (file$)"
  145.     PRINT #2, "'--- option _explicit requirements ---"
  146.     PRINT #2, "DIM po%, body$, ext$, num%, numL&, numB&, rawdata$, stroffs&, i&, dat&, ff%";
  147.     IF packed% THEN PRINT #2, ", filedata$": ELSE PRINT #2, ""
  148.     PRINT #2, "'--- separate filename body & extension ---"
  149.     PRINT #2, "FOR po% = LEN(file$) TO 1 STEP -1"
  150.     PRINT #2, "    IF MID$(file$, po%, 1) = "; CHR$(34); "."; CHR$(34); " THEN"
  151.     PRINT #2, "        body$ = LEFT$(file$, po% - 1)"
  152.     PRINT #2, "        ext$ = MID$(file$, po%)"
  153.     PRINT #2, "        EXIT FOR"
  154.     PRINT #2, "    ELSEIF MID$(file$, po%, 1) = "; CHR$(34); "\"; CHR$(34); " OR MID$(file$, po%, 1) = "; CHR$(34); "/"; CHR$(34); " OR po% = 1 THEN"
  155.     PRINT #2, "        body$ = file$"
  156.     PRINT #2, "        ext$ = "; CHR$(34); CHR$(34)
  157.     PRINT #2, "        EXIT FOR"
  158.     PRINT #2, "    END IF"
  159.     PRINT #2, "NEXT po%"
  160.     PRINT #2, "'--- avoid overwriting of existing files ---"
  161.     PRINT #2, "num% = 1"
  162.     PRINT #2, "WHILE _FILEEXISTS(file$)"
  163.     PRINT #2, "    file$ = body$ + "; CHR$(34); "("; CHR$(34); " + LTRIM$(STR$(num%)) + "; CHR$(34); ")"; CHR$(34); " + ext$"
  164.     PRINT #2, "    num% = num% + 1"
  165.     PRINT #2, "WEND"
  166.     PRINT #2, "'--- write DATAs ---"
  167.     PRINT #2, "RESTORE "; tarName$
  168.     PRINT #2, "READ numL&, numB&"
  169.     PRINT #2, "rawdata$ = SPACE$((numL& * 4) + numB&)"
  170.     PRINT #2, "stroffs& = 1"
  171.     PRINT #2, "FOR i& = 1 TO numL&"
  172.     PRINT #2, "    READ dat&"
  173.     PRINT #2, "    MID$(rawdata$, stroffs&, 4) = MKL$(dat&)"
  174.     PRINT #2, "    stroffs& = stroffs& + 4"
  175.     PRINT #2, "NEXT i&"
  176.     PRINT #2, "IF numB& > 0 THEN"
  177.     PRINT #2, "    FOR i& = 1 TO numB&"
  178.     PRINT #2, "        READ dat&"
  179.     PRINT #2, "        MID$(rawdata$, stroffs&, 1) = CHR$(dat&)"
  180.     PRINT #2, "        stroffs& = stroffs& + 1"
  181.     PRINT #2, "    NEXT i&"
  182.     PRINT #2, "END IF"
  183.     PRINT #2, "ff% = FREEFILE"
  184.     PRINT #2, "OPEN file$ FOR OUTPUT AS ff%"
  185.     IF packed% THEN
  186.         PRINT #2, "CLOSE ff%"
  187.         PRINT #2, "filedata$ = LzwUnpack$(rawdata$)"
  188.         PRINT #2, "OPEN file$ FOR BINARY AS ff%"
  189.         PRINT #2, "PUT #ff%, , filedata$"
  190.     ELSE
  191.         PRINT #2, "PRINT #ff%, rawdata$;"
  192.     END IF
  193.     PRINT #2, "CLOSE ff%"
  194.     PRINT #2, "'--- set result ---"
  195.     PRINT #2, "Write"; tarName$; "Data$ = file$"
  196.     PRINT #2, "EXIT FUNCTION"
  197.     PRINT #2, ""
  198.     PRINT #2, "'--- DATAs representing the contents of file "; srcName$
  199.     PRINT #2, "'---------------------------------------------------------------------"
  200.     PRINT #2, tarName$; ":"
  201.     '--- read LONGs ---
  202.     PRINT #2, "DATA "; LTRIM$(STR$(cntL& * 8)); ","; LTRIM$(STR$(cntB&))
  203.     tmpI$ = SPACE$(32)
  204.     FOR z& = 1 TO cntL&
  205.         GET #1, , tmpI$: offI% = 1
  206.         tmpO$ = "DATA " + STRING$(87, ","): offO% = 6
  207.         DO
  208.             tmpL& = CVL(MID$(tmpI$, offI%, 4)): offI% = offI% + 4
  209.             MID$(tmpO$, offO%, 10) = "&H" + RIGHT$("00000000" + HEX$(tmpL&), 8)
  210.             offO% = offO% + 11
  211.         LOOP UNTIL offO% > 92
  212.         PRINT #2, tmpO$
  213.     NEXT z&
  214.     '--- read remaining BYTEs ---
  215.     IF cntB& > 0 THEN
  216.         PRINT #2, "DATA ";
  217.         FOR x% = 1 TO cntB&
  218.             GET #1, , tmpB%%
  219.             PRINT #2, "&H" + RIGHT$("00" + HEX$(tmpB%%), 2);
  220.             IF x% <> 16 THEN
  221.                 IF x% <> cntB& THEN PRINT #2, ",";
  222.             ELSE
  223.                 IF x% <> cntB& THEN
  224.                     PRINT #2, ""
  225.                     PRINT #2, "DATA ";
  226.                 END IF
  227.             END IF
  228.         NEXT x%
  229.         PRINT #2, ""
  230.     END IF
  231.     PRINT #2, "END FUNCTION"
  232.     PRINT #2, ""
  233.     '--- ending ---
  234.     CLOSE #2
  235.     CLOSE #1
  236.      
  237.     '--- finish message ---
  238.     COLOR 10: PRINT: PRINT "file successfully processed..."
  239.     COLOR 9: PRINT: PRINT "You must $INCLUDE the created file (target name + .bm extension) at"
  240.     PRINT "the end of your program and call the function 'Write"; tarName$; "Data$(...)'"
  241.     PRINT "in an appropriate place to write the file back to disk."
  242.     IF packed% THEN
  243.         COLOR 12: PRINT: PRINT "Your program must also $INCLUDE 'lzwpacker.bm' available from"
  244.         PRINT "the Libraries Collection here:"
  245.         PRINT "     https://www.qb64.org/forum/index.php?topic=809"
  246.         PRINT "to be able to write back the just processed file."
  247.         KILL tarPath$ + tar$ + ".lzw"
  248.     END IF
  249.     done:
  250.     COLOR 7
  251.     END
  252.     '--- error handler ---
  253.     abort:
  254.     COLOR 12: PRINT: PRINT "something is wrong with path/file access, check your inputs and try again..."
  255.     RESUME done
  256.      
  257.     '$INCLUDE: 'QB64Library\LZW-Compress\lzwpacker.bm'
  258.      
  259.      
  260.  


Source Code MakeCARR.bas:
Code: QB64: [Select]
  1.     '+---------------+---------------------------------------------------+
  2.     '| ###### ###### |     .--. .         .-.                            |
  3.     '| ##  ## ##   # |     |   )|        (   ) o                         |
  4.     '| ##  ##  ##    |     |--' |--. .-.  `-.  .  .-...--.--. .-.        |
  5.     '| ######   ##   |     |  \ |  |(   )(   ) | (   ||  |  |(   )       |
  6.     '| ##      ##    |     '   `'  `-`-'  `-'-' `-`-`|'  '  `-`-'`-      |
  7.     '| ##     ##   # |                            ._.'                   |
  8.     '| ##     ###### |  Sources & Documents placed in the Public Domain. |
  9.     '+---------------+---------------------------------------------------+
  10.     '|                                                                   |
  11.     '| === MakeCARR.bas ===                                              |
  12.     '|                                                                   |
  13.     '| == Create a C/C++ array out of the given file, so you can embed   |
  14.     '| == it in your program and write it back when needed.              |
  15.     '|                                                                   |
  16.     '| == Two files are created, the .h file, which contains the array(s)|
  17.     '| == and some functions, and a respective .bm file which needs to   |
  18.     '| == be $INCLUDEd with your program and does provide the FUNCTION   |
  19.     '| == to write back the array(s) into any file. All used functions   |
  20.     '| == are standard library calls, no API calls are involved, so the  |
  21.     '| == writeback should work on all QB64 supported platforms.         |
  22.     '|                                                                   |
  23.     '| == Make sure to adjust the path for the .h file for your personal |
  24.     '| == needs in the created .bm files (DECLARE LIBRARY), if required. |
  25.     '| == You may specify default paths right below this header.         |
  26.     '|                                                                   |
  27.     '| == This program needs the 'lzwpacker.bm' file available from the  |
  28.     '| == Libraries Collection here:                                     |
  29.     '| ==      https://www.qb64.org/forum/index.php?topic=809            |
  30.     '| == as it will try to pack the given file to keep the array(s) as  |
  31.     '| == small as possible. If compression is successful, then your     |
  32.     '| == program also must $INCLUDE 'lzwpacker.bm' to be able to unpack |
  33.     '| == the file data again for write back. MakeCARR.bas is printing   |
  34.     '| == a reminder message in such a case.                             |
  35.     '|                                                                   |
  36.     '+-------------------------------------------------------------------+
  37.     '| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
  38.     '| Find me in the QB64 Forum or mail to support&rhosigma-cw.net for  |
  39.     '| any questions or suggestions. Thanx for your interest in my work. |
  40.     '+-------------------------------------------------------------------+
  41.      
  42.     '--- if you wish, set any default paths, end with a backslash ---
  43.     srcPath$ = "" 'source path
  44.     tarPath$ = "" 'target path
  45.     '-----
  46.     IF srcPath$ <> "" THEN
  47.         COLOR 15: PRINT "Default source path: ": COLOR 7: PRINT srcPath$: PRINT
  48.     END IF
  49.     IF tarPath$ <> "" THEN
  50.         COLOR 15: PRINT "Default target path: ": COLOR 7: PRINT tarPath$: PRINT
  51.     END IF
  52.      
  53.     '--- collect inputs (relative paths allowed, based on default paths) ---
  54.     source:
  55.     LINE INPUT "Source Filename: "; src$ 'any file you want to put into a C/C++ array
  56.     IF src$ = "" GOTO source
  57.     target:
  58.     LINE INPUT "Target Basename: "; tar$ 'write stuff into this file(s) (.h/.bm is added)
  59.     IF tar$ = "" GOTO target
  60.     '-----
  61.     ON ERROR GOTO abort
  62.     OPEN "I", #1, srcPath$ + src$: CLOSE #1 'file exist check
  63.     OPEN "O", #2, tarPath$ + tar$ + ".bm": CLOSE #2 'path exist check
  64.     ON ERROR GOTO 0
  65.      
  66.     '--- separate source filename part ---
  67.     FOR po% = LEN(src$) TO 1 STEP -1
  68.         IF MID$(src$, po%, 1) = "\" OR MID$(src$, po%, 1) = "/" THEN
  69.             srcName$ = MID$(src$, po% + 1)
  70.             EXIT FOR
  71.         ELSEIF po% = 1 THEN
  72.             srcName$ = src$
  73.         END IF
  74.     NEXT po%
  75.     '--- separate target filename part ---
  76.     FOR po% = LEN(tar$) TO 1 STEP -1
  77.         IF MID$(tar$, po%, 1) = "\" OR MID$(tar$, po%, 1) = "/" THEN
  78.             tarName$ = MID$(tar$, po% + 1)
  79.             EXIT FOR
  80.         ELSEIF po% = 1 THEN
  81.             tarName$ = tar$
  82.         END IF
  83.     NEXT po%
  84.     MID$(tarName$, 1, 1) = UCASE$(MID$(tarName$, 1, 1)) 'capitalize 1st letter
  85.      
  86.     '---------------------------------------------------------------------
  87.     ' Depending on the source file's size, one or more array(s) are
  88.     ' created. This is because some C/C++ compilers seem to have problems
  89.     ' with arrays with more than 65535 elements. This does not affect the
  90.     ' write back, as the write function will take this behavior into account.
  91.     '---------------------------------------------------------------------
  92.      
  93.     '--- init ---
  94.     OPEN "B", #1, srcPath$ + src$
  95.     filedata$ = SPACE$(LOF(1))
  96.     GET #1, , filedata$
  97.     CLOSE #1
  98.     rawdata$ = LzwPack$(filedata$, 20)
  99.     IF rawdata$ <> "" THEN
  100.         OPEN "O", #1, tarPath$ + tar$ + ".lzw"
  101.         CLOSE #1
  102.         OPEN "B", #1, tarPath$ + tar$ + ".lzw"
  103.         PUT #1, , rawdata$
  104.         CLOSE #1
  105.         packed% = -1
  106.         OPEN "B", #1, tarPath$ + tar$ + ".lzw"
  107.     ELSE
  108.         packed% = 0
  109.         OPEN "B", #1, srcPath$ + src$
  110.     END IF
  111.     fl& = LOF(1)
  112.     cntL& = INT(fl& / 32)
  113.     cntV& = INT(cntL& / 8180)
  114.     cntB& = (fl& - (cntL& * 32))
  115.      
  116.     '--- .h include file ---
  117.     OPEN "O", #2, tarPath$ + tar$ + ".h"
  118.     PRINT #2, "// ============================================================"
  119.     PRINT #2, "// === This file was created with MakeCARR.bas by RhoSigma, ==="
  120.     PRINT #2, "// === use it in conjunction with its respective .bm file.  ==="
  121.     PRINT #2, "// ============================================================"
  122.     PRINT #2, ""
  123.     PRINT #2, "// --- Array(s) representing the contents of file "; srcName$
  124.     PRINT #2, "// ---------------------------------------------------------------------"
  125.     '--- read LONGs ---
  126.     tmpI$ = SPACE$(32)
  127.     FOR vc& = 0 TO cntV&
  128.         IF vc& = cntV& THEN numL& = (cntL& MOD 8180): ELSE numL& = 8180
  129.         PRINT #2, "static const unsigned int32 "; tarName$; "L"; LTRIM$(STR$(vc&)); "[] = {"
  130.         PRINT #2, "    "; LTRIM$(STR$(numL& * 8)); ","
  131.         FOR z& = 1 TO numL&
  132.             GET #1, , tmpI$: offI% = 1
  133.             tmpO$ = "    " + STRING$(88, ","): offO% = 5
  134.             DO
  135.                 tmpL& = CVL(MID$(tmpI$, offI%, 4)): offI% = offI% + 4
  136.                 MID$(tmpO$, offO%, 10) = "0x" + RIGHT$("00000000" + HEX$(tmpL&), 8)
  137.                 offO% = offO% + 11
  138.             LOOP UNTIL offO% > 92
  139.             IF z& < numL& THEN PRINT #2, tmpO$: ELSE PRINT #2, LEFT$(tmpO$, 91)
  140.         NEXT z&
  141.         PRINT #2, "};"
  142.         PRINT #2, ""
  143.     NEXT vc&
  144.     '--- read remaining BYTEs ---
  145.     IF cntB& > 0 THEN
  146.         PRINT #2, "static const unsigned int8 "; tarName$; "B[] = {"
  147.         PRINT #2, "    "; LTRIM$(STR$(cntB&)); ","
  148.         PRINT #2, "    ";
  149.         FOR x% = 1 TO cntB&
  150.             GET #1, , tmpB%%
  151.             PRINT #2, "0x" + RIGHT$("00" + HEX$(tmpB%%), 2);
  152.             IF x% <> 16 THEN
  153.                 IF x% <> cntB& THEN PRINT #2, ",";
  154.             ELSE
  155.                 IF x% <> cntB& THEN
  156.                     PRINT #2, ","
  157.                     PRINT #2, "    ";
  158.                 END IF
  159.             END IF
  160.         NEXT x%
  161.         PRINT #2, ""
  162.         PRINT #2, "};"
  163.         PRINT #2, ""
  164.     END IF
  165.     '--- some functions ---
  166.     PRINT #2, "// --- Saved full qualified output path and filename, so we've no troubles"
  167.     PRINT #2, "// --- when cleaning up, even if the current working folder was changed"
  168.     PRINT #2, "// --- during program runtime."
  169.     PRINT #2, "// ---------------------------------------------------------------------"
  170.     PRINT #2, "char "; tarName$; "Name[8192]; // it's a safe size for any current OS"
  171.     PRINT #2, ""
  172.     PRINT #2, "// --- Cleanup function to delete the written file, called by the atexit()"
  173.     PRINT #2, "// --- handler at program termination time, if requested by user."
  174.     PRINT #2, "// ---------------------------------------------------------------------"
  175.     PRINT #2, "void Kill"; tarName$; "Data(void)"
  176.     PRINT #2, "{"
  177.     PRINT #2, "    remove("; tarName$; "Name);"
  178.     PRINT #2, "}"
  179.     PRINT #2, ""
  180.     PRINT #2, "// --- Function to write the array(s) back into a file, will return the"
  181.     PRINT #2, "// --- full qualified output path and filename on success, otherwise an"
  182.     PRINT #2, "// --- empty string is returned (access/write errors, file truncated)."
  183.     PRINT #2, "// ---------------------------------------------------------------------"
  184.     PRINT #2, "const char *Write"; tarName$; "Data(const char *FileName, int16 AutoClean)"
  185.     PRINT #2, "{"
  186.     PRINT #2, "    FILE *han = NULL; // file handle"
  187.     PRINT #2, "    int32 num = NULL; // written elements"
  188.     PRINT #2, ""
  189.     PRINT #2, "    #ifdef QB64_WINDOWS"
  190.     PRINT #2, "    if (!_fullpath("; tarName$; "Name, FileName, 8192)) return "; CHR$(34); CHR$(34); ";"
  191.     PRINT #2, "    #else"
  192.     PRINT #2, "    if (!realpath(FileName, "; tarName$; "Name)) return "; CHR$(34); CHR$(34); ";"
  193.     PRINT #2, "    #endif"
  194.     PRINT #2, ""
  195.     PRINT #2, "    if (!(han = fopen("; tarName$; "Name, "; CHR$(34); "wb"; CHR$(34); "))) return "; CHR$(34); CHR$(34); ";"
  196.     PRINT #2, "    if (AutoClean) atexit(Kill"; tarName$; "Data);"
  197.     PRINT #2, ""
  198.     FOR vc& = 0 TO cntV&
  199.         PRINT #2, "    num = fwrite(&"; tarName$; "L"; LTRIM$(STR$(vc&)); "[1], 4, "; tarName$; "L"; LTRIM$(STR$(vc&)); "[0], han);"
  200.         PRINT #2, "    if (num != "; tarName$; "L"; LTRIM$(STR$(vc&)); "[0]) {fclose(han); return "; CHR$(34); CHR$(34); ";}"
  201.         PRINT #2, ""
  202.     NEXT vc&
  203.     IF cntB& > 0 THEN
  204.         PRINT #2, "    num = fwrite(&"; tarName$; "B[1], 1, "; tarName$; "B[0], han);"
  205.         PRINT #2, "    if (num != "; tarName$; "B[0]) {fclose(han); return "; CHR$(34); CHR$(34); ";}"
  206.         PRINT #2, ""
  207.     END IF
  208.     PRINT #2, "    fclose(han);"
  209.     PRINT #2, "    return "; tarName$; "Name;"
  210.     PRINT #2, "}"
  211.     PRINT #2, ""
  212.     '--- ending ---
  213.     CLOSE #2
  214.     CLOSE #1
  215.      
  216.     '--- .bm include file ---
  217.     OPEN "O", #2, tarPath$ + tar$ + ".bm"
  218.     PRINT #2, "'============================================================"
  219.     PRINT #2, "'=== This file was created with MakeCARR.bas by RhoSigma, ==="
  220.     PRINT #2, "'=== you must $INCLUDE this at the end of your program.   ==="
  221.     IF packed% THEN
  222.         PRINT #2, "'=== ---------------------------------------------------- ==="
  223.         PRINT #2, "'=== If your program is NOT a GuiTools based application, ==="
  224.         PRINT #2, "'=== then it must also $INCLUDE: 'lzwpacker.bm' available ==="
  225.         PRINT #2, "'=== from the Libraries Collection here:                  ==="
  226.         PRINT #2, "'===    https://www.qb64.org/forum/index.php?topic=809    ==="
  227.     END IF
  228.     PRINT #2, "'============================================================"
  229.     PRINT #2, ""
  230.     PRINT #2, "'-----------------"
  231.     PRINT #2, "'--- Important ---"
  232.     PRINT #2, "'-----------------"
  233.     PRINT #2, "' If you need to move around this .bm file and its respective .h file"
  234.     PRINT #2, "' to fit in your project, then make sure the path in the DECLARE LIBRARY"
  235.     PRINT #2, "' statement below does match the actual .h file location. It's best to"
  236.     PRINT #2, "' specify a relative path assuming your QB64 installation folder as root."
  237.     PRINT #2, "'---------------------------------------------------------------------"
  238.     PRINT #2, ""
  239.     '--- writeback function ---
  240.     PRINT #2, "'"; STRING$(LEN(tarName$) + 19, "-")
  241.     PRINT #2, "'--- Write"; tarName$; "Array$ ---"
  242.     PRINT #2, "'"; STRING$(LEN(tarName$) + 19, "-")
  243.     PRINT #2, "' This function will write the array(s) you've created with MakeCARR.bas"
  244.     PRINT #2, "' back to disk and so it rebuilds the original file."
  245.     PRINT #2, "'"
  246.     PRINT #2, "' After the writeback call, only use the returned realFile$ to access the"
  247.     PRINT #2, "' written file. It's the full qualified absolute path and filename, which"
  248.     PRINT #2, "' is made by expanding your maybe given relative path and an maybe altered"
  249.     PRINT #2, "' filename (number added) in order to avoid the overwriting of an already"
  250.     PRINT #2, "' existing file with the same name in the given location. By this means"
  251.     PRINT #2, "' you'll always have safe access to the file, no matter how your current"
  252.     PRINT #2, "' working folder changes during runtime."
  253.     PRINT #2, "'"
  254.     PRINT #2, "' If you wish, the written file can automatically be deleted for you when"
  255.     PRINT #2, "' your program will end, so you don't need to do the cleanup yourself."
  256.     PRINT #2, "'----------"
  257.     PRINT #2, "' SYNTAX:"
  258.     PRINT #2, "'   realFile$ = Write"; tarName$; "Array$ (wantFile$, autoDel%)"
  259.     PRINT #2, "'----------"
  260.     PRINT #2, "' INPUTS:"
  261.     PRINT #2, "'   --- wantFile$ ---"
  262.     PRINT #2, "'    The filename you would like to write the array(s) to, can contain"
  263.     PRINT #2, "'    a full or relative path."
  264.     PRINT #2, "'   --- autoDel% ---"
  265.     PRINT #2, "'    Shows whether you want the auto cleanup (see description above) at"
  266.     PRINT #2, "'    the program end or not (-1 = delete file, 0 = don't delete file)."
  267.     PRINT #2, "'----------"
  268.     PRINT #2, "' RESULT:"
  269.     PRINT #2, "'   --- realFile$ ---"
  270.     PRINT #2, "'    - On success this is the full qualified path and filename finally"
  271.     PRINT #2, "'      used after all applied checks, use only this returned filename"
  272.     PRINT #2, "'      to access the written file."
  273.     PRINT #2, "'    - On failure (write/access) this will be an empty string, so you"
  274.     PRINT #2, "'      should check for this before trying to access/open the file."
  275.     PRINT #2, "'---------------------------------------------------------------------"
  276.     PRINT #2, "FUNCTION Write"; tarName$; "Array$ (file$, clean%)"
  277.     PRINT #2, "'--- declare C/C++ function ---"
  278.     PRINT #2, "DECLARE LIBRARY "; CHR$(34); tarPath$; tar$; CHR$(34); " 'Do not add .h here !!"
  279.     PRINT #2, "    FUNCTION Write"; tarName$; "Data$ (FileName$, BYVAL AutoClean%)"
  280.     PRINT #2, "END DECLARE"
  281.     PRINT #2, "'--- option _explicit requirements ---"
  282.     PRINT #2, "DIM po%, body$, ext$, num%";
  283.     IF packed% THEN PRINT #2, ", real$, ff%, rawdata$, filedata$": ELSE PRINT #2, ""
  284.     PRINT #2, "'--- separate filename body & extension ---"
  285.     PRINT #2, "FOR po% = LEN(file$) TO 1 STEP -1"
  286.     PRINT #2, "    IF MID$(file$, po%, 1) = "; CHR$(34); "."; CHR$(34); " THEN"
  287.     PRINT #2, "        body$ = LEFT$(file$, po% - 1)"
  288.     PRINT #2, "        ext$ = MID$(file$, po%)"
  289.     PRINT #2, "        EXIT FOR"
  290.     PRINT #2, "    ELSEIF MID$(file$, po%, 1) = "; CHR$(34); "\"; CHR$(34); " OR MID$(file$, po%, 1) = "; CHR$(34); "/"; CHR$(34); " OR po% = 1 THEN"
  291.     PRINT #2, "        body$ = file$"
  292.     PRINT #2, "        ext$ = "; CHR$(34); CHR$(34)
  293.     PRINT #2, "        EXIT FOR"
  294.     PRINT #2, "    END IF"
  295.     PRINT #2, "NEXT po%"
  296.     PRINT #2, "'--- avoid overwriting of existing files ---"
  297.     PRINT #2, "num% = 1"
  298.     PRINT #2, "WHILE _FILEEXISTS(file$)"
  299.     PRINT #2, "    file$ = body$ + "; CHR$(34); "("; CHR$(34); " + LTRIM$(STR$(num%)) + "; CHR$(34); ")"; CHR$(34); " + ext$"
  300.     PRINT #2, "    num% = num% + 1"
  301.     PRINT #2, "WEND"
  302.     PRINT #2, "'--- write array & set result ---"
  303.     IF NOT packed% THEN
  304.         PRINT #2, "Write"; tarName$; "Array$ = Write"; tarName$; "Data$(file$ + CHR$(0), clean%)"
  305.     ELSE
  306.         PRINT #2, "real$ = Write"; tarName$; "Data$(file$ + CHR$(0), clean%)"
  307.         PRINT #2, "IF real$ <> "; CHR$(34); CHR$(34); " THEN"
  308.         PRINT #2, "    ff% = FREEFILE"
  309.         PRINT #2, "    OPEN real$ FOR BINARY AS ff%"
  310.         PRINT #2, "    rawdata$ = SPACE$(LOF(ff%))"
  311.         PRINT #2, "    GET #ff%, , rawdata$"
  312.         PRINT #2, "    filedata$ = LzwUnpack$(rawdata$)"
  313.         PRINT #2, "    PUT #ff%, 1, filedata$"
  314.         PRINT #2, "    CLOSE ff%"
  315.         PRINT #2, "END IF"
  316.         PRINT #2, "Write"; tarName$; "Array$ = real$"
  317.     END IF
  318.     PRINT #2, "END FUNCTION"
  319.     PRINT #2, ""
  320.     '--- ending ---
  321.     CLOSE #2
  322.      
  323.     '--- finish message ---
  324.     COLOR 10: PRINT: PRINT "file successfully processed..."
  325.     COLOR 9: PRINT: PRINT "You must $INCLUDE the created file (target name + .bm extension) at"
  326.     PRINT "the end of your program and call the function 'Write"; tarName$; "Array$(...)'"
  327.     PRINT "in an appropriate place to write the file back to disk."
  328.     IF packed% THEN
  329.         COLOR 12: PRINT: PRINT "Your program must also $INCLUDE 'lzwpacker.bm' available from"
  330.         PRINT "the Libraries Collection here:"
  331.         PRINT "     https://www.qb64.org/forum/index.php?topic=809"
  332.         PRINT "to be able to write back the just processed file."
  333.         KILL tarPath$ + tar$ + ".lzw"
  334.     END IF
  335.     done:
  336.     COLOR 7
  337.     END
  338.     '--- error handler ---
  339.     abort:
  340.     COLOR 12: PRINT: PRINT "something is wrong with path/file access, check your inputs and try again..."
  341.     RESUME done
  342.      
  343.     '$INCLUDE: 'QB64Library\LZW-Compress\lzwpacker.bm'
  344.      
  345.      
  346.  

                                                                                                                                         (162 downloads previously)

4
Games / Pipes Puzzle by Dav & bplus
« on: September 30, 2021, 06:06:46 am »
Pipes Puzzle

Author: @Dav
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=4232.0
Version: 1

Description:
This is a Maze puzzler.  To play you click on the pipes to rotate them and connect them to the flow, making the pipes all connected and one color.

Source Code (for reference only: use the zip file):
Code: QB64: [Select]
  1.     '================
  2.     'PIPES.BAS v1.0
  3.     '================
  4.     'Connect the pipes puzzle game
  5.     'Coded by Dav for QB64-GL 1.5 in SEP/2021
  6.      
  7.     'NOTE: Formally called MazeConnect Prototype on the forum.
  8.      
  9.     '============
  10.     'HOW TO PLAY:
  11.     '============
  12.      
  13.     'Click on pipes to rotate them and connect them as one.
  14.     'Object is to make all pipes on board connected to leader.
  15.     'Top left pipe is always on, the leader, so start from it.
  16.     'When pipes are all connected, you advance to next level.
  17.     'There are currently 20 levels.  ESC key exits game.
  18.      
  19.     'SPACE  = restarts level
  20.     'RIGHT ARROW = goto next level
  21.     'LEFT ARROW = go back a level
  22.     'ESC = Quits game
  23.      
  24.     '         VVVVVVV     blus fixed next line to work from his downloaded zip
  25.     $ExeIcon:'.\icon.ico'
  26.     _Icon
  27.      
  28.      
  30.      
  31.     Dim Shared GridSize, Level, MaxLevel, LD$, LU$, RD$, RU$, HZ$, VT$, BM$
  32.      
  33.     Level = 1: MaxLevel = 13
  34.      
  35.     GridSize = 3 'default starting GridSize is 3x3 (its level 1)
  36.     MaxGridSize = 15 'The last GridSize level so far (13 levels right now)
  37.      
  38.     'Declare image names: angle characters, right up, left up, etc
  39.     LD$ = "ld": LU$ = "lu"
  40.     RD$ = "rd": RU$ = "ru"
  41.     HZ$ = "hz": VT$ = "vt"
  42.     BM$ = "bm"
  43.      
  44.     'Sound files
  45.     new& = _SndOpen("sfx_magic.ogg")
  46.     move& = _SndOpen("sfx_click1.mp3"):
  47.     click& = _SndOpen("sfx_click2.mp3"):
  48.     clap& = _SndOpen("sfx_clap.ogg")
  49.      
  50.     'image file
  51.     Dim Shared Solved&
  52.     Solved& = _LoadImage("solved.png", 32) '<  thank bplus for this
  53.      
  54.     'For game state saving...to be added later
  55.     loaded = 0: fil$ = "pipe.dat"
  56.     If _FileExists(fil$) Then
  57.         loaded = 1
  58.     End If
  59.      
  60.     '=======
  61.     newlevel:
  62.     '=======
  63.      
  64.     Screen _NewImage(640, 640, 32)
  65.     'Do: Loop Until _ScreenExists ' <<<<<<<<<< sorry Dav this aint working on my system
  66.     _Delay .25 ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<< does this work for you?
  67.     '            No? increase delay time really nice to have centered on screen
  68.     _ScreenMove _Middle ' <  thank bplus for this , ahhhh that's better
  69.     Cls ', _RGB(32, 32, 77)
  70.      
  71.     If Level = 1 Then
  72.         back& = _LoadImage("hz-grn.png")
  73.         _PutImage (0, 0)-(640, 640), back&
  74.         _FreeImage back&
  75.         title& = _LoadImage("title.png")
  76.         _PutImage (84, 140), title&
  77.         _FreeImage title&
  78.         w$ = Input$(1)
  79.         For a = 0 To 64
  80.             Line (0, 0)-(640, 640), _RGBA(0, 0, 0, a), BF
  81.             _Delay .02
  82.         Next
  83.     End If
  84.      
  85.     PPRINT 100, 300, 30, _RGB(200, 200, 200), 0, "Level:" + Str$(Level) + " of" + Str$(MaxLevel)
  86.     _Delay 2
  87.      
  88.     _SndPlay new&
  89.      
  90.     Title$ = "Pipes: Level " + Str$(Level) + " of" + Str$(MaxLevel)
  91.     _Title Title$
  92.      
  93.     'Make space for variables
  94.     ReDim Shared TileVal$(GridSize * GridSize)
  95.     ReDim Shared TileX(GridSize * GridSize), TileY(GridSize * GridSize)
  96.     ReDim Shared TileClr(GridSize * GridSize), TileClr2(GridSize * GridSize)
  97.      
  98.     TileSize = Int(640 / GridSize) 'The width/height of tiles, in pixels
  99.      
  100.     'set tile values, and generate x/y values...
  101.     bb = 1
  102.     For r = 1 To GridSize
  103.         For c = 1 To GridSize
  104.             x = (r * TileSize): y = (c * TileSize)
  105.             If Rnd(GridSize * 2) = GridSize Then br = 0
  106.             TileX(bb) = x - TileSize: TileY(bb) = y - TileSize
  107.             TileVal$(bb) = RD$
  108.             TileClr(bb) = 0
  109.             TileClr2(bb) = 0
  110.             bb = bb + 1
  111.         Next c
  112.     Next r
  113.      
  114.     TileClr(1) = 1 'turn on top left leader tile
  115.     TileClr2(1) = 1 'make a copy
  116.      
  117.     setmaze 'Load level maze data, it's already scrambled up
  118.      
  119.     firstdraw = 1
  120.     GoSub updatebuttons
  121.      
  122.     Do
  123.      
  124.         _Limit 300
  125.      
  126.         'wait until mouse button up to continue
  127.         While _MouseButton(1) <> 0: n = _MouseInput: Wend
  128.      
  129.         trap = _MouseInput
  130.         If _MouseButton(1) Then
  131.             mx = _MouseX: my = _MouseY
  132.      
  133.             For b = 1 To (GridSize * GridSize)
  134.      
  135.                 tx = TileX(b): tx2 = TileX(b) + TileSize
  136.                 ty = TileY(b): ty2 = TileY(b) + TileSize
  137.      
  138.                 If mx >= tx And mx <= tx2 Then
  139.                     If my >= ty And my <= ty2 Then
  140.                         'skip any black blocks clicked on
  141.                         If TileVal$(b) = BM$ Then GoTo skip
  142.      
  143.                         _SndPlay move&
  144.      
  145.                         bv2$ = TileVal$(b) 'see what tile it is
  146.      
  147.                         'rotate right angle tiles
  148.                         If bv2$ = RD$ Then TileVal$(b) = LD$
  149.                         If bv2$ = LD$ Then TileVal$(b) = LU$
  150.                         If bv2$ = LU$ Then TileVal$(b) = RU$
  151.                         If bv2$ = RU$ Then TileVal$(b) = RD$
  152.      
  153.                         'rotate horiz/vert lines
  154.                         If bv2$ = HZ$ Then TileVal$(b) = VT$
  155.                         If bv2$ = VT$ Then TileVal$(b) = HZ$
  156.      
  157.                         'show tile
  158.                         If TileClr(b) = 1 Then
  159.                             tag$ = "-grn.png"
  160.                         Else
  161.                             tag$ = "-wht.png"
  162.                         End If
  163.      
  164.                         SHOW TileVal$(b) + tag$, TileX(b), TileY(b), TileX(b) + TileSize, TileY(b) + TileSize
  165.      
  166.                         GoSub updatebuttons
  167.                         GoSub checkforwin
  168.      
  169.                     End If
  170.                 End If
  171.             Next b
  172.         End If
  173.         skip:
  174.      
  175.         ink$ = UCase$(InKey$)
  176.      
  177.         If ink$ = Chr$(32) Then GoTo newlevel
  178.      
  179.         'Right arrows advance to next level
  180.         If ink$ = Chr$(0) + Chr$(77) Then
  181.             GridSize = GridSize + 1
  182.             Level = Level + 1
  183.             If Level > MaxLevel Then Level = 1
  184.             If GridSize > MaxGridSize Then
  185.                 GridSize = 3 'MaxGridSize  'restart
  186.             End If
  187.             GoTo newlevel
  188.         End If
  189.      
  190.         'Left Arrows go back a level
  191.         If ink$ = Chr$(0) + Chr$(75) Then
  192.             GridSize = GridSize - 1
  193.             If GridSize < 3 Then GridSize = MaxGridSize
  194.             Level = Level - 1
  195.             If Level < 1 Then Level = MaxLevel
  196.             GoTo newlevel
  197.         End If
  198.      
  199.     Loop Until ink$ = Chr$(27)
  200.      
  201.     System
  202.      
  203.     '============
  204.     updatebuttons:
  205.     '============
  206.      
  207.     'first tile always on, draw it green
  208.     SHOW TileVal$(1) + "-grn.png", TileX(1), TileY(1), TileX(1) + TileSize, TileY(1) + TileSize
  209.      
  210.      
  211.     'turn all off tile colors first, except 1st
  212.     For g = 2 To GridSize * GridSize
  213.         TileClr(g) = 0
  214.     Next g
  215.      
  216.      
  217.     'set leader tile flow direction
  218.     If TileVal$(1) = HZ$ Then direction = 1 'going right
  219.     If TileVal$(1) = VT$ Then direction = 2 'going down
  220.      
  221.     cur = 1 'start with 1st tile always
  222.      
  223.     'do until can't flow anymore (direction blocked)
  224.     Do
  225.      
  226.         If direction = 1 Then 'heading right
  227.             'see if already on the right edge of board
  228.             'if so, it can't go right anymore, so end flow...
  229.             For j = (GridSize * GridSize) - GridSize + 1 To GridSize * GridSize
  230.                 If cur = j Then GoTo flowdone
  231.             Next j
  232.             'now see if one to the right can connect with it.
  233.             'if not connectable, end flow here.
  234.             con = 0 'default is not connectable
  235.             nv$ = TileVal$(cur + GridSize)
  236.             If nv$ = HZ$ Then con = 1
  237.             If nv$ = LU$ Then con = 1
  238.             If nv$ = LD$ Then con = 1
  239.             'if not, end flow here
  240.             If con = 0 Then GoTo flowdone
  241.             'looks like it is connectable, so turn it on
  242.             TileClr(cur + GridSize) = 1 'turn piece to the right on.
  243.             'Make new pieve the new current flow position
  244.             tc = (cur + GridSize): cur = tc
  245.             'find/set new direction based on that character
  246.             If nv$ = HZ$ Then direction = 1 'right
  247.             If nv$ = LU$ Then direction = 4 'up
  248.             If nv$ = LD$ Then direction = 2 'down
  249.         End If
  250.      
  251.         If direction = 2 Then 'heading down
  252.             'see if this one is on the bottom edge
  253.             For j = GridSize To (GridSize * GridSize) Step GridSize
  254.                 If cur = j Then GoTo flowdone
  255.             Next j
  256.             'now see if new one can connect with this one.
  257.             'if not, end flow here.
  258.             con = 0 'default is not connectable
  259.             nv$ = TileVal$(cur + 1)
  260.             If nv$ = VT$ Then con = 1
  261.             If nv$ = LU$ Then con = 1
  262.             If nv$ = RU$ Then con = 1
  263.             'if not, end flow here
  264.             If con = 0 Then GoTo flowdone
  265.             'looks like it must be connectable
  266.             TileClr(cur + 1) = 1 'turn the next piece on too
  267.             'Make it the new current char position
  268.             tc = (cur + 1): cur = tc
  269.             'find/set new direction based on character
  270.             If nv$ = LU$ Then direction = 3 'left
  271.             If nv$ = RU$ Then direction = 1 'right
  272.             If nv$ = VT$ Then direction = 2 'down
  273.         End If
  274.      
  275.         If direction = 3 Then 'heading left
  276.             'see if this one is on the bottom edge
  277.             For j = 1 To GridSize
  278.                 If cur = j Then GoTo flowdone
  279.             Next j
  280.      
  281.             'now see if new one can connect with this one.
  282.             'if not, end flow here.
  283.             con = 0 'default is not connectable
  284.             nv$ = TileVal$(cur - GridSize)
  285.             If nv$ = HZ$ Then con = 1
  286.             If nv$ = RU$ Then con = 1
  287.             If nv$ = RD$ Then con = 1
  288.             'if not, end flow here
  289.             If con = 0 Then GoTo flowdone
  290.             'looks like it must be connectable
  291.             TileClr(cur - GridSize) = 1 'turn the next piece on too
  292.             'Make it the new current char position
  293.             tc = (cur - GridSize): cur = tc
  294.             'find/set new direction based on character
  295.             If nv$ = HZ$ Then direction = 3 'left
  296.             If nv$ = RU$ Then direction = 4 'up
  297.             If nv$ = RD$ Then direction = 2 'down
  298.         End If
  299.      
  300.         If direction = 4 Then 'going up
  301.             'see if this one is on the edge of board
  302.             'if so, it can't go up, so end flow...
  303.             For j = 1 To (GridSize * GridSize) Step GridSize
  304.                 If cur = j Then GoTo flowdone
  305.             Next j
  306.             'now see if new one can connect with this one.
  307.             'if not, end flow here.
  308.             con = 0 'default is not connectable
  309.             nv$ = TileVal$(cur - 1)
  310.             If nv$ = VT$ Then con = 1
  311.             If nv$ = LD$ Then con = 1
  312.             If nv$ = RD$ Then con = 1
  313.             'if not, end flow here
  314.             If con = 0 Then GoTo flowdone
  315.             'looks like it must be connectable
  316.             TileClr(cur - 1) = 1 'turn the next piece on too
  317.             'Make it the new current char position
  318.             tc = (cur - 1): cur = tc
  319.             'find/set new direction based on character
  320.             If nv$ = VT$ Then direction = 4 'up
  321.             If nv$ = LD$ Then direction = 3 'left
  322.             If nv$ = RD$ Then direction = 1 'right
  323.         End If
  324.      
  325.     Loop
  326.      
  327.     flowdone:
  328.      
  329.     If firstdraw = 0 Then
  330.      
  331.         'draw/colorize board
  332.         For t = 2 To (GridSize * GridSize)
  333.             If TileClr(t) = 1 And TileClr2(t) = 0 Then
  334.                 'show green...
  335.                 SHOW TileVal$(t) + "-grn.png", TileX(t), TileY(t), TileX(t) + TileSize, TileY(t) + TileSize
  336.             End If
  337.             If TileClr(t) = 0 And TileClr2(t) = 1 Then
  338.                 'show white...
  339.                 SHOW TileVal$(t) + "-wht.png", TileX(t), TileY(t), TileX(t) + TileSize, TileY(t) + TileSize
  340.             End If
  341.         Next t
  342.      
  343.     Else
  344.      
  345.         'draw/colorize board
  346.         For t = 2 To (GridSize * GridSize)
  347.             If TileClr(t) = 1 Then
  348.                 tag$ = "-grn.png"
  349.             Else
  350.                 tag$ = "-wht.png"
  351.             End If
  352.             SHOW TileVal$(t) + tag$, TileX(t), TileY(t), TileX(t) + TileSize, TileY(t) + TileSize
  353.         Next t
  354.      
  355.         firstdraw = 0
  356.      
  357.     End If
  358.      
  359.      
  360.     'copy current color values
  361.     For t = 1 To GridSize * GridSize
  362.         TileClr2(t) = TileClr(t)
  363.     Next t
  364.      
  365.      
  366.     '===========
  367.     checkforwin:
  368.     '===========
  369.      
  370.     all = 0
  371.     For w = 1 To (GridSize * GridSize)
  372.         If TileClr(w) = 1 Then all = all + 1
  373.         If TileVal$(w) = BM$ Then all = all + 1 'add any blocks
  374.     Next w
  375.      
  376.     If all = (GridSize * GridSize) Then
  377.      
  378.         ' bplus rewrote this section to fade in the You did it! sign over the gameboard =======================
  379.         ' Solved& has already been loaded after sounds at start of program
  380.         _SndPlay clap&
  381.         snap& = _NewImage(_Width, _Height, 32)
  382.         _PutImage , 0, snap&
  383.         For alph = 0 To 255
  384.             Cls
  385.             _PutImage , snap&, 0 'background
  386.             _SetAlpha alph, , Solved&
  387.             _PutImage (166, 258), Solved&
  388.             _Limit 40 ' 255 frames in 2 secs
  389.             _Display ' damn blinking!!! without this
  390.         Next
  391.         _AutoDisplay '<<<<<< back to not needing _display
  392.         _FreeImage snap&
  393.         ' end of bplus meddling ================================================================================
  394.      
  395.         Level = Level + 1
  396.      
  397.         GridSize = GridSize + 1
  398.      
  399.         If Level > MaxLevel Then Level = 1
  400.      
  401.         If GridSize > MaxGridSize Then
  402.             GridSize = 3 'MaxGridSize  'restart
  403.         End If
  404.      
  405.         GoTo newlevel
  406.      
  407.     End If
  408.      
  409.     Return
  410.      
  411.      
  412.     Sub setmaze ()
  413.      
  414.         If Level = 1 Then
  415.             GridSize = 3
  416.             a$ = "" '3x3 MazeConnect GridSize
  417.             a$ = a$ + "hzrdru"
  418.             a$ = a$ + "hzhzhz"
  419.             a$ = a$ + "ldluld"
  420.         End If
  421.      
  422.         If Level = 2 Then
  423.             GridSize = 4
  424.             a$ = "" '4x4 MazeConnect GridSize
  425.             a$ = a$ + "vtvtruru"
  426.             a$ = a$ + "rdvtluhz"
  427.             a$ = a$ + "hzrdruhz"
  428.             a$ = a$ + "ldluldlu"
  429.         End If
  430.      
  431.         If Level = 3 Then
  432.             GridSize = 5
  433.             a$ = "" '5x5 MazeConnect GridSize
  434.             a$ = a$ + "hzrdvtvtld"
  435.             a$ = a$ + "hzhzrdrdhz"
  436.             a$ = a$ + "hzhzldhzhz"
  437.             a$ = a$ + "hzldvtluhz"
  438.             a$ = a$ + "ldvtvtvtlu"
  439.         End If
  440.      
  441.         If Level = 4 Then
  442.             GridSize = 6
  443.             a$ = "" '6x6 MazeConnect GridSize
  444.             a$ = a$ + "hzrdrurdvtru"
  445.             a$ = a$ + "hzhzhzhzrdlu"
  446.             a$ = a$ + "ldluhzhzldru"
  447.             a$ = a$ + "rdvtluhzbmhz"
  448.             a$ = a$ + "hzrdruldruhz"
  449.             a$ = a$ + "ldluldvtlulu"
  450.         End If
  451.      
  452.         If Level = 5 Then
  453.             GridSize = 7
  454.             a$ = "" '7x7 MazeConnect GridSize
  455.             a$ = "vtruvtvtrurdru"
  456.             a$ = a$ + "rdlurdruldluhz"
  457.             a$ = a$ + "ldvtluldrurdlu"
  458.             a$ = a$ + "rdvtrurdluldru"
  459.             a$ = a$ + "ldruldlurdvtlu"
  460.             a$ = a$ + "rdlurdruldvtru"
  461.             a$ = a$ + "ldvtluldvtvtlu"
  462.         End If
  463.      
  464.         If Level = 6 Then
  465.             GridSize = 8
  466.             a$ = "" '8x8 MazeConnect GridSize
  467.             a$ = a$ + "hzvtrurdrurdrubm"
  468.             a$ = a$ + "hzbmldluhzhzldru"
  469.             a$ = a$ + "ldvtrurdluhzrdlu"
  470.             a$ = a$ + "rdvtluldvtluldru"
  471.             a$ = a$ + "ldrurdvtrurdvtlu"
  472.             a$ = a$ + "bmhzhzbmldlurdru"
  473.             a$ = a$ + "rdluldvtvtvtluhz"
  474.             a$ = a$ + "ldvtvtvtvtvtvtlu"
  475.         End If
  476.      
  477.         If Level = 7 Then
  478.             GridSize = 9
  479.             a$ = "" '9x9 MazeConnect GridSize
  480.             a$ = a$ + "hzrdvtvtrurdrurdru"
  481.             a$ = a$ + "hzldvtruldluldluhz"
  482.             a$ = a$ + "ldvtruldrubmrdvtlu"
  483.             a$ = a$ + "rdruldruldruldrubm"
  484.             a$ = a$ + "hzldruldruldruldru"
  485.             a$ = a$ + "ldruhzbmldruhzbmhz"
  486.             a$ = a$ + "rdluldvtvtluldruhz"
  487.             a$ = a$ + "hzrdrurdvtrurdluhz"
  488.             a$ = a$ + "ldluldlubmldluvtlu"
  489.         End If
  490.      
  491.         If Level = 8 Then
  492.             GridSize = 10
  493.             a$ = "" '10x10 MazeConnect GridSize
  494.             a$ = a$ + "vtvtvtrurdrurdvtrubm"
  495.             a$ = a$ + "hzrdvtluhzhzldruldru"
  496.             a$ = a$ + "hzldvtvtluldruhzrdlu"
  497.             a$ = a$ + "hzbmrdvtvtruldluldru"
  498.             a$ = a$ + "hzrdlurdruhzrdvtvtlu"
  499.             a$ = a$ + "hzhzrdluhzldlurdrubm"
  500.             a$ = a$ + "hzhzhzbmldrubmhzldru"
  501.             a$ = a$ + "hzldlurdruldvtlurdlu"
  502.             a$ = a$ + "hzrdruhzldrurdruldru"
  503.             a$ = a$ + "ldluldlubmldluldvtlu"
  504.         End If
  505.      
  506.         If Level = 9 Then
  507.             GridSize = 11
  508.             a$ = "" '11x11 MazeConnect GridSize
  509.             a$ = a$ + "hzvtrubmrdvtrubmrdvtru"
  510.             a$ = a$ + "ldruldruldruldruldruhz"
  511.             a$ = a$ + "bmldruldruldruldruhzhz"
  512.             a$ = a$ + "rdruldruldruldruldluhz"
  513.             a$ = a$ + "hzldruldruldruldrurdlu"
  514.             a$ = a$ + "ldruldruldruldruhzldru"
  515.             a$ = a$ + "bmldruldruldruldlurdlu"
  516.             a$ = a$ + "rdruldruldruldrurdlubm"
  517.             a$ = a$ + "hzldruldruldvtluldvtru"
  518.             a$ = a$ + "ldruldvtlurdrurdrurdlu"
  519.             a$ = a$ + "bmldvtvtvtluldluldlubm"
  520.         End If
  521.      
  522.         If Level = 10 Then
  523.             GridSize = 12
  524.             a$ = "" '12x12 MazeConnect GridSize
  525.             a$ = a$ + "vtvtrubmbmrdrurdrurdvtru"
  526.             a$ = a$ + "bmbmhzbmrdluldluhzhzrdlu"
  527.             a$ = a$ + "bmrdlurdlurdrurdluhzldru"
  528.             a$ = a$ + "rdlurdlurdluhzhzrdlurdlu"
  529.             a$ = a$ + "ldruldvtlurdluhzhzbmldru"
  530.             a$ = a$ + "bmldvtvtruhzbmldlurdvtlu"
  531.             a$ = a$ + "rdvtvtvtluhzrdvtvtlurdru"
  532.             a$ = a$ + "ldrurdvtvtluhzrdvtvtluhz"
  533.             a$ = a$ + "rdluhzbmbmbmldlurdrurdlu"
  534.             a$ = a$ + "hzrdlurdrurdrubmhzhzhzbm"
  535.             a$ = a$ + "ldlurdluhzhzhzrdluhzldru"
  536.             a$ = a$ + "vtvtlubmldluldlubmldvtlu"
  537.         End If
  538.      
  539.         If Level = 11 Then
  540.             GridSize = 13
  541.             a$ = "" '13x13 MazeConnect GridSize
  542.             a$ = a$ + "hzvtvtvtvtvtrurdrurdrurdru"
  543.             a$ = a$ + "hzrdrurdvtruldluhzhzldluhz"
  544.             a$ = a$ + "hzhzhzhzspldvtruhzhzrdruhz"
  545.             a$ = a$ + "hzhzhzldrubmrdluldluhzhzhz"
  546.             a$ = a$ + "hzhzldvtlurdlurdvtvtluldlu"
  547.             a$ = a$ + "hzldrubmrdlubmldvtvtrurdru"
  548.             a$ = a$ + "ldruldruhzbmbmbmrdruhzhzhz"
  549.             a$ = a$ + "rdlurdluldrubmrdluhzldluhz"
  550.             a$ = a$ + "hzrdlurdruldvtlurdlubmrdlu"
  551.             a$ = a$ + "hzldruhzldrurdvtlurdruldru"
  552.             a$ = a$ + "hzrdluhzbmldlurdvtluhzrdlu"
  553.             a$ = a$ + "hzhzrdlurdvtruhzrdvtluldru"
  554.             a$ = a$ + "ldluldvtlubmldluldvtvtvtlu"
  555.         End If
  556.      
  557.         If Level = 12 Then
  558.             GridSize = 14
  559.             a$ = "" '14x14 MazeConnect GridSize
  560.             a$ = a$ + "hzrdrurdvtvtrurdrurdvtvtrubm"
  561.             a$ = a$ + "hzhzhzldvtruhzhzhzhzrdruhzbm"
  562.             a$ = a$ + "ldluhzrdruhzldluldluhzhzhzbm"
  563.             a$ = a$ + "rdruhzhzhzldvtvtvtruhzldlubm"
  564.             a$ = a$ + "hzhzhzhzhzrdrurdruhzldvtrubm"
  565.             a$ = a$ + "hzhzhzhzhzhzhzhzhzhzrdruldru"
  566.             a$ = a$ + "hzhzldluhzhzhzhzhzhzhzldvtlu"
  567.             a$ = a$ + "hzldvtruhzhzhzhzhzhzldrurdru"
  568.             a$ = a$ + "hzrdruhzldluhzhzhzhzbmldluhz"
  569.             a$ = a$ + "ldluhzldvtruhzhzhzhzrdrurdlu"
  570.             a$ = a$ + "rdruhzrdvtluhzhzldluhzhzhzbm"
  571.             a$ = a$ + "hzldluldvtvtluhzrdvtluhzhzbm"
  572.             a$ = a$ + "hzvtvtvtvtvtvtluldrurdluhzbm"
  573.             a$ = a$ + "ldvtvtvtvtvtvtvtvtluldvtlubm"
  574.         End If
  575.      
  576.         If Level = 13 Then
  577.             GridSize = 15
  578.             a$ = "" '15x15 MazeConnect GridSize
  579.             a$ = a$ + "vtvtrurdrurdrurdrubmrdvtvtvtru"
  580.             a$ = a$ + "vtruldluhzhzldluldvtlurdvtruhz"
  581.             a$ = a$ + "rdlubmbmhzldvtvtrurdvtlubmldlu"
  582.             a$ = a$ + "ldrurdruhzbmrdruhzldrurdvtvtru"
  583.             a$ = a$ + "bmhzhzldlurdluhzldruldlurdvtlu"
  584.             a$ = a$ + "rdluldrurdlubmhzrdlurdruldrubm"
  585.             a$ = a$ + "ldrubmldlurdruldlubmhzhzbmldru"
  586.             a$ = a$ + "rdlurdvtvtluldrurdruhzhzrdvtlu"
  587.             a$ = a$ + "ldvtlurdvtvtvtluhzldluhzldvtru"
  588.             a$ = a$ + "rdvtvtlurdvtvtruldrurdlurdruhz"
  589.             a$ = a$ + "ldvtrurdlubmrdlurdluhzrdluldlu"
  590.             a$ = a$ + "rdvtluldrurdlurdlurdluhzbmrdru"
  591.             a$ = a$ + "ldvtrurdluhzbmldruldruldvtluhz"
  592.             a$ = a$ + "rdvtluldruhzrdruldruldvtrurdlu"
  593.             a$ = a$ + "ldvtvtvtluldluldvtlubmbmldlubm"
  594.         End If
  595.      
  596.         dd = 1
  597.         For s = 1 To Len(a$) Step 2
  598.             b$ = Mid$(a$, s, 2)
  599.             If b$ = "vt" Then rotate dd, 1
  600.             If b$ = "hz" Then rotate dd, 1
  601.             If b$ = "ld" Then rotate dd, 2
  602.             If b$ = "lu" Then rotate dd, 2
  603.             If b$ = "rd" Then rotate dd, 2
  604.             If b$ = "ru" Then rotate dd, 2
  605.             If b$ = "bm" Then TileVal$(dd) = BM$
  606.      
  607.             dd = dd + 1
  608.         Next s
  609.      
  610.     End Sub
  611.      
  612.     Sub rotate (num, typ)
  613.      
  614.         'there are only two types of rotating characters,
  615.         'straight lines, or right angles...
  616.      
  617.         'randomly rotate straight character
  618.         If typ = 1 Then
  619.             If Int(Rnd * 2) = 0 Then
  620.                 TileVal$(num) = VT$
  621.             Else
  622.                 TileVal$(num) = HZ$
  623.             End If
  624.         End If
  625.      
  626.         'randomly rotate right angles...
  627.         If typ = 2 Then
  628.             rn = Int(Rnd * 4) + 1
  629.             If rn = 1 Then TileVal$(num) = LD$
  630.             If rn = 2 Then TileVal$(num) = LU$
  631.             If rn = 3 Then TileVal$(num) = RD$
  632.             If rn = 4 Then TileVal$(num) = RU$
  633.         End If
  634.      
  635.     End Sub
  636.      
  637.     Sub SHOW (i$, x1, y1, x2, y2)
  638.         'Just a little sub to load & put an image at x1/y1
  639.         ttmp = _LoadImage(i$)
  640.         _PutImage (x1, y1)-(x2, y2), ttmp
  641.         _FreeImage ttmp
  642.     End Sub
  643.      
  644.     Sub PPRINT (x, y, size, clr&, trans&, text$)
  645.         'This sub outputs to the current _DEST set
  646.         'It makes trans& the transparent color
  647.      
  648.         'x/y is where to print text
  649.         'size is the font size to use
  650.         'clr& is the color of your text
  651.         'trans& is the background transparent color
  652.         'text$ is the string to print
  653.      
  654.         '=== get users current write screen
  655.         orig& = _Dest
  656.      
  657.         '=== if you are using an 8 or 32 bit screen
  658.         bit = 32: If _PixelSize(0) = 1 Then bit = 256
  659.      
  660.         '=== step through your text
  661.         For t = 0 To Len(text$) - 1
  662.             '=== make a temp screen to use
  663.             pprintimg& = _NewImage(16, 16, bit)
  664.             _Dest pprintimg&
  665.             '=== set colors and print text
  666.             Cls , trans&: Color clr&
  667.             Print Mid$(text$, t + 1, 1);
  668.             '== make background color the transprent one
  669.             _ClearColor _RGB(0, 0, 0), pprintimg&
  670.             '=== go back to original screen  to output
  671.             _Dest orig&
  672.             '=== set it and forget it
  673.             x1 = x + (t * size): x2 = x1 + size
  674.             y1 = y: y2 = y + size
  675.             _PutImage (x1 - (size / 2), y1)-(x2, y2 + (size / 3)), pprintimg&
  676.             _FreeImage pprintimg&
  677.         Next
  678.     End Sub
  679.  
  680.  

Attachments:

 

PipesPuzzle.jpg

Author's previous version for rerefence:https://www.qb64.org/foru/index.php?topic=2094.msg113243#msg113243

5
2D/3D Graphics / MOVED: SaveImage (take screenshots) by SMcNeill
« on: September 26, 2021, 04:55:45 am »
This topic has been moved to Utilities.

https://www.qb64.org/forum/index.php?topic=1651.0

6
General, Math & Geometry / MOVED: Curve Smoother
« on: September 25, 2021, 08:02:15 am »
This topic has been moved to Utilities.

https://www.qb64.org/forum/index.php?topic=184.0

7
General, Math & Geometry / MOVED: Circle Intersecting Line
« on: September 25, 2021, 08:00:25 am »
This topic has been moved to Utilities.

https://www.qb64.org/forum/index.php?topic=2301.0

8
General, Math & Geometry / MOVED: Circle Intersecting Circle
« on: September 25, 2021, 07:57:43 am »
This topic has been moved to Utilities.

https://www.qb64.org/forum/index.php?topic=2299.0

9
General, Math & Geometry / MOVED: Ellipse Intersecting Line by STxAxTIC
« on: September 25, 2021, 07:50:50 am »
This topic has been moved to Utilities.

https://www.qb64.org/forum/index.php?topic=2302.0

10
Utilities / Filled Circles and Ellipses (collaborative)
« on: September 25, 2021, 06:48:06 am »
Filled Circles and Ellipses

Contributor(s): @bplus, @Pete, @SMcNeill, @STxAxTIC
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1044.0

Description:
We develop four variations on the CIRCLE command in the form of four SUBs:
(i) CircleFill = Filled circle
(ii) EllipseFill = Filled ellipse
(iii) EllipseTilt = Tilted ellipse
(iv) EllipseTiltFill = Tilted and filled ellipse

These works have been optimized for speed and respect for alpha transparency.

Source Code:
Code: QB64: [Select]
  1. SCREEN _NEWIMAGE(800, 600, 32)
  2.  
  3. DIM TransRed AS _UNSIGNED LONG
  4. DIM TransGreen AS _UNSIGNED LONG
  5. DIM TransBlue AS _UNSIGNED LONG
  6. TransRed = _RGBA(255, 0, 0, 128)
  7. TransGreen = _RGBA(0, 255, 0, 128)
  8. TransBlue = _RGBA(0, 0, 255, 128)
  9.  
  10. CALL CircleFill(100, 100, 75, TransRed)
  11. CALL CircleFill(120, 120, 75, TransBlue)
  12.  
  13. CALL EllipseFill(550, 100, 150, 75, TransBlue)
  14. CALL EllipseFill(570, 120, 150, 75, TransGreen)
  15.  
  16. CALL EllipseTilt(200, 400, 150, 75, 0, TransGreen)
  17. CALL EllipseTilt(220, 420, 150, 75, 3.14 / 4, TransRed)
  18.  
  19. CALL EllipseTiltFill(0, 550, 400, 150, 75, 3.14 / 6, TransRed)
  20. CALL EllipseTiltFill(0, 570, 420, 150, 75, 3.14 / 4, TransGreen)
  21.  
  23.  
  24. SUB CircleFill (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
  25.     ' CX = center x coordinate
  26.     ' CY = center y coordinate
  27.     '  R = radius
  28.     '  C = fill color
  29.     DIM Radius AS INTEGER, RadiusError AS INTEGER
  30.     DIM X AS INTEGER, Y AS INTEGER
  31.     Radius = ABS(R)
  32.     RadiusError = -Radius
  33.     X = Radius
  34.     Y = 0
  35.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
  36.     LINE (CX - X, CY)-(CX + X, CY), C, BF
  37.     WHILE X > Y
  38.         RadiusError = RadiusError + Y * 2 + 1
  39.         IF RadiusError >= 0 THEN
  40.             IF X <> Y + 1 THEN
  41.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  42.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  43.             END IF
  44.             X = X - 1
  45.             RadiusError = RadiusError - X * 2
  46.         END IF
  47.         Y = Y + 1
  48.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  49.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  50.     WEND
  52.  
  53. SUB EllipseFill (CX AS INTEGER, CY AS INTEGER, a AS INTEGER, b AS INTEGER, C AS _UNSIGNED LONG)
  54.     ' CX = center x coordinate
  55.     ' CY = center y coordinate
  56.     '  a = semimajor axis
  57.     '  b = semiminor axis
  58.     '  C = fill color
  59.     IF a = 0 OR b = 0 THEN EXIT SUB
  60.     DIM h2 AS _INTEGER64
  61.     DIM w2 AS _INTEGER64
  62.     DIM h2w2 AS _INTEGER64
  63.     DIM x AS INTEGER
  64.     DIM y AS INTEGER
  65.     w2 = a * a
  66.     h2 = b * b
  67.     h2w2 = h2 * w2
  68.     LINE (CX - a, CY)-(CX + a, CY), C, BF
  69.     DO WHILE y < b
  70.         y = y + 1
  71.         x = SQR((h2w2 - y * y * w2) \ h2)
  72.         LINE (CX - x, CY + y)-(CX + x, CY + y), C, BF
  73.         LINE (CX - x, CY - y)-(CX + x, CY - y), C, BF
  74.     LOOP
  76.  
  77. SUB EllipseTilt (CX, CY, a, b, ang, C AS _UNSIGNED LONG)
  78.     '  CX = center x coordinate
  79.     '  CY = center y coordinate
  80.     '   a = semimajor axis
  81.     '   b = semiminor axis
  82.     ' ang = clockwise orientation of semimajor axis in radians (0 default)
  83.     '   C = fill color
  84.     FOR k = 0 TO 6.283185307179586 + .025 STEP .025
  85.         i = a * COS(k) * COS(ang) + b * SIN(k) * SIN(ang)
  86.         j = -a * COS(k) * SIN(ang) + b * SIN(k) * COS(ang)
  87.         i = i + CX
  88.         j = -j + CY
  89.         IF k <> 0 THEN
  90.             LINE -(i, j), C
  91.         ELSE
  92.             PSET (i, j), C
  93.         END IF
  94.     NEXT
  96.  
  97. SUB EllipseTiltFill (destHandle&, CX, CY, a, b, ang, C AS _UNSIGNED LONG)
  98.     '  destHandle& = destination handle
  99.     '  CX = center x coordinate
  100.     '  CY = center y coordinate
  101.     '   a = semimajor axis
  102.     '   b = semiminor axis
  103.     ' ang = clockwise orientation of semimajor axis in radians (0 default)
  104.     '   C = fill color
  105.     DIM max AS INTEGER, mx2 AS INTEGER, i AS INTEGER, j AS INTEGER
  106.     DIM prc AS _UNSIGNED LONG
  107.     DIM D AS INTEGER, S AS INTEGER
  108.     D = _DEST: S = _SOURCE
  109.     prc = _RGB32(255, 255, 255, 255)
  110.     IF a > b THEN max = a + 1 ELSE max = b + 1
  111.     mx2 = max + max
  112.     tef& = _NEWIMAGE(mx2, mx2)
  113.     _DEST tef&
  114.     _SOURCE tef&
  115.     FOR k = 0 TO 6.283185307179586 + .025 STEP .025
  116.         i = max + a * COS(k) * COS(ang) + b * SIN(k) * SIN(ang)
  117.         j = max + a * COS(k) * SIN(ang) - b * SIN(k) * COS(ang)
  118.         IF k <> 0 THEN
  119.             LINE (lasti, lastj)-(i, j), prc
  120.         ELSE
  121.             PSET (i, j), prc
  122.         END IF
  123.         lasti = i: lastj = j
  124.     NEXT
  125.     DIM xleft(mx2) AS INTEGER, xright(mx2) AS INTEGER, x AS INTEGER, y AS INTEGER
  126.     FOR y = 0 TO mx2
  127.         x = 0
  128.         WHILE POINT(x, y) <> prc AND x < mx2
  129.             x = x + 1
  130.         WEND
  131.         xleft(y) = x
  132.         WHILE POINT(x, y) = prc AND x < mx2
  133.             x = x + 1
  134.         WEND
  135.         WHILE POINT(x, y) <> prc AND x < mx2
  136.             x = x + 1
  137.         WEND
  138.         IF x = mx2 THEN xright(y) = xleft(y) ELSE xright(y) = x
  139.     NEXT
  140.     _DEST destHandle&
  141.     FOR y = 0 TO mx2
  142.         IF xleft(y) <> mx2 THEN LINE (xleft(y) + CX - max, y + CY - max)-(xright(y) + CX - max, y + CY - max), C, BF
  143.     NEXT
  144.     _DEST D: _DEST S
  145.     _FREEIMAGE tef&
  147.  

Attachments:
 
                                                                                                                                         (191 downloads previously)

Ellipses.png

11
Utilities / RotoZoom3 (Modification) by bplus
« on: September 25, 2021, 06:20:27 am »
Author and contributor: @bplus @Galleon
Source: QB64.org Wiki and Forum
URL: https://www.qb64.org/wiki/MAPTRIANGLE
https://www.qb64.org/forum/index.php?topic=1511.msg115148#msg115148
Version: 2020 version #3
Tags: [graphics] [image]
Description:
A modification of Galleon's RotoZoom in Wiki that both scales and rotates an image, this version scales the x-axis and y-axis independently allowing some rotations of image just by changing X or Y Scales making this already powerful routine even more a versatile image tool.

Source Code (and demos with Spike Image (attached)):
Code: QB64: [Select]
  2. _TITLE "Another RotoZoom Demo" 'b+ started 2020-03-02
  3.  
  4. CONST xmax = 1200, ymax = 700, xc = 600, yc = 350
  5. SCREEN _NEWIMAGE(xmax, ymax, 32)
  6. _SCREENMOVE 100, 40
  7. DIM SHARED s&, ao
  8. DIM a, x, y, x1, y1, xs, dxs, ddxs, ys, dys, ddys, maxScale
  9.  
  10. ' Starting from an image I pulled from Internet, I used Paint 3D to give it a transparent background.
  11. s& = _LOADIMAGE("tspike.png") 't for transparent background
  12.  
  13.  
  14. ' Standard Rotation about the image center on a given X, Y location. Rotating image in middle of screen,
  15. ' I used something like this to find ideal angle for level point on left head on right.
  16. WHILE _KEYDOWN(27) = 0
  17.     a = a + _PI(1 / 36)
  18.     IF a > _PI(1.999) THEN a = 0
  19.     CLS
  20.     RotoZoom3 xc, yc, s&, 1, 1, a
  21.     PRINT "Raw image rotation:": PRINT
  22.     PRINT "radian angle:"; a; "   degrees:"; _R2D(a) \ 1; " press key for next angle... esc to rotate on y axis"
  23.     WHILE LEN(INKEY$) = 0: _LIMIT 60: WEND
  25.  
  26. ao = _PI(.27) ' I have to offset the image angle by this amount so that the spike point is on the left
  27. '               and the head is on the right at 0 degrees or radians.
  28.  
  29.  
  30. 'Demo of the independent x and y scale for axis rotations
  31. maxScale = 4: dxs = .01: ddxs = 1: xs = maxScale:
  33.     CLS
  34.     PRINT "Press any for rotation on x axis..."
  35.     RotoZoom3 xc, yc, s&, xs, maxScale, ao
  36.     IF xs + dxs > maxScale OR xs + dxs < -maxScale THEN ddxs = ddxs * -1
  37.     xs = xs + dxs * ddxs
  38.     _DISPLAY
  39.     _LIMIT 60
  41.  
  42. ys = maxScale: dys = .01: ddys = 1
  44.     CLS
  45.     PRINT "Press any to see layout of image over whole screen and end demo..."
  46.     RotoZoom3 xc, yc, s&, maxScale, ys, ao
  47.     IF ys + dys > maxScale OR ys + dys < -maxScale THEN ddys = ddys * -1
  48.     ys = ys + dys * ddys
  49.     _DISPLAY
  50.     _LIMIT 60
  52.  
  53. ' Demo of an applied layout on screen
  54. COLOR , &HFFBBBBBB: CLS ' the image has slight gray halo so hide with gray background
  55. FOR x = 40 TO _WIDTH - 40 STEP 20
  56.     RotoZoom3 x, 15, s&, .2, .2, _PI(1.5 + .27)
  57.     RotoZoom3 x, _HEIGHT - 15, s&, .2, .2, _PI(.5 + .27)
  59. FOR y = 40 TO _HEIGHT - 40 STEP 20
  60.     RotoZoom3 15, y, s&, .2, .2, _PI(1 + .27)
  61.     RotoZoom3 _WIDTH - 15, y, s&, .2, .2, _PI(.27)
  63. FOR a = 0 TO _PI(2) STEP _PI(1 / 6)
  64.     x1 = xc + 200 * COS(a)
  65.     y1 = yc + 200 * SIN(a)
  66.     RotoZoom3 x1, y1, s&, 2, 2, a + ao
  70.  
  71. 'And finally a little show. What is better than a knife thrower throwing bananas?
  72. WHILE _KEYDOWN(27) = 0
  73.     CLS
  74.     drawKite xc, .9 * ymax, 600, a + ao
  75.     _DISPLAY
  76.     _LIMIT 30
  77.     a = a + _PI(2 / 360)
  80.  
  81. SUB drawKite (x, y, s, a)
  82.     RotoZoom3 x, y, s&, s / _WIDTH(s&), s / _HEIGHT(s&), a + ao
  83.     IF s > 10 THEN
  84.         drawKite x + .5 * s * COS(_PI(2) - a), (y - .25 * s) + .25 * s * SIN(_PI(2) - a), s / 1.5, a
  85.         drawKite x + .5 * s * COS(_PI + a), (y - .25 * s) + .25 * s * SIN(_PI + a), s / 1.5, a
  86.     END IF
  88.  
  89. ' Description:
  90. ' Started from a mod of Galleon's in Wiki that both scales and rotates an image.
  91. ' This version scales the x-axis and y-axis independently allowing rotations of image just by changing X or Y Scales
  92. ' making this tightly coded routine a very powerful and versatile image tool.
  93. SUB RotoZoom3 (X AS LONG, Y AS LONG, Image AS LONG, xScale AS SINGLE, yScale AS SINGLE, radianRotation AS SINGLE)
  94.     ' This assumes you have set your drawing location with _DEST or default to screen.
  95.     ' X, Y - is where you want to put the middle of the image
  96.     ' Image - is the handle assigned with _LOADIMAGE
  97.     ' xScale, yScale - are shrinkage < 1 or magnification > 1 on the given axis, 1 just uses image size.
  98.     ' These are multipliers so .5 will create image .5 size on given axis and 2 for twice image size.
  99.     ' radianRotation is the Angle in Radian units to rotate the image
  100.     ' note: Radian units for rotation because it matches angle units of other Basic Trig functions
  101.     '       and saves a little time converting from degree.
  102.     '       Use the _D2R() function if you prefer to work in degree units for angles.
  103.  
  104.     DIM px(3) AS SINGLE: DIM py(3) AS SINGLE ' simple arrays for x, y to hold the 4 corners of image
  105.     DIM W&, H&, sinr!, cosr!, i&, x2&, y2& '   variables for image manipulation
  106.     W& = _WIDTH(Image&): H& = _HEIGHT(Image&)
  107.     px(0) = -W& / 2: py(0) = -H& / 2 'left top corner
  108.     px(1) = -W& / 2: py(1) = H& / 2 ' left bottom corner
  109.     px(2) = W& / 2: py(2) = H& / 2 '  right bottom
  110.     px(3) = W& / 2: py(3) = -H& / 2 ' right top
  111.     sinr! = SIN(-radianRotation): cosr! = COS(-radianRotation) ' rotation helpers
  112.     FOR i& = 0 TO 3 ' calc new point locations with rotation and zoom
  113.         x2& = xScale * (px(i&) * cosr! + sinr! * py(i&)) + X: y2& = yScale * (py(i&) * cosr! - px(i&) * sinr!) + Y
  114.         px(i&) = x2&: py(i&) = y2&
  115.     NEXT
  116.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
  117.     _MAPTRIANGLE _SEAMLESS(0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
  119.  
  120.  

Attachments:
 
                                                                                                                                         (124 downloads previously)

Spiked.PNG

12
General, Math & Geometry / Convert BMP to Dominoes by Richard Frost
« on: September 25, 2021, 05:46:49 am »
Convert BMP to Dominoes

Author: @Richard Frost
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1023.0
Version: 2019

Description:
[This] is an image converter that takes a picture a small block at a time and finds the "best fit" domino for that space. (The woman is Heather Thomas.)

Source Code:
Code: QB64: [Select]
  1. ' The woman is Heather Thomas
  2.  
  3. DEFINT A-Z
  5. DIM dots(7), x(7, 7), y(7, 7), c1(7), c2(28), pixel(7, 7), w(3), y$(30)
  6. cps! = 12.83 ' cost per set
  7. FOR i = 1 TO 28: READ y$(i): NEXT i
  8. FOR n = 1 TO 7
  9.     READ dots(n)
  10.     FOR dot = 1 TO dots(n)
  11.         READ x(n, dot), y(n, dot)
  12.     NEXT dot
  14. xb = 10: xe = 350 ' x begin and end
  15. yb = 0: ye = 470 ' y begin and end
  16. OPEN "heath.bmp" FOR RANDOM AS #1 LEN = 1: FIELD #1, 1 AS t$
  17. FOR y1 = yb TO ye STEP 8
  18.     FOR x1 = xb TO xe STEP 8
  19.         n = 0
  20.         FOR y2 = 0 TO 7
  21.             FOR x2 = 0 TO 7
  22.                 x3 = x1 + x2
  23.                 y3 = y1 + y2
  24.                 r& = CDBL(479 - y3) * 640 + x3 + 441
  25.                 GET #1, r&
  26.                 d = ASC(t$) \ 13
  27.                 IF d > 15 THEN d = 15
  28.                 pixel(x2, y2) = -(d > 7) ' for 3 problem
  29.                 n = n + d
  30.             NEXT x2
  31.         NEXT y2
  32.         n = n / 155 ' 175
  33.         IF n > 6 THEN n = 6
  34.         x$ = x$ + CHR$(48 + n) ' for counting tiles used
  35.         IF LEN(x$) = 2 THEN ' got left & right
  36.             FOR i = 1 TO 28
  37.                 IF x$ = y$(i) THEN c2(i) = c2(i) + 1: EXIT FOR
  38.             NEXT i
  39.             x$ = ""
  40.         END IF
  41.         IF n = 3 THEN ' default bottom left - top right
  42.             IF (l = 3) OR (l = 7) THEN ' can't change direction if the
  43.                 n = l ' last piece was also a 3
  44.             ELSE
  45.                 FOR zi = 0 TO 3
  46.                     w(zi) = 0
  47.                 NEXT zi
  48.                 FOR y2 = 0 TO 7
  49.                     FOR x2 = 0 TO 7
  50.                         xi = x2 \ 4 ' 0 or 1
  51.                         yi = y2 \ 4 ' 0 or 1
  52.                         zi = xi * 2 + yi ' 0-3
  53.                         ' LOCATE zi + 1, 1: PRINT zi;
  54.                         w(zi) = w(zi) + pixel(x2, y2)
  55.                     NEXT x2
  56.                 NEXT y2
  57.                 IF (w(1) + w(2)) > (w(0) + w(3)) THEN n = 7
  58.             END IF
  59.         END IF
  60.         l = n ' save last used (for 3)
  61.         d = dots(n)
  62.         c1(n) = c1(n) + 1
  63.         FOR dot = 1 TO d
  64.             tx = (x1 + 4) + x(n, dot) * 2 - xb
  65.             ty = (y1 + 4) + y(n, dot) * 2 - yb
  66.             PSET (tx, ty), 15
  67.         NEXT dot
  68.         IF INKEY$ = CHR$(27) THEN CLOSE: SCREEN 0, 0, 0, 0: END
  69.         nd = nd + 1
  70.     NEXT x1
  71.     GOSUB Status
  72. NEXT y1
  76.  
  77. Status:
  78. FOR i = 0 TO 7
  79.     'COLOR i
  80.     LOCATE i + 2, 49: PRINT USING "####"; i; c1(i);
  82. RESTORE count
  83. FOR i = 1 TO 28
  84.     LOCATE i + 1, 60: PRINT " ";
  85.     LOCATE i + 1, 60
  86.     IF c2(i) >= max THEN
  87.         max = c2(i)
  88.         PRINT "*";
  89.     ELSE
  90.         PRINT " ";
  91.     END IF
  92.     PRINT y$(i);
  93.     PRINT USING " #### "; c2(i);
  94.     c! = c2(i) * cps!
  95.     c! = c! + c! * .07
  96.     PRINT USING "####.##"; c!;
  98. xn = (xe - xb) / 16
  99. yn = (ye - yb) / 8
  100. LOCATE 27, 52: PRINT xn;
  101. LOCATE 28, 52: PRINT yn;
  102. LOCATE 29, 52: PRINT xn * yn;
  104.  
  105. count:
  106. DATA 00,01,02,03,04,05,06
  107. DATA 11,12,13,14,15,16
  108. DATA 22,23,24,25,26
  109. DATA 33,34,35,36
  110. DATA 44,45,46
  111. DATA 55,56
  112. DATA 66
  113.  
  114. dots:
  115. DATA 1,0,0
  116. DATA 2,0,-1,0,1
  117. DATA 3,-1,-1,0,0,1,1
  118. DATA 4,-1,1,-1,-1,1,-1,1,1
  119. DATA 5,-1,1,-1,-1,1,-1,1,1,0,0
  120. DATA 6,-1,1,-1,0,-1,-1,1,1,1,0,1,-1
  121. DATA 3,1,-1,0,0,-1,1
  122.  

Attachments:
Requires HEATH.BMP

 
                                                                                                                                         (219 downloads previously)
 
HEATH.BMP


BMP2Dominoes.png

13
General, Math & Geometry / InForm Calculator by Terry Ritchie
« on: September 24, 2021, 05:12:55 am »
InForm Calculator

Author: @TerryRitchie
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=507.0
Version: 1

Description:
This is a calculator program I have been working on.  This little program gave me the general feel for InForm and got me back into programming QB64, a win-win.

Source Code:
Code: QB64: [Select]
  1.  
  2.     ':  ____ ____ ____ ____ ____ ____ ____ ____ ____ ____
  3.     ': ||C |||A |||L |||C |||U |||L |||A |||T |||O |||R ||
  4.     ': ||__|||__|||__|||__|||__|||__|||__|||__|||__|||__||
  5.     ': |/__\|/__\|/__\|/__\|/__\|/__\|/__\|/__\|/__\|/__\|
  6.     ':
  7.     ': QB64 Calculator V1.0
  8.     ': Terry Ritchie - 08/29/18
  9.     ':
  10.     ': Built as a clone of the Windows 7 standard calculator
  11.     ': An exersize in getting to know the InForm library
  12.     ':
  13.     ': This program uses
  14.     ': InForm - GUI library for QB64 - Beta version 7
  15.     ': Fellippe Heitor, 2016-2018 - fellippe@qb64.org - [member=2]FellippeHeitor[/member]
  16.     ': https://github.com/FellippeHeitor/InForm
  17.     '----------------------------------------------------------------------------------------------------------------------
  18.      
  19.     ': Program constants: -------------------------------------------------------------------------------------------------
  20.      
  21.     CONST EQUATE = 0
  22.     CONST ADDITION = 1
  23.     CONST SUBTRACTION = 2
  24.     CONST MULTIPLICATION = 3
  25.     CONST DIVISION = 4
  26.      
  27.     ': Controls' IDs: -----------------------------------------------------------------------------------------------------
  28.      
  29.     DIM SHARED Calculator AS LONG
  30.     DIM SHARED frmResults AS LONG
  31.     DIM SHARED mnuEdit AS LONG
  32.     DIM SHARED mnuHelp AS LONG
  33.     DIM SHARED butMC AS LONG
  34.     DIM SHARED butMR AS LONG
  35.     DIM SHARED butMS AS LONG
  36.     DIM SHARED butMplus AS LONG
  37.     DIM SHARED butMminus AS LONG
  38.     DIM SHARED butBS AS LONG
  39.     DIM SHARED butCE AS LONG
  40.     DIM SHARED butC AS LONG
  41.     DIM SHARED butSign AS LONG
  42.     DIM SHARED butSQR AS LONG
  43.     DIM SHARED but7 AS LONG
  44.     DIM SHARED but8 AS LONG
  45.     DIM SHARED but9 AS LONG
  46.     DIM SHARED butDivide AS LONG
  47.     DIM SHARED butPercent AS LONG
  48.     DIM SHARED but4 AS LONG
  49.     DIM SHARED but5 AS LONG
  50.     DIM SHARED but6 AS LONG
  51.     DIM SHARED butMultiply AS LONG
  52.     DIM SHARED butReciprocate AS LONG
  53.     DIM SHARED but1 AS LONG
  54.     DIM SHARED but2 AS LONG
  55.     DIM SHARED but3 AS LONG
  56.     DIM SHARED butSubtract AS LONG
  57.     DIM SHARED but0 AS LONG
  58.     DIM SHARED butPoint AS LONG
  59.     DIM SHARED butAdd AS LONG
  60.     DIM SHARED butEqual AS LONG
  61.     DIM SHARED mnuCopy AS LONG
  62.     DIM SHARED mnuPaste AS LONG
  63.     DIM SHARED mnuAbout AS LONG
  64.     DIM SHARED lblAnswer AS LONG
  65.     DIM SHARED lblMemory AS LONG
  66.     DIM SHARED lblHistory AS LONG
  67.      
  68.     ': Program variables: -------------------------------------------------------------------------------------------------
  69.      
  70.     DIM SHARED operand$ '                       current operand
  71.     DIM SHARED history$ '                       calculation history
  72.     DIM SHARED operand1 AS DOUBLE '             first operand enetered
  73.     DIM SHARED operand2 AS DOUBLE '             second operand entered
  74.     DIM SHARED operator AS INTEGER '            current operator selected
  75.     DIM SHARED operator$(4)
  76.     DIM SHARED previousoperator AS INTEGER '    previous operator saved
  77.     DIM SHARED resetoperand AS INTEGER '        True when operand entry needs reset
  78.     DIM SHARED memory AS DOUBLE '               value stored in memory
  79.     DIM SHARED nohistory AS INTEGER
  80.      
  81.     ': External modules: --------------------------------------------------------------------------------------------------
  82.      
  83.     '$INCLUDE:'InForm\InForm.ui'
  84.     '$INCLUDE:'InForm\xp.uitheme'
  85.     '$INCLUDE:'Calculator.frm'
  86.      
  87.     ': Windows libraries : ------------------------------------------------------------------------------------------------
  88.      
  89.     ' Windows system sounds
  90.     ' Code contributed by QB64.org Wiki - Author unknown
  91.     ' http://qb64.org/wiki/Windows_Libraries#Windows_Sounds
  92.     ' Note: this Windows library will fail in SDL versions of QB64
  93.     '       change DECLARE LIBRARY to DECLARE DYNAMIC LIBRARY "Wimmm"
  94.     '       to allow this library to work with SDL versions of QB64
  95.      
  97.         FUNCTION PlaySound (pszSound AS STRING, BYVAL hmod AS INTEGER, BYVAL fdwSound AS INTEGER)
  98.     END DECLARE
  99.      
  100.     ': Program procedures: ------------------------------------------------------------------------------------------------
  101.      
  102.     '----------------------------------------------------------------------------------------------------------------------
  103.     SUB ALERT () '                                                                                                  ALERT()
  104.         '------------------------------------------------------------------------------------------------------------------
  105.      
  106.         ' Plays Windows default sounds
  107.         ' Sounds can be invoked using the following strings:
  108.         ' "SystemDefault","SystemExclamation","SystemExit","SystemHand","SystemQuestion","SystemStart","SystemWelcome"
  109.      
  110.         s = PlaySound("SystemDefault" + CHR$(0), 0, 65537) '                play Windows default system sound
  111.      
  112.     END SUB
  113.      
  114.     '----------------------------------------------------------------------------------------------------------------------
  115.     FUNCTION CLEAN$ (n AS DOUBLE) '                                                                                CLEAN$()
  116.         '------------------------------------------------------------------------------------------------------------------
  117.      
  118.         ' Return number (n) as a string with no leading/trailing spaces
  119.         ' Add leading zero if necessary
  120.      
  121.         DIM c$ ' n converted to a clean string
  122.      
  123.         c$ = LTRIM$(RTRIM$(STR$(n))) '                                      create clean string
  124.         IF ASC(c$, 1) = 46 THEN '                                           first character a decimal point?
  125.             c$ = "0" + c$ '                                                 yes, add leading zero
  126.         ELSEIF ASC(c$, 1) = 45 AND ASC(c$, 2) = 46 THEN '                   no, minus sign then decimal point?
  127.             c$ = "-0" + RIGHT$(c$, LEN(c$) - 1) '                           yes, add leading zero
  128.         END IF
  129.         CLEAN$ = c$ '                                                       return cleaned string
  130.      
  132.      
  133.     '----------------------------------------------------------------------------------------------------------------------
  134.     SUB UPDATEOPERAND (n$) '                                                                                UPDATEOPERAND()
  135.         '------------------------------------------------------------------------------------------------------------------
  136.      
  137.         ' Add user entries to operand
  138.         ' Keep operand to a max length of 16 numbers (not including decimal point)
  139.         ' Reset user operand input as needed
  140.         ' Keep leading zero for decimal values between one and negative one
  141.      
  142.         DIM olen AS INTEGER ' operand length
  143.      
  144.         IF resetoperand THEN '                                              new operand input?
  145.             operand$ = "" '                                                 yes, reset operand
  146.             resetoperand = False '                                          reset trigger
  147.         END IF
  148.         IF n$ = "." THEN '                                                  adding decimal point?
  149.             IF INSTR(operand$, ".") = 0 THEN '                              yes, already a decimal point?
  150.                 IF operand$ = "" THEN '                                     no, has operand been reset?
  151.                     n$ = "0." '                                             yes, add leading zero
  152.                 END IF
  153.             ELSE '                                                          yes, decimal point exists
  154.                 n$ = "" '                                                   ignore user request for decimal point
  155.             END IF
  156.         END IF
  157.         operand$ = operand$ + n$ '                                          update operand with user entry
  158.         olen = LEN(operand$) '                                              get length of operand
  159.         IF INSTR(operand$, ".") > 0 THEN olen = olen - 1 '                  don't count decimal point if preset
  160.         IF olen > 16 THEN operand$ = LEFT$(operand$, LEN(operand$) - 1) '   keep operand within 16 number limit
  161.      
  162.     END SUB
  163.      
  164.     '----------------------------------------------------------------------------------------------------------------------
  165.     SUB CALCULATE () '                                                                                          CALCULATE()
  166.         '------------------------------------------------------------------------------------------------------------------
  167.      
  168.         ' Calculate operand values based on operator previously used
  169.         ' Store result back into current operand
  170.      
  171.         SELECT CASE previousoperator '                                      which operator to use?
  172.             CASE ADDITION '                                                 add the operands
  173.             &