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.                 operand$ = CLEAN$(operand1 + operand2) '                    perform clculation
  174.             CASE SUBTRACTION '                                              subtract the operands
  175.                 operand$ = CLEAN$(operand1 - operand2) '                    perform calculation
  176.             CASE MULTIPLICATION '                                           multiply the operands
  177.                 operand$ = CLEAN$(operand1 * operand2) '                    perform calculation
  178.             CASE DIVISION '                                                 divide the operands
  179.                 IF operand2 = 0 THEN '                                      dividing by zero?
  180.                     ALERT '                                                 get user's attention
  181.                     operand$ = "Can't divide by zero!" '                    yes, not in this universe!
  182.                 ELSE '                                                      no, physics is safe for now
  183.                     operand$ = CLEAN$(operand1 / operand2) '                perform calculation
  184.                 END IF
  185.         END SELECT
  186.         calculated = True
  187.      
  188.     END SUB
  189.      
  190.     '----------------------------------------------------------------------------------------------------------------------
  191.     SUB COMMITOPERAND () '                                                                                  COMMITOPERAND()
  192.         '------------------------------------------------------------------------------------------------------------------
  193.      
  194.         ' Get value of current operand
  195.         ' Calculate operands if necessary
  196.         ' Save current operand value
  197.         ' Remember the operator that invoked this routine
  198.      
  199.         operand2 = VAL(operand$) '                                          store value of current operand
  200.         IF previousoperator THEN '                                          previous operator selected?
  201.             CALCULATE '                                                     yes, calculate
  202.         END IF
  203.         operand1 = VAL(operand$) '                                          move current total to previous value
  204.         previousoperator = operator '                                       move current operator to previous operator
  205.         resetoperand = True '                                               trigger an operand reset
  206.      
  207.     END SUB
  208.      
  209.     '----------------------------------------------------------------------------------------------------------------------
  210.     SUB SCANKEYBOARD () '                                                                                    SCANKEYBOARD()
  211.         '------------------------------------------------------------------------------------------------------------------
  212.      
  213.         ' Scan the keyboard for user keystrokes
  214.         ' Invoke the appropriate button for the desired key
  215.      
  216.         DIM k$ ' key pressed by user
  217.         DIM ctrl AS INTEGER
  218.      
  219.         k$ = INKEY$ '                                                       look for a key press
  220.         IF k$ <> "" THEN '                                                  was a key pressed?
  221.             SELECT CASE k$ '                                                yes, which one?
  222.                 CASE "0" '                                                  zero key pressed
  223.                     __UI_Click (but0) '                                     manually click the zero button
  224.                 CASE "1" '                                                  etc..
  225.                     __UI_Click (but1) '                                     etc..
  226.                 CASE "2"
  227.                     __UI_Click (but2)
  228.                 CASE "3"
  229.                     __UI_Click (but3)
  230.                 CASE "4"
  231.                     __UI_Click (but4)
  232.                 CASE "5"
  233.                     __UI_Click (but5)
  234.                 CASE "6"
  235.                     __UI_Click (but6)
  236.                 CASE "7"
  237.                     __UI_Click (but7)
  238.                 CASE "8"
  239.                     __UI_Click (but8)
  240.                 CASE "9"
  241.                     __UI_Click (but9)
  242.                 CASE "."
  243.                     __UI_Click (butPoint)
  244.                 CASE "+"
  245.                     __UI_Click (butAdd)
  246.                 CASE "-"
  247.                     __UI_Click (butSubtract)
  248.                 CASE "*"
  249.                     __UI_Click (butMultiply)
  250.                 CASE "/"
  251.                     __UI_Click (butDivide)
  252.                 CASE "%"
  253.                     __UI_Click (butPercent)
  254.                 CASE "=", CHR$(13) '                                        treat ENTER and = the same
  255.                     __UI_Click (butEqual)
  256.                 CASE CHR$(8) '                                              backspace key pressed
  257.                     __UI_Click (butBS)
  258.      
  259.                 CASE "c", "C" '                                             CTRL-C copy
  260.                     ctrl = _KEYDOWN(100305) OR _KEYDOWN(100306)
  261.                     IF ctrl THEN BEEP
  262.      
  263.                     ' Will need to investigate how to capture CTRL-C and CTRL-V
  264.                     ' Neither the code above or below works
  265.      
  266.                 CASE "v", "V" '                                             CTRL-V paste
  267.                     IF __UI_CtrlIsDown THEN '                               is CTRL key presses?
  268.      
  269.                         BEEP
  270.      
  271.                     END IF
  272.      
  273.             END SELECT
  274.         END IF
  275.      
  276.     END SUB
  277.      
  278.     '----------------------------------------------------------------------------------------------------------------------
  279.     SUB ADDHISTORY (h$) '                                                                                      ADDHISTORY()
  280.         '------------------------------------------------------------------------------------------------------------------
  281.      
  282.         IF nohistory THEN
  283.             nohistory = False
  284.         ELSE
  285.             history$ = history$ + h$
  286.         END IF
  287.      
  288.     END SUB
  289.      
  290.     '----------------------------------------------------------------------------------------------------------------------
  291.      
  292.     ': Event procedures: --------------------------------------------------------------------------------------------------
  293.      
  294.     SUB __UI_BeforeInit
  295.      
  296.     END SUB
  297.      
  298.     SUB __UI_OnLoad
  299.      
  300.         operator$(1) = " + " ' define operator strings
  301.         operator$(2) = " - "
  302.         operator$(3) = " * "
  303.         operator$(4) = " / "
  304.      
  305.     END SUB
  306.      
  307.     SUB __UI_BeforeUpdateDisplay
  308.         'This event occurs at approximately 30 frames per second.
  309.         'You can change the update frequency by calling SetFrameRate DesiredRate%
  310.      
  311.         DIM answer$ ' current operand displayed
  312.      
  313.         SCANKEYBOARD '                                                      process keys pressed by user
  314.      
  315.         Caption(lblHistory) = history$ + operator$(operator) '              update history display
  316.      
  317.         answer$ = operand$ '                                                copy operand
  318.         IF answer$ = "" THEN answer$ = "0" '                                set to zero if empty
  319.      
  320.         Caption(lblAnswer) = answer$ '                                      display current operand
  321.      
  322.         IF memory THEN '                                                    does memory have value?
  323.             Caption(lblMemory) = "M" '                                      yes, apply screen indication
  324.         ELSE '                                                              no
  325.             Caption(lblMemory) = "" '                                       remove screen indication
  326.         END IF
  327.      
  328.     END SUB
  329.      
  330.     SUB __UI_BeforeUnload
  331.         'If you set __UI_UnloadSignal = False here you can
  332.         'cancel the user's request to close.
  333.      
  334.     END SUB
  335.      
  336.     SUB __UI_Click (id AS LONG)
  337.         SELECT CASE id
  338.             CASE Calculator
  339.      
  340.             CASE frmResults
  341.      
  342.             CASE mnuEdit
  343.      
  344.             CASE mnuHelp
  345.      
  346.                 ': memory buttons: ----------------------------------------------------------------------------------------
  347.      
  348.             CASE butMC '                                                    memory clear clicked
  349.                 memory = 0 '                                                reset memory value
  350.      
  351.             CASE butMR '                                                    memory recall clicked
  352.                 IF memory THEN '                                            memory available?
  353.                     operand$ = CLEAN$(memory) '                             Yes, make it the current operand
  354.                     resetoperand = True '                                   trigger an operand reset
  355.                 END IF
  356.      
  357.             CASE butMS '                                                    memory store clicked
  358.                 memory = VAL(operand$) '                                    overwrite memory with current operand
  359.                 resetoperand = True '                                       trigger an operand reset
  360.      
  361.             CASE butMplus '                                                 memory addition clicked
  362.                 memory = memory + VAL(operand$) '                           add current operand to memory
  363.                 resetoperand = True '                                       trigger an operand reset
  364.      
  365.             CASE butMminus '                                                memory subtraction clicked
  366.                 memory = memory - VAL(operand$) '                           subtract current operand from memory
  367.                 resetoperand = True '                                       trigger an operand reset
  368.      
  369.                 ': clear buttons: -----------------------------------------------------------------------------------------
  370.      
  371.             CASE butCE '                                                    clear entry clicked
  372.                 operand$ = "" '                                             reset current operand
  373.      
  374.             CASE butC '                                                     clear clicked
  375.                 operand1 = 0 '                                              initialize all values
  376.                 operand2 = 0
  377.                 operator = 0
  378.                 previousoperator = 0
  379.                 operand$ = ""
  380.                 history$ = ""
  381.      
  382.             CASE butBS '                                                    backspace clicked
  383.                 IF LEN(operand$) THEN '                                     characters in operand?
  384.                     operand$ = LEFT$(operand$, LEN(operand$) - 1) '         yes, remove right-most character
  385.                 END IF
  386.      
  387.                 ': calculation buttons: -----------------------------------------------------------------------------------
  388.      
  389.             CASE butReciprocate '                                           reciprocate clicked
  390.                 IF VAL(operand$) THEN '                                     dividing by zero?
  391.      
  392.                     ADDHISTORY (operator$(previousoperator) + "Reciproc(" + operand$ + ")")
  393.                     nohistory = True '                                      skip operand history next time
  394.                     operator = EQUATE
  395.      
  396.                     operand$ = CLEAN$(1 / VAL(operand$)) '                  no, calculate reciprocate
  397.                 ELSE '                                                      yes, physics will collapse!
  398.                     ALERT '                                                 get user's attention
  399.                     operand$ = "Can't divide by zero!" '                    report error to user
  400.                 END IF
  401.                 resetoperand = True '                                       trigger an operand reset
  402.      
  403.             CASE butSQR '                                                   square root clicked
  404.                 IF VAL(operand$) >= 0 THEN '                                positive value?
  405.      
  406.                     ADDHISTORY (operator$(previousoperator) + "SQRT(" + operand$ + ")")
  407.                     nohistory = True '                                      skip operand history next time
  408.                     operator = EQUATE
  409.      
  410.                     operand$ = CLEAN$(SQR(VAL(operand$))) '                 yes, calculate square root
  411.                 ELSE '                                                      no, value is negative
  412.                     ALERT '                                                 get user's attention
  413.                     operand$ = "Invalid input!" '                           nice try buddy
  414.                 END IF
  415.                 resetoperand = True '                                       trigger an operand reset
  416.      
  417.             CASE butPercent '                                               percent clicked
  418.                 operand$ = CLEAN$(operand1 * VAL(operand$) / 100) '         calculate percentage of previous operand
  419.                 resetoperand = True
  420.      
  421.             CASE butSign '                                                  sign clicked
  422.                 IF VAL(operand$) THEN '                                     value equal to zero?
  423.                     operand$ = CLEAN$(-VAL(operand$)) '                     no, reverse sign of operand
  424.                 END IF
  425.      
  426.                 ': number buttons: ----------------------------------------------------------------------------------------
  427.      
  428.             CASE but0 '                                                     zero clicked
  429.                 IF VAL(operand$) OR INSTR(operand$, ".") THEN '             ok to add a zero?
  430.                     UPDATEOPERAND ("0") '                                   yes, append zero
  431.                 END IF
  432.      
  433.             CASE but1 '                                                     one clicked
  434.                 UPDATEOPERAND ("1") '                                       append one
  435.      
  436.             CASE but2 '                                                     etc..
  437.                 UPDATEOPERAND ("2") '                                       etc..
  438.      
  439.             CASE but3
  440.                 UPDATEOPERAND ("3")
  441.      
  442.             CASE but4
  443.                 UPDATEOPERAND ("4")
  444.      
  445.             CASE but5
  446.                 UPDATEOPERAND ("5")
  447.      
  448.             CASE but6
  449.                 UPDATEOPERAND ("6")
  450.      
  451.             CASE but7
  452.                 UPDATEOPERAND ("7")
  453.      
  454.             CASE but8
  455.                 UPDATEOPERAND ("8")
  456.      
  457.             CASE but9
  458.                 UPDATEOPERAND ("9")
  459.      
  460.             CASE butPoint
  461.                 UPDATEOPERAND (".")
  462.      
  463.                 ': operator buttons: --------------------------------------------------------------------------------------
  464.      
  465.             CASE butDivide '                                                divide clicked
  466.      
  467.                 ADDHISTORY (operator$(previousoperator) + operand$)
  468.      
  469.                 operator = DIVISION '                                       remember operator selected
  470.                 COMMITOPERAND '                                             save operand
  471.      
  472.             CASE butMultiply '                                              multiply clicked
  473.      
  474.                 ADDHISTORY (operator$(previousoperator) + operand$)
  475.      
  476.                 operator = MULTIPLICATION '                                 remember operator selected
  477.                 COMMITOPERAND '                                             save operand
  478.      
  479.             CASE butSubtract '                                              subtract clicked
  480.      
  481.                 ADDHISTORY (operator$(previousoperator) + operand$)
  482.      
  483.                 operator = SUBTRACTION '                                    remember operator selected
  484.                 COMMITOPERAND '                                             save operand
  485.      
  486.             CASE butAdd '                                                   addition clicked
  487.      
  488.                 ADDHISTORY (operator$(previousoperator) + operand$)
  489.      
  490.                 operator = ADDITION '                                       remember operator selected
  491.                 COMMITOPERAND '                                             save operand
  492.      
  493.             CASE butEqual '                                                 equal clicked
  494.      
  495.                 history$ = ""
  496.                 operator = EQUATE '                                         remember operator selected
  497.                 COMMITOPERAND '                                             save operand
  498.                 previousoperator = 0
  499.      
  500.      
  501.             CASE mnuCopy
  502.      
  503.             CASE mnuPaste
  504.      
  505.             CASE mnuAbout
  506.                 operand$ = "InForm Calculator 1.0"
  507.                 resetoperand = True
  508.      
  509.             CASE lblAnswer
  510.      
  511.             CASE lblMemory
  512.      
  513.             CASE lblHistory
  514.      
  515.         END SELECT
  516.     END SUB
  517.      
  518.     SUB __UI_MouseEnter (id AS LONG)
  519.         SELECT CASE id
  520.             CASE Calculator
  521.      
  522.             CASE frmResults
  523.      
  524.             CASE mnuEdit
  525.      
  526.             CASE mnuHelp
  527.      
  528.             CASE butMC
  529.      
  530.             CASE butMR
  531.      
  532.             CASE butMS
  533.      
  534.             CASE butMplus
  535.      
  536.             CASE butMminus
  537.      
  538.             CASE butBS
  539.      
  540.             CASE butCE
  541.      
  542.             CASE butC
  543.      
  544.             CASE butSign
  545.      
  546.             CASE butSQR
  547.      
  548.             CASE but7
  549.      
  550.             CASE but8
  551.      
  552.             CASE but9
  553.      
  554.             CASE butDivide
  555.      
  556.             CASE butPercent
  557.      
  558.             CASE but4
  559.      
  560.             CASE but5
  561.      
  562.             CASE but6
  563.      
  564.             CASE butMultiply
  565.      
  566.             CASE butReciprocate
  567.      
  568.             CASE but1
  569.      
  570.             CASE but2
  571.      
  572.             CASE but3
  573.      
  574.             CASE butSubtract
  575.      
  576.             CASE but0
  577.      
  578.             CASE butPoint
  579.      
  580.             CASE butAdd
  581.      
  582.             CASE butEqual
  583.      
  584.             CASE mnuCopy
  585.      
  586.             CASE mnuPaste
  587.      
  588.             CASE mnuAbout
  589.      
  590.             CASE lblAnswer
  591.      
  592.             CASE lblMemory
  593.      
  594.             CASE lblHistory
  595.      
  596.         END SELECT
  597.     END SUB
  598.      
  599.     SUB __UI_MouseLeave (id AS LONG)
  600.         SELECT CASE id
  601.             CASE Calculator
  602.      
  603.             CASE frmResults
  604.      
  605.             CASE mnuEdit
  606.      
  607.             CASE mnuHelp
  608.      
  609.             CASE butMC
  610.      
  611.             CASE butMR
  612.      
  613.             CASE butMS
  614.      
  615.             CASE butMplus
  616.      
  617.             CASE butMminus
  618.      
  619.             CASE butBS
  620.      
  621.             CASE butCE
  622.      
  623.             CASE butC
  624.      
  625.             CASE butSign
  626.      
  627.             CASE butSQR
  628.      
  629.             CASE but7
  630.      
  631.             CASE but8
  632.      
  633.             CASE but9
  634.      
  635.             CASE butDivide
  636.      
  637.             CASE butPercent
  638.      
  639.             CASE but4
  640.      
  641.             CASE but5
  642.      
  643.             CASE but6
  644.      
  645.             CASE butMultiply
  646.      
  647.             CASE butReciprocate
  648.      
  649.             CASE but1
  650.      
  651.             CASE but2
  652.      
  653.             CASE but3
  654.      
  655.             CASE butSubtract
  656.      
  657.             CASE but0
  658.      
  659.             CASE butPoint
  660.      
  661.             CASE butAdd
  662.      
  663.             CASE butEqual
  664.      
  665.             CASE mnuCopy
  666.      
  667.             CASE mnuPaste
  668.      
  669.             CASE mnuAbout
  670.      
  671.             CASE lblAnswer
  672.      
  673.             CASE lblMemory
  674.      
  675.             CASE lblHistory
  676.      
  677.         END SELECT
  678.     END SUB
  679.      
  680.     SUB __UI_FocusIn (id AS LONG)
  681.         SELECT CASE id
  682.             CASE butMC
  683.      
  684.             CASE butMR
  685.      
  686.             CASE butMS
  687.      
  688.             CASE butMplus
  689.      
  690.             CASE butMminus
  691.      
  692.             CASE butBS
  693.      
  694.             CASE butCE
  695.      
  696.             CASE butC
  697.      
  698.             CASE butSign
  699.      
  700.             CASE butSQR
  701.      
  702.             CASE but7
  703.      
  704.             CASE but8
  705.      
  706.             CASE but9
  707.      
  708.             CASE butDivide
  709.      
  710.             CASE butPercent
  711.      
  712.             CASE but4
  713.      
  714.             CASE but5
  715.      
  716.             CASE but6
  717.      
  718.             CASE butMultiply
  719.      
  720.             CASE butReciprocate
  721.      
  722.             CASE but1
  723.      
  724.             CASE but2
  725.      
  726.             CASE but3
  727.      
  728.             CASE butSubtract
  729.      
  730.             CASE but0
  731.      
  732.             CASE butPoint
  733.      
  734.             CASE butAdd
  735.      
  736.             CASE butEqual
  737.      
  738.         END SELECT
  739.     END SUB
  740.      
  741.     SUB __UI_FocusOut (id AS LONG)
  742.         'This event occurs right before a control loses focus.
  743.         'To prevent a control from losing focus, set __UI_KeepFocus = True below.
  744.         SELECT CASE id
  745.             CASE butMC
  746.      
  747.             CASE butMR
  748.      
  749.             CASE butMS
  750.      
  751.             CASE butMplus
  752.      
  753.             CASE butMminus
  754.      
  755.             CASE butBS
  756.      
  757.             CASE butCE
  758.      
  759.             CASE butC
  760.      
  761.             CASE butSign
  762.      
  763.             CASE butSQR
  764.      
  765.             CASE but7
  766.      
  767.             CASE but8
  768.      
  769.             CASE but9
  770.      
  771.             CASE butDivide
  772.      
  773.             CASE butPercent
  774.      
  775.             CASE but4
  776.      
  777.             CASE but5
  778.      
  779.             CASE but6
  780.      
  781.             CASE butMultiply
  782.      
  783.             CASE butReciprocate
  784.      
  785.             CASE but1
  786.      
  787.             CASE but2
  788.      
  789.             CASE but3
  790.      
  791.             CASE butSubtract
  792.      
  793.             CASE but0
  794.      
  795.             CASE butPoint
  796.      
  797.             CASE butAdd
  798.      
  799.             CASE butEqual
  800.      
  801.         END SELECT
  802.     END SUB
  803.      
  804.     SUB __UI_MouseDown (id AS LONG)
  805.         SELECT CASE id
  806.             CASE Calculator
  807.      
  808.             CASE frmResults
  809.      
  810.             CASE mnuEdit
  811.      
  812.             CASE mnuHelp
  813.      
  814.             CASE butMC
  815.      
  816.             CASE butMR
  817.      
  818.             CASE butMS
  819.      
  820.             CASE butMplus
  821.      
  822.             CASE butMminus
  823.      
  824.             CASE butBS
  825.      
  826.             CASE butCE
  827.      
  828.             CASE butC
  829.      
  830.             CASE butSign
  831.      
  832.             CASE butSQR
  833.      
  834.             CASE but7
  835.      
  836.             CASE but8
  837.      
  838.             CASE but9
  839.      
  840.             CASE butDivide
  841.      
  842.             CASE butPercent
  843.      
  844.             CASE but4
  845.      
  846.             CASE but5
  847.      
  848.             CASE but6
  849.      
  850.             CASE butMultiply
  851.      
  852.             CASE butReciprocate
  853.      
  854.             CASE but1
  855.      
  856.             CASE but2
  857.      
  858.             CASE but3
  859.      
  860.             CASE butSubtract
  861.      
  862.             CASE but0
  863.      
  864.             CASE butPoint
  865.      
  866.             CASE butAdd
  867.      
  868.             CASE butEqual
  869.      
  870.             CASE mnuCopy
  871.      
  872.             CASE mnuPaste
  873.      
  874.             CASE mnuAbout
  875.      
  876.             CASE lblAnswer
  877.      
  878.             CASE lblMemory
  879.      
  880.             CASE lblHistory
  881.      
  882.         END SELECT
  883.     END SUB
  884.      
  885.     SUB __UI_MouseUp (id AS LONG)
  886.         SELECT CASE id
  887.             CASE Calculator
  888.      
  889.             CASE frmResults
  890.      
  891.             CASE mnuEdit
  892.      
  893.             CASE mnuHelp
  894.      
  895.             CASE butMC
  896.      
  897.             CASE butMR
  898.      
  899.             CASE butMS
  900.      
  901.             CASE butMplus
  902.      
  903.             CASE butMminus
  904.      
  905.             CASE butBS
  906.      
  907.             CASE butCE
  908.      
  909.             CASE butC
  910.      
  911.             CASE butSign
  912.      
  913.             CASE butSQR
  914.      
  915.             CASE but7
  916.      
  917.             CASE but8
  918.      
  919.             CASE but9
  920.      
  921.             CASE butDivide
  922.      
  923.             CASE butPercent
  924.      
  925.             CASE but4
  926.      
  927.             CASE but5
  928.      
  929.             CASE but6
  930.      
  931.             CASE butMultiply
  932.      
  933.             CASE butReciprocate
  934.      
  935.             CASE but1
  936.      
  937.             CASE but2
  938.      
  939.             CASE but3
  940.      
  941.             CASE butSubtract
  942.      
  943.             CASE but0
  944.      
  945.             CASE butPoint
  946.      
  947.             CASE butAdd
  948.      
  949.             CASE butEqual
  950.      
  951.             CASE mnuCopy
  952.      
  953.             CASE mnuPaste
  954.      
  955.             CASE mnuAbout
  956.      
  957.             CASE lblAnswer
  958.      
  959.             CASE lblMemory
  960.      
  961.             CASE lblHistory
  962.      
  963.         END SELECT
  964.     END SUB
  965.      
  966.     SUB __UI_KeyPress (id AS LONG)
  967.         'When this event is fired, __UI_KeyHit will contain the code of the key hit.
  968.         'You can change it and even cancel it by making it = 0
  969.      
  970.         SELECT CASE id
  971.             CASE butMC
  972.      
  973.             CASE butMR
  974.      
  975.             CASE butMS
  976.      
  977.             CASE butMplus
  978.      
  979.             CASE butMminus
  980.      
  981.             CASE butBS
  982.      
  983.             CASE butCE
  984.      
  985.             CASE butC
  986.      
  987.             CASE butSign
  988.      
  989.             CASE butSQR
  990.      
  991.             CASE but7
  992.      
  993.             CASE but8
  994.      
  995.             CASE but9
  996.      
  997.             CASE butDivide
  998.      
  999.             CASE butPercent
  1000.      
  1001.             CASE but4
  1002.      
  1003.             CASE but5
  1004.      
  1005.             CASE but6
  1006.      
  1007.             CASE butMultiply
  1008.      
  1009.             CASE butReciprocate
  1010.      
  1011.             CASE but1
  1012.      
  1013.             CASE but2
  1014.      
  1015.             CASE but3
  1016.      
  1017.             CASE butSubtract
  1018.      
  1019.             CASE but0
  1020.      
  1021.             CASE butPoint
  1022.      
  1023.             CASE butAdd
  1024.      
  1025.             CASE butEqual
  1026.      
  1027.         END SELECT
  1028.     END SUB
  1029.      
  1030.     SUB __UI_TextChanged (id AS LONG)
  1031.         SELECT CASE id
  1032.         END SELECT
  1033.     END SUB
  1034.      
  1035.     SUB __UI_ValueChanged (id AS LONG)
  1036.         SELECT CASE id
  1037.         END SELECT
  1038.     END SUB
  1039.      
  1040.     SUB __UI_FormResized
  1041.      
  1042.     END SUB
  1043.  

Calculator Screenshot.jpg

 
                                                                                                                                         (175 downloads previously)

14
Audio / Drum Machine Prototype by Dav
« on: September 23, 2021, 05:41:59 am »
Drum Machine Prototype

Author: @Dav
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2459.msg117923#msg117923
Version: v0.1c

Description:
Here's a drum machine, or beat maker.  I started making another puzzle game, but it turned into a little music making program instead.   With this you can make drum beats using 14 drum instrument samples.

Controls:
L Load Pattern
S Save Pattern
M Toggle Metronome

Source Code:
The code is given here for reference.  You will need to load all the files from the .zip.
Code: QB64: [Select]
  1.     '=======================
  2.     'DRUMMACHINE.BAS - v0.1c
  3.     '=======================
  4.     'QB64 Drum machine
  5.     'Make drum beats using 16 drum sounds.
  6.     'Coded by Dav for QB64, MAY/2020
  7.      
  8.     'Follow this programs development here:
  9.     'https://www.qb64.org/forum/index.php?topic=2459.0
  10.      
  11.     '===================================================================
  12.     'New in v0.1c...
  13.      
  14.     'Added: Added program _TITLE and _ICON.
  15.     'Added: New logo with keyboard command help.
  16.     'Added: Shows big TEMPO (BMP) font at top left.
  17.     'Added: Shows green playing position line down grid.
  18.     '       (replaced little white moving marker)
  19.     'Added: Give user notices when a Save/Load is done.
  20.     'Added: Instrument names can now be clicked on to mute/unmute.
  21.     'Added: Now shows on screen if metronome is ON/OFF
  22.     'Fixed: Changed keyboard input method. Much more responsive.
  23.     '
  24.     '===================================================================
  25.     ''NOTE: You need "\drummachine-data\" and all of its data files!
  26.     '===================================================================
  27.      
  28.     '=====
  29.     'ABOUT:
  30.     '=====
  31.      
  32.     'This is a very basic drum machine with limited capabilities.
  33.     'With it you can program beats (limited to 2 bars of 4/4 now).
  34.     'It uses 16 real drum sounds to make a real sound drum beat.
  35.     'Drum patterns can be saved and loaded by file DRUMMACHINE.SAV.
  36.     'I just wanted to see if QB64 can handle something like this,
  37.     'and it looks like it can.  So a more serious program can be tackled.
  38.     'The real drum sound samples were all found in public domain.
  39.      
  40.     '==========
  41.     'HOW TO USE:
  42.     '==========
  43.      
  44.     'The grid represents bars and notes that you can click on.
  45.     'Click on squares in a row to to add sound for that beat.
  46.     'Click an square again to turn it back off or change it's volume.
  47.     'A bright red square is loudest, a darker red is softer volume.
  48.      
  49.     'Click on the instrument name on left screen to mute/unmute it.
  50.      
  51.     'The following keys can be used as well:
  52.      
  53.     '* +/- keys:  Speeds up and slow down tempo (shown upper left)
  54.     '* SPACE key: Will pause and resume the playback.
  55.     '* ENTER:     Resets current playback marker to the beginning.
  56.     '* M:         Turns on/off metonome click sound (default is on)
  57.     '* C:         Clears the playing grid (starts over).
  58.     '* L:         Loads last saved grid pattern from DRUMMACHINE.SAV
  59.     '* S:         Saves current grid pattern to DRUMMACHINE.SAV.
  60.     '* D:         Enters drawing mode (fast filling of boxes.
  61.     '             (While in it, enter ESC to exit drawing mode)
  62.     '* ESC:       Exits program. DOES NOT ATUMATICALLY SAVE ON EXIT.
  63.      
  64.     '======================================================================
  65.      
  66.     $EXEICON:'.\drummachine-data\icon.ico'
  67.     _ICON
  68.      
  69.     'define playing grid and button deminsions
  70.     DIM SHARED row: row = 16 'rows in playing grid
  71.     DIM SHARED col: col = 8 * 4 'columns in grid (8 beats, 4 boxes per beat)
  72.     DIM SHARED size: size = 30 ' pixel size of buttons
  73.     DIM SHARED buttons: buttons = row * col ' total number of buttons on playing grid
  74.      
  75.     'define button data
  76.     DIM SHARED buttonv(row * col) ' num data for button
  77.     DIM SHARED buttonx(row * col), buttony(row * col) 'top x/y cords of buttons
  78.     DIM SHARED buttonx2(row * col), buttony2(row * col) ' bottom x/y cords of buttons
  79.      
  80.     'define intrument name data
  81.     DIM SHARED instv(row * col) 'value for is intrument on or off
  82.     DIM SHARED instx(row * col), insty(row * col) 'top x/y cords of instr names
  83.      
  84.     'share these sound files
  85.     DIM SHARED crash&, crash2&, ride&, ride2&, hhopen&, hhclosed&, snare&, kick&, tamb&, gong2&
  86.     DIM SHARED tomhigh&, tommid&, tomlow&, cowbell&, shaker&, gong&, vibraslap&, vibraslap2&
  87.     DIM SHARED clave&, trianglelong&, triangleshort&
  88.      
  89.     '====================================================
  90.      
  91.     'Set screen based on grid deminsions
  92.      
  93.     SCREEN _NEWIMAGE(size * col + 100, size * row + 100, 32)
  94.     DO: LOOP UNTIL _SCREENEXISTS 'Make sure window exists before TITLE used.
  95.      
  96.     _TITLE "QB64 Drum Machine"
  97.      
  98.     '===================================================
  99.      
  100.     CLS , _RGB(42, 42, 42)
  101.      
  102.     'Load title top area.
  103.     ttmp = _LOADIMAGE("drummachine-data\title.png")
  104.     _PUTIMAGE (5, 5), ttmp: _FREEIMAGE ttmp
  105.      
  106.     'Load media sounds used
  107.     click& = _SNDOPEN("drummachine-data\click.ogg")
  108.     hhopen& = _SNDOPEN("drummachine-data\hhopen.ogg")
  109.     hhclosed& = _SNDOPEN("drummachine-data\hhclosed.ogg")
  110.     kick& = _SNDOPEN("drummachine-data\kick.ogg")
  111.     snare& = _SNDOPEN("drummachine-data\snare.ogg")
  112.     crash& = _SNDOPEN("drummachine-data\crash.ogg")
  113.     crash2& = _SNDOPEN("drummachine-data\crash.ogg")
  114.     ride& = _SNDOPEN("drummachine-data\ride.ogg")
  115.     ride2& = _SNDOPEN("drummachine-data\ride.ogg")
  116.     tomhigh& = _SNDOPEN("drummachine-data\tomhigh.ogg")
  117.     tommid& = _SNDOPEN("drummachine-data\tommid.ogg")
  118.     tomlow& = _SNDOPEN("drummachine-data\tomlow.ogg")
  119.     cowbell& = _SNDOPEN("drummachine-data\cowbell.ogg")
  120.     shaker& = _SNDOPEN("drummachine-data\shaker.ogg")
  121.     vibraslap& = _SNDOPEN("drummachine-data\vibraslap.ogg")
  122.     gong& = _SNDOPEN("drummachine-data\gong.ogg")
  123.     vibraslap2& = _SNDOPEN("drummachine-data\vibraslap.ogg")
  124.     gong2& = _SNDOPEN("drummachine-data\gong.ogg")
  125.     tamb& = _SNDOPEN("drummachine-data\tamb.ogg")
  126.     clave& = _SNDOPEN("drummachine-data\clave.ogg")
  127.     trianglelong& = _SNDOPEN("drummachine-data\trianglelong.ogg")
  128.     triangleshort& = _SNDOPEN("drummachine-data\triangleshort.ogg")
  129.      
  130.     'Load special number font images fro BMP display
  131.     DIM SHARED num&(0 TO 9)
  132.     FOR t = 0 TO 9
  133.         n$ = LTRIM$(RTRIM$(STR$(t)))
  134.         num&(t) = _LOADIMAGE("drummachine-data\font\" + n$ + ".png")
  135.     NEXT
  136.      
  137.      
  138.     '===================================================
  139.      
  140.     'Set program defaults
  141.      
  142.     beats = 8 'number of beats in pattern
  143.     tempo = 80 'tempo of drum pattern
  144.     curbeat = 1 'start at bar 1
  145.     clickon = 1 'turn on click sound, on the beat
  146.     playing = 1 'Pattern is playing
  147.     firstlaunch = 1 'flag to know when program first launches
  148.      
  149.      
  150.     '=========================================================
  151.     START:
  152.     '========
  153.      
  154.     'Init the grids button values (x/y, data)
  155.     bc = 1 'counter
  156.     FOR r = 1 TO row
  157.         FOR c = 1 TO col
  158.             x = (c * size) + 100: y = (r * size) + 100
  159.             buttonx(bc) = x - size: buttonx2(bc) = x ' generate x/y values
  160.             buttony(bc) = y - size: buttony2(bc) = y
  161.             buttonv(bc) = 0 'default button is OFF
  162.             bc = bc + 1
  163.         NEXT
  164.     NEXT
  165.      
  166.     'Show metronome on/off
  167.     Metronome clickon
  168.      
  169.     'Show the grid buttons
  170.     bc = 1
  171.     FOR r = 1 TO row
  172.         FOR c = 1 TO col
  173.             Show "drummachine-data\off.jpg", buttonx(bc), buttony(bc), 0
  174.             bc = bc + 1
  175.         NEXT
  176.     NEXT
  177.      
  178.      
  179.     'Draw beat lines, every 4 squares ...
  180.     bc = 1
  181.     FOR c = 1 TO col STEP 4
  182.         LINE (buttonx(bc), buttony(bc))-(buttonx(bc), buttony(bc) + (size * row)), _RGB(128, 128, 0), B
  183.         bc = bc + 4
  184.     NEXT
  185.      
  186.     '====================================
  187.      
  188.     'Init Instrument name data
  189.     FOR c = 1 TO 16
  190.         instv(c) = 1 'all instruments on by default
  191.     NEXT
  192.     bc = 1
  193.     FOR c = 1 TO col * row STEP col
  194.         instx(bc) = 0: insty(bc) = 70 + (bc * 30)
  195.         bc = bc + 1
  196.     NEXT
  197.     'show the nstrument names
  198.     FOR c = 1 TO 16
  199.         ShowInst c, instx(c), insty(c)
  200.     NEXT
  201.      
  202.     '==============================================
  203.      
  204.     'Show current TEMPO (BMP) on upper left
  205.     FPRINT 140, 15, 20, 40, LTRIM$(RTRIM$(STR$(tempo)))
  206.      
  207.     '================================================
  208.      
  209.     'If firstlaunch, load the saved pattern file
  210.     IF firstlaunch = 1 THEN
  211.         firstlaunch = 0
  212.         GOSUB loadfile
  213.     END IF
  214.      
  215.     '============================================================
  216.      
  217.     MAIN:
  218.     '=====
  219.      
  220.     'Main Loop here
  221.     DO
  222.      
  223.         GOSUB GetUserInput
  224.      
  225.         IF playing THEN
  226.      
  227.             IF clickon THEN
  228.                 SELECT CASE curbeat
  229.                     CASE 1, 2, 3, 4, 5, 6, 7, 8: _SNDPLAY click&
  230.                 END SELECT
  231.             END IF
  232.      
  233.             IF curbeat = 1 THEN PlayBeat (1)
  234.             IF curbeat = 1.25 THEN PlayBeat (2)
  235.             IF curbeat = 1.50 THEN PlayBeat (3)
  236.             IF curbeat = 1.75 THEN PlayBeat (4)
  237.             IF curbeat = 2 THEN PlayBeat (5)
  238.             IF curbeat = 2.25 THEN PlayBeat (6)
  239.             IF curbeat = 2.50 THEN PlayBeat (7)
  240.             IF curbeat = 2.75 THEN PlayBeat (8)
  241.             IF curbeat = 3 THEN PlayBeat (9)
  242.             IF curbeat = 3.25 THEN PlayBeat (10)
  243.             IF curbeat = 3.50 THEN PlayBeat (11)
  244.             IF curbeat = 3.75 THEN PlayBeat (12)
  245.             IF curbeat = 4 THEN PlayBeat (13)
  246.             IF curbeat = 4.25 THEN PlayBeat (14)
  247.             IF curbeat = 4.50 THEN PlayBeat (15)
  248.             IF curbeat = 4.75 THEN PlayBeat (16)
  249.             IF curbeat = 5 THEN PlayBeat (17)
  250.             IF curbeat = 5.25 THEN PlayBeat (18)
  251.             IF curbeat = 5.50 THEN PlayBeat (19)
  252.             IF curbeat = 5.75 THEN PlayBeat (20)
  253.             IF curbeat = 6 THEN PlayBeat (21)
  254.             IF curbeat = 6.25 THEN PlayBeat (22)
  255.             IF curbeat = 6.50 THEN PlayBeat (23)
  256.             IF curbeat = 6.75 THEN PlayBeat (24)
  257.             IF curbeat = 7 THEN PlayBeat (25)
  258.             IF curbeat = 7.25 THEN PlayBeat (26)
  259.             IF curbeat = 7.50 THEN PlayBeat (27)
  260.             IF curbeat = 7.75 THEN PlayBeat (28)
  261.             IF curbeat = 8 THEN PlayBeat (29)
  262.             IF curbeat = 8.25 THEN PlayBeat (30)
  263.             IF curbeat = 8.50 THEN PlayBeat (31)
  264.             IF curbeat = 8.75 THEN PlayBeat (32)
  265.      
  266.             curbeat = curbeat + .25
  267.             IF curbeat > beats + .75 THEN curbeat = 1
  268.      
  269.             'Delay routine, based on TEMP
  270.             d1 = TIMER
  271.             DO
  272.                 d2 = TIMER
  273.      
  274.                 'still get user input while delaying....
  275.                 GOSUB GetUserInput
  276.      
  277.             LOOP UNTIL d2 - d1 >= (60 / 4 / tempo)
  278.      
  279.         END IF
  280.      
  281.     LOOP
  282.      
  283.     '===============================
  284.      
  285.     EndProgram:
  286.      
  287.     _SNDCLOSE click&
  288.     _SNDCLOSE hhopen&
  289.     _SNDCLOSE hhclosed&
  290.     _SNDCLOSE kick&
  291.     _SNDCLOSE snare&
  292.     _SNDCLOSE crash&
  293.     _SNDCLOSE crash2&
  294.     _SNDCLOSE ride&
  295.     _SNDCLOSE ride2&
  296.     _SNDCLOSE tomhigh&
  297.     _SNDCLOSE tommid&
  298.     _SNDCLOSE tomlow&
  299.     _SNDCLOSE cowbell&
  300.     _SNDCLOSE shaker&
  301.     _SNDCLOSE vibraslap&
  302.     _SNDCLOSE gong&
  303.     _SNDCLOSE vibraslap2&
  304.     _SNDCLOSE gong2&
  305.     _SNDCLOSE tamb&
  306.     _SNDCLOSE clave&
  307.     _SNDCLOSE trianglelong&
  308.     _SNDCLOSE triangleshort&
  309.      
  310.     END
  311.      
  312.      
  313.      
  314.     '================================================
  315.     GetUserInput:
  316.     '============
  317.      
  318.     trap = _MOUSEINPUT
  319.      
  320.     'if left mouse button clicked
  322.      
  323.         mx = _MOUSEX: my = _MOUSEY 'current mouse position
  324.      
  325.         'see if a grid button was pressed
  326.         FOR t = 1 TO buttons
  327.             bx = buttonx(t): bx2 = buttonx2(t)
  328.             by = buttony(t): by2 = buttony2(t)
  329.      
  330.             'If clicked on a grid button...
  331.             IF mx >= bx AND mx <= bx2 AND my >= by AND my <= by2 THEN
  332.                 IF _MOUSEBUTTON(1) THEN
  333.      
  334.                     'change its value...
  335.                     buttonv(t) = buttonv(t) + 1
  336.                     IF buttonv(t) > 2 THEN buttonv(t) = 0
  337.                     'LOCATE 1, 1: PRINT t   'for testing purposes...
  338.                     SELECT CASE buttonv(t)
  339.                         CASE 0: Show "drummachine-data\off.jpg", buttonx(t), buttony(t), 0
  340.                         CASE 1: Show "drummachine-data\hot.jpg", buttonx(t), buttony(t), 0
  341.                         CASE 2: Show "drummachine-data\med.jpg", buttonx(t), buttony(t), 0
  342.                     END SELECT
  343.                 ELSE
  344.                     buttonv(t) = 0
  345.                     Show "drummachine-data\off.jpg", buttonx(t), buttony(t), 0
  346.                 END IF
  347.      
  348.             END IF
  349.         NEXT
  350.      
  351.         'see if a instrument name was pressed
  352.         FOR t = 1 TO 16
  353.             bx = instx(t): bx2 = instx(t) + 100
  354.             by = insty(t): by2 = insty(t) + 30
  355.      
  356.             'If clicked on an instrument name...
  357.             IF mx >= bx AND mx <= bx2 AND my >= by AND my <= by2 THEN
  358.                 IF _MOUSEBUTTON(1) THEN
  359.      
  360.                     'change its value...
  361.                     instv(t) = instv(t) + 1
  362.                     IF instv(t) > 1 THEN instv(t) = 0
  363.                     'redraw instrument name here
  364.                     ShowInst t, instx(t), insty(t)
  365.                 END IF
  366.      
  367.             END IF
  368.         NEXT
  369.      
  370.      
  371.         IF _MOUSEBUTTON(1) THEN
  372.             'wait until mouse button up to continue
  373.             WHILE _MOUSEBUTTON(1) <> 0: n = _MOUSEINPUT: WEND
  374.         END IF
  375.      
  376.     END IF
  377.      
  378.      
  379.     'check is user made a keypress
  380.      
  382.      
  383.         CASE "D": 'd enters drawing mode
  384.             DO
  385.                 trap = _MOUSEINPUT
  386.                 IF _MOUSEBUTTON(1) OR _MOUSEBUTTON(2) THEN
  387.                     mx = _MOUSEX: my = _MOUSEY
  388.                     'see if a button was pressed
  389.                     FOR t = 1 TO buttons
  390.                         bx = buttonx(t): bx2 = buttonx2(t)
  391.                         by = buttony(t): by2 = buttony2(t)
  392.                         IF mx >= bx AND mx <= bx2 AND my >= by AND my <= by2 THEN
  393.                             IF _MOUSEBUTTON(1) THEN
  394.                                 buttonv(t) = 1
  395.                                 Show "drummachine-data\hot.jpg", buttonx(t), buttony(t), 0
  396.                             ELSE
  397.                                 buttonv(t) = 0
  398.                                 Show "drummachine-data\off.jpg", buttonx(t), buttony(t), 0
  399.                             END IF
  400.                         END IF
  401.                     NEXT
  402.                 END IF
  403.             LOOP UNTIL INKEY$ = CHR$(27)
  404.      
  405.         CASE "C": GOTO START 'C clears playing grid, starts over
  406.      
  407.         CASE "S": 's = saves current pattern to file
  408.             backtmp& = _COPYIMAGE(_DISPLAY)
  409.             f$ = "drummachine-data\savingpattern.png"
  410.             ttmp = _LOADIMAGE(f$)
  411.             _PUTIMAGE (350, 250), ttmp: _FREEIMAGE ttmp
  412.             _DELAY 1
  413.             OPEN "drummachine.sav" FOR OUTPUT AS #3
  414.             PRINT #3, MKI$(tempo);
  415.             PRINT #3, MKI$(buttons);
  416.             FOR fs = 1 TO buttons
  417.                 PRINT #3, MKI$(buttonv(fs));
  418.             NEXT
  419.             CLOSE #3
  420.             _PUTIMAGE (0, 0), backtmp&
  421.      
  422.         CASE "L"
  423.             backtmp& = _COPYIMAGE(_DISPLAY)
  424.             f$ = "drummachine-data\loadingpattern.png"
  425.             ttmp = _LOADIMAGE(f$)
  426.             _PUTIMAGE (350, 250), ttmp: _FREEIMAGE ttmp
  427.             _DELAY .5
  428.             _PUTIMAGE (0, 0), backtmp&
  429.             GOSUB loadfile
  430.      
  431.         CASE " " 'SPACE pauses and resumes playing
  432.             IF playing = 1 THEN
  433.                 playing = 0
  434.             ELSE
  435.                 playing = 1
  436.             END IF
  437.      
  438.         CASE CHR$(13) 'ENTER resets marker to beginning
  439.             'erase all marker positions
  440.             FOR e = 1 TO 32
  441.                 SELECT CASE e
  442.                     CASE 1, 5, 9, 13, 17, 21, 25, 29
  443.                         LINE (buttonx(e), buttony(e))-(buttonx(e), buttony(e) + (size * row)), _RGB(128, 128, 0), B
  444.                     CASE ELSE
  445.                         LINE (buttonx(e), buttony(e))-(buttonx(e), buttony(e) + (size * row)), _RGB(0, 0, 0), B
  446.                 END SELECT
  447.             NEXT
  448.             LINE (buttonx(1), buttony(1))-(buttonx(1), buttony(1) + (size * row)), _RGB(0, 255, 128), B
  449.             curbeat = 1: GOTO MAIN
  450.      
  451.         CASE "M" 'm = turn metronome click on/off
  452.             IF clickon = 1 THEN
  453.                 clickon = 0
  454.             ELSE
  455.                 clickon = 1
  456.             END IF
  457.             Metronome clickon
  458.      
  459.         CASE "+": tempo = tempo + 1: IF tempo > 280 THEN tempo = 280
  460.             FPRINT 140, 15, 20, 40, LTRIM$(RTRIM$(STR$(tempo)))
  461.      
  462.         CASE "-": tempo = tempo - 1: IF tempo < 40 THEN tempo = 40
  463.             FPRINT 140, 15, 20, 40, LTRIM$(RTRIM$(STR$(tempo)))
  464.         CASE CHR$(27): GOTO EndProgram
  465.      
  466.     END SELECT
  467.      
  468.     RETURN
  469.      
  470.      
  471.     '=================================================================
  472.      
  473.     loadfile: 'Loads pattern from save file
  474.     '=======
  475.      
  476.     fil$ = "drummachine.sav"
  477.     IF _FILEEXISTS(fil$) THEN
  478.         OPEN fil$ FOR BINARY AS #3
  479.         IF LOF(3) <= 1028 THEN
  480.             tempo = CVI(INPUT$(2, 3))
  481.             bb = CVI(INPUT$(2, 3))
  482.             FOR b = 1 TO bb
  483.                 buttonv(b) = CVI(INPUT$(2, 3))
  484.                 SELECT CASE buttonv(b)
  485.                     CASE 0: Show "drummachine-data\off.jpg", buttonx(b), buttony(b), 0
  486.                     CASE 1: Show "drummachine-data\hot.jpg", buttonx(b), buttony(b), 0
  487.                     CASE 2: Show "drummachine-data\med.jpg", buttonx(b), buttony(b), 0
  488.                 END SELECT
  489.             NEXT
  490.             CLOSE 3
  491.             'Show current TEMPO (BMP) on upper left
  492.             FPRINT 140, 15, 20, 40, LTRIM$(RTRIM$(STR$(tempo)))
  493.             GOTO MAIN
  494.         ELSE
  495.             CLOSE 3
  496.             'print error message here
  497.         END IF
  498.     END IF
  499.      
  500.     RETURN
  501.      
  502.     '========================================================
  503.      
  504.     SUB Show (nam$, x, y, dly)
  505.         'Loads & puts image filename img$ on screen at x,y
  506.         'dly is optional delay after putting image on screen
  507.         'SUB frees up image handle after loading file.
  508.         ttmp = _LOADIMAGE(nam$)
  509.         _PUTIMAGE (x + 1, y + 1)-(x - 1 + size - 1, y - 1 + size - 1), ttmp: _FREEIMAGE ttmp
  510.         IF dly <> 0 THEN _DELAY dly
  511.     END SUB
  512.      
  513.     '===============================================
  514.      
  515.     SUB ShowInst (num, x, y)
  516.         'This SUB loads the instrumet name image files
  517.         src$ = "drummachine-data\"
  518.         IF instv(num) = 1 THEN pre$ = "_" ELSE pre$ = ""
  519.         IF num = 1 THEN n$ = pre$ + "crash.png"
  520.         IF num = 2 THEN n$ = pre$ + "ride.png"
  521.         IF num = 3 THEN n$ = pre$ + "hhopen.png"
  522.         IF num = 4 THEN n$ = pre$ + "hhclosed.png"
  523.         IF num = 5 THEN n$ = pre$ + "tomhigh.png"
  524.         IF num = 6 THEN n$ = pre$ + "tommid.png"
  525.         IF num = 7 THEN n$ = pre$ + "tomlow.png"
  526.         IF num = 8 THEN n$ = pre$ + "snare.png"
  527.         IF num = 9 THEN n$ = pre$ + "kick.png"
  528.         IF num = 10 THEN n$ = pre$ + "cowbell.png"
  529.         IF num = 11 THEN n$ = pre$ + "shaker.png"
  530.         IF num = 12 THEN n$ = pre$ + "tambourine.png"
  531.         IF num = 13 THEN n$ = pre$ + "vibraslap.png"
  532.         IF num = 14 THEN n$ = pre$ + "gong.png"
  533.         IF num = 15 THEN n$ = pre$ + "triangle.png"
  534.         IF num = 16 THEN n$ = pre$ + "clave.png"
  535.      
  536.         fil$ = src$ + n$
  537.         ttmp = _LOADIMAGE(fil$)
  538.         _PUTIMAGE (x, y), ttmp: _FREEIMAGE ttmp
  539.     END SUB
  540.      
  541.     '===============================================
  542.      
  543.     SUB PlayBeat (num)
  544.         'This SUB plays the sounds on current beat position.
  545.         'It also shows the playing marker moving across the grid
  546.      
  547.         'erase previous marker pos displayed first, and redraw the 4 beat lines...
  548.         IF num = 1 THEN
  549.             'erase the end playing position on grid
  550.             LINE (buttonx(col), buttony(col))-(buttonx(col), buttony(col) + (size * row)), _RGB(0, 0, 0), B
  551.         ELSE
  552.             'erase the last beat position
  553.             LINE (buttonx(num - 1), buttony(num - 1))-(buttonx(num - 1), buttony(num - 1) + (size * row)), _RGB(0, 0, 0), B
  554.             'if last position was one of the 4 beat lines, redraw it
  555.             SELECT CASE (num - 1)
  556.                 CASE 1, 5, 9, 13, 17, 21, 25, 29
  557.                     LINE (buttonx(num - 1), buttony(num - 1))-(buttonx(num - 1), buttony(num - 1) + (size * row)), _RGB(128, 128, 0), B
  558.             END SELECT
  559.         END IF
  560.      
  561.         'Show curreny marker position
  562.         'Now Draw current playing position beat line
  563.         LINE (buttonx(num), buttony(num))-(buttonx(num), buttony(num) + (size * row)), _RGB(0, 255, 128), B
  564.      
  565.         'Play sounds on the current beat position, if inst not muted
  566.         'play crash
  567.         IF instv(1) = 1 THEN
  568.             IF buttonv(num) = 1 THEN _SNDVOL crash&, 6: _SNDPLAY crash& '1
  569.             IF buttonv(num) = 2 THEN _SNDVOL crash2&, .2: _SNDPLAY crash2& '1
  570.         END IF
  571.         'play ride
  572.         IF instv(2) = 1 THEN
  573.             IF buttonv(num + (col * 1)) = 1 THEN _SNDVOL ride&, 5: _SNDPLAY ride& '2
  574.             IF buttonv(num + (col * 1)) = 2 THEN _SNDVOL ride2&, .2: _SNDPLAY ride2& '2
  575.         END IF
  576.         'play hhopen
  577.         IF instv(3) = 1 THEN
  578.             IF buttonv(num + (col * 2)) = 1 THEN _SNDSETPOS hhopen&, 0: _SNDVOL hhopen&, 5: _SNDPLAY hhopen& '3
  579.             IF buttonv(num + (col * 2)) = 2 THEN _SNDSETPOS hhopen&, 0: _SNDVOL hhopen&, .15: _SNDPLAY hhopen& '3
  580.         END IF
  581.         'play hhclosed
  582.         IF instv(4) = 1 THEN
  583.             IF buttonv(num + (col * 3)) = 1 THEN _SNDSTOP hhopen&: _SNDVOL hhclosed&, 1: _SNDPLAY hhclosed& '4
  584.             IF buttonv(num + (col * 3)) = 2 THEN _SNDSTOP hhopen&: _SNDVOL hhclosed&, .2: _SNDPLAY hhclosed& '4
  585.         END IF
  586.         'play tom high
  587.         IF instv(5) THEN
  588.             IF buttonv(num + (col * 4)) = 1 THEN _SNDVOL tomhigh&, 9: _SNDPLAY tomhigh& '5
  589.             IF buttonv(num + (col * 4)) = 2 THEN _SNDVOL tomhigh&, .1: _SNDPLAY tomhigh& '5
  590.         END IF
  591.         'play tom mid
  592.         IF instv(6) THEN
  593.             IF buttonv(num + (col * 5)) = 1 THEN _SNDVOL tommid&, 9: _SNDPLAY tommid& '6
  594.             IF buttonv(num + (col * 5)) = 2 THEN _SNDVOL tommid&, .1: _SNDPLAY tommid& '6
  595.         END IF
  596.         'play tom low
  597.         IF instv(7) THEN
  598.             IF buttonv(num + (col * 6)) = 1 THEN _SNDVOL tomlow&, 9: _SNDPLAY tomlow& '7
  599.             IF buttonv(num + (col * 6)) = 2 THEN _SNDVOL tomlow&, .1: _SNDPLAY tomlow& '7
  600.         END IF
  601.         'play snare
  602.         IF instv(8) THEN
  603.             IF buttonv(num + (col * 7)) = 1 THEN _SNDVOL snare&, 1: _SNDPLAY snare& '8
  604.             IF buttonv(num + (col * 7)) = 2 THEN _SNDVOL snare&, .1: _SNDPLAY snare& '8
  605.         END IF
  606.         'play kick
  607.         IF instv(9) THEN
  608.             IF buttonv(num + (col * 8)) = 1 THEN _SNDVOL kick&, 1: _SNDPLAY kick& '9
  609.             IF buttonv(num + (col * 8)) = 2 THEN _SNDVOL kick&, .1: _SNDPLAY kick& '9
  610.         END IF
  611.         'play cowbell
  612.         IF instv(10) THEN
  613.             IF buttonv(num + (col * 9)) = 1 THEN _SNDVOL cowbell&, .3: _SNDPLAY cowbell& '10
  614.             IF buttonv(num + (col * 9)) = 2 THEN _SNDVOL cowbell&, .02: _SNDPLAY cowbell& '10
  615.         END IF
  616.         'play shaker
  617.         IF instv(11) THEN
  618.             IF buttonv(num + (col * 10)) = 1 THEN _SNDVOL shaker&, .6: _SNDPLAY shaker& '11
  619.             IF buttonv(num + (col * 10)) = 2 THEN _SNDVOL shaker&, .1: _SNDPLAY shaker& '11
  620.         END IF
  621.         'play tambourine
  622.         IF instv(12) THEN
  623.             IF buttonv(num + (col * 11)) = 1 THEN _SNDVOL tamb&, 1: _SNDPLAY tamb& '12
  624.             IF buttonv(num + (col * 11)) = 2 THEN _SNDVOL tamb&, .1: _SNDPLAY tamb& '12
  625.         END IF
  626.         'play vibraslap
  627.         IF instv(13) THEN
  628.             IF buttonv(num + (col * 12)) = 1 THEN _SNDVOL vibraslap&, .1: _SNDPLAY vibraslap& '13
  629.             IF buttonv(num + (col * 12)) = 2 THEN _SNDVOL vibraslap2&, .05: _SNDPLAY vibraslap2& '13
  630.         END IF
  631.         'play gong
  632.         IF instv(14) THEN
  633.             IF buttonv(num + (col * 13)) = 1 THEN _SNDVOL gong&, .1: _SNDPLAY gong& '14
  634.             IF buttonv(num + (col * 13)) = 2 THEN _SNDVOL gong2&, .03: _SNDPLAY gong2& '14
  635.         END IF
  636.         'play triangle
  637.         IF instv(15) THEN
  638.             IF buttonv(num + (col * 14)) = 1 THEN _SNDVOL trianglelong&, .3: _SNDPLAY trianglelong& '15
  639.             IF buttonv(num + (col * 14)) = 2 THEN _SNDVOL triangleshort&, .3: _SNDPLAY triangleshort& '15
  640.         END IF
  641.         'play clave
  642.         IF instv(16) THEN
  643.             IF buttonv(num + (col * 15)) = 1 THEN _SNDVOL clave&, .6: _SNDPLAY clave& '16
  644.             IF buttonv(num + (col * 15)) = 2 THEN _SNDVOL clave&, .02: _SNDPLAY clave& '16
  645.         END IF
  646.     END SUB
  647.      
  648.     SUB FPRINT (x, y, xsize, ysize, num$)
  649.         LINE (x, y)-(x + 100, y + ysize), _RGB(42, 42, 42), BF
  650.         FOR t = 1 TO LEN(num$)
  651.             n = VAL(MID$(num$, t, 1))
  652.             _PUTIMAGE (x, y)-(x + xsize, y + ysize), num&(n)
  653.             x = x + xsize: y = y + zsize
  654.         NEXT
  655.     END SUB
  656.      
  657.     SUB Metronome (way)
  658.         IF way = 1 THEN
  659.             f$ = "drummachine-data\metron.png"
  660.         ELSE
  661.             f$ = "drummachine-data\metroff.png"
  662.         END IF
  663.         ttmp = _LOADIMAGE(f$)
  664.         _PUTIMAGE (875, 72), ttmp: _FREEIMAGE ttmp
  665.     END SUB
  666.  
  667.  

 
                                                                                                                                         (117 downloads previously)
Drum Machine Screenshot.png

15
Audio / Simple Piano by Terry Ritchie
« on: September 22, 2021, 05:49:27 am »
QB64 Simple Piano

Author: @TerryRitchie
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2400.msg116185#msg116185
Version: 2

Description:
This is a little program I wrote back in 2014. It's a one-octave piano simulator that allows you to switch between octaves. The asset files (images and sounds) are contained in the zip file. Be sure to place the \PIANO folder in your QB64 folder and load the PIANO.bas file into the IDE.  Make sure that you have the RUN option “Output EXE to Source Folder” checked.

Directions for use are at the top of the source code listing.

Note: I wrote this using version 0.954 and because of that the sounds are loaded using options not available in the latest versions of QB64. If you compile this using an SDL version of QB64 the piano keys will stop the sound as soon as you release them. In non SDL versions of QB64 the key sustains even after released.

The thread for this project also contains variants by @Petr for saving the tunes created with this program.



Source Code:
Librarian's note: The code is given here for reference only.  Load the .bas file in the folder.
Code: QB64: [Select]
  1.     '*
  2.     '* QB64 Simple Piano
  3.     '*
  4.     '* by Terry Ritchie
  5.     '*
  6.     '* Demonstrates the use of external sound files to create a realistic piano.
  7.     '*
  8.     '* Modified 03/26/20
  9.     '* Removed the need for a separate .\PIANO\ folder to hold the graphics and
  10.     '* sound assets. All assets are now to be contained in the same folder as
  11.     '* PIANO.EXE
  12.     '*
  13.     '* ESC         - exit program
  14.     '* RIGHT ARROW - increase octave
  15.     '* LEFT ARROW  - decrease octave
  16.     '* Piano Keys  -  R T  U I O   (black keys)
  17.     '*             - D F GH J K L  (white keys)
  18.     '*
  19.      
  20.     '--------------------------------
  21.     '- Variable Declaration Section -
  22.     '--------------------------------
  23.      
  24.     TYPE IVORY '          key information
  25.         u AS INTEGER '    upper case value
  26.         l AS INTEGER '    lower case value
  27.         Down AS INTEGER ' key position
  28.         x AS INTEGER '    key indicator x coordinate
  29.         y AS INTEGER '    key indicator y coordinate
  30.     END TYPE
  31.      
  32.     DIM K(12) AS IVORY '  key information array
  33.     DIM Tone&(88) '       piano key sounds array
  34.     DIM imgPiano& '       piano keyboard image
  35.     DIM imgAoctave& '     active octave image
  36.     DIM imgIoctave& '     inactive octave image
  37.     DIM Octave% '         current octave
  38.     DIM Khit& '           keyboard status
  39.     DIM Keys% '           key cycle counter
  40.      
  41.     '----------------------------
  42.     '- Main Program Begins Here -
  43.     '----------------------------
  44.      
  45.     LOADPIANO '                                                          load piano assets
  46.     SCREEN _NEWIMAGE(512, 263, 32) '                                     create default screen
  47.     _TITLE "PIANO" '                                                     set window title
  48.     _SCREENMOVE _MIDDLE '                                                center window on desktop
  49.     _DELAY .25
  50.     _PUTIMAGE (0, 0), imgPiano& '                                        show piano image
  51.     SHOWOCTAVE '                                                         update octave indicator
  52.     DO '                                                                 MAIN LOOP begins
  53.         Khit& = _KEYHIT '                                                get keyboard status
  54.         IF Khit& THEN '                                                  was a key hit?
  55.             IF Khit& = 19200 OR Khit& = 19712 THEN '                     yes, left or right key?
  56.                 IF Khit& = 19200 THEN '                                  yes, left key?
  57.                     Octave% = Octave% - 1 '                              yes, decrease octave
  58.                     IF Octave% = -1 THEN Octave% = 0 '                   keep octave in limits
  59.                 ELSE '                                                   no, must be right key
  60.                     Octave% = Octave% + 1 '                              increase octave
  61.                     IF Octave% = 5 THEN Octave% = 4 '                    keep octave in limits
  62.                 END IF
  63.                 SHOWOCTAVE '                                             update octave indicator
  64.             ELSEIF Khit& = 27 THEN '                                     no, escape key?
  65.                 QUIT '                                                   yes, quit program
  66.             END IF
  67.         END IF
  68.         FOR Keys% = 1 TO 12 '                                            cycle through keys
  69.             IF _KEYDOWN(K(Keys%).u) OR _KEYDOWN(K(Keys%).l) THEN '       key pressed?
  70.                 PRESS Keys% '                                            yes, play note
  71.             ELSE '                                                       no
  72.                 RELEASE Keys% '                                          remove key indicator
  73.             END IF
  74.         NEXT Keys%
  75.         _DISPLAY '                                                       update screen changes
  76.     LOOP '                                                               MAIN LOOP back
  77.      
  78.     '-----------------------------------
  79.     '- Function and Subroutine section -
  80.     '-----------------------------------
  81.      
  82.     '--------------------------------------------------------------------------------------------
  83.      
  84.     SUB QUIT ()
  85.      
  86.         '*
  87.         '* Cleans RAM by removing all image and sound assets and then exits to Windows.
  88.         '*
  89.      
  90.         SHARED Tone&() '     need access to piano key sounds array
  91.         SHARED imgPiano& '   need access to piano keyboard image
  92.         SHARED imgAoctave& ' need access to active octave image
  93.         SHARED imgIoctave& ' need access to inactive octave image
  94.      
  95.         DIM Count% '         generic counter
  96.      
  97.         FOR Count% = 1 TO 88 '        cycle through all 88 sound files
  98.             _SNDCLOSE Tone&(Count%) ' remove sound file from RAM
  99.         NEXT Count%
  100.         _FREEIMAGE imgPiano& '        remove piano image from RAM
  101.         _FREEIMAGE imgAoctave& '      remove active octave image from RAM
  102.         _FREEIMAGE imgIoctave& '      remove inactive octave image from RAM
  103.         SYSTEM '                      return to Windows
  104.      
  105.     END SUB
  106.      
  107.     '--------------------------------------------------------------------------------------------
  108.      
  109.     SUB RELEASE (k%)
  110.      
  111.         '*
  112.         '* Removes key press display and sets key as being released
  113.         '*
  114.      
  115.         SHARED K() AS IVORY ' need access to key information array
  116.      
  117.         IF K(k%).Down THEN '                                                  is key pressed?
  118.             K(k%).Down = 0 '                                                  yes, set it as released
  119.             SELECT CASE k% '                                                  which key is it?
  120.                 CASE 1, 3, 5, 6, 8, 10, 12 '                                  white key
  121.                     LINE (K(k%).x, K(k%).y)-(K(k%).x + 27, K(k%).y + 27), _RGB32(255, 255, 255), BF
  122.                 CASE ELSE '                                                   black key
  123.                     LINE (K(k%).x, K(k%).y)-(K(k%).x + 27, K(k%).y + 27), _RGB32(32, 32, 32), BF
  124.             END SELECT
  125.         END IF
  126.      
  127.     END SUB
  128.      
  129.     '--------------------------------------------------------------------------------------------
  130.      
  131.     SUB PRESS (k%)
  132.      
  133.         '*
  134.         '* Applies key press display and sets key as being pressed
  135.         '*
  136.      
  137.         SHARED K() AS IVORY ' need access to key information array
  138.         SHARED Tone&() '      need access to piano key sounds array
  139.         SHARED Octave% '      need access to current octave
  140.      
  141.         IF NOT K(k%).Down THEN '                                               is key released?
  142.             K(k%).Down = -1 '                                                  yes, set it as pressed
  143.             _SNDPLAY Tone&(Octave% * 12 + k%) '                                play tone for key
  144.             SELECT CASE k% '                                                   which key is it?
  145.                 CASE 1, 3, 5, 6, 8, 10, 12 '                                   white key
  146.                     LINE (K(k%).x, K(k%).y)-(K(k%).x + 27, K(k%).y + 27), _RGB32(0, 0, 0), BF
  147.                 CASE ELSE '                                                    black key
  148.                     LINE (K(k%).x, K(k%).y)-(K(k%).x + 27, K(k%).y + 27), _RGB32(255, 255, 255), BF
  149.             END SELECT
  150.         END IF
  151.      
  152.     END SUB
  153.      
  154.     '--------------------------------------------------------------------------------------------
  155.      
  156.     SUB SHOWOCTAVE
  157.      
  158.         '*
  159.         '* Updates the small top piano keyboard to show current active octave
  160.         '*
  161.      
  162.         SHARED Octave% '     need access to current octave
  163.         SHARED imgAoctave& ' need access to active octave image
  164.         SHARED imgIoctave& ' need access to inactive octave image
  165.      
  166.         DIM Count% '         generic counter
  167.      
  168.         FOR Count% = 0 TO 4 '                                    cycle through octaves
  169.             IF Count% = Octave% THEN '                           current octave?
  170.                 _PUTIMAGE (96 + (Count% * 64), 0), imgAoctave& ' yes, place active octave image
  171.             ELSE '                                               no
  172.                 _PUTIMAGE (96 + (Count% * 64), 0), imgIoctave& ' place inactive octave image
  173.             END IF
  174.         NEXT Count%
  175.      
  176.     END SUB
  177.      
  178.     '--------------------------------------------------------------------------------------------
  179.      
  180.     SUB LOADPIANO ()
  181.      
  182.         '*
  183.         '* Loads the piano sounds and images and initializes variables
  184.         '*
  185.      
  186.         SHARED K() AS IVORY ' need access to key information array
  187.         SHARED Tone&() '      need access to piano key sounds array
  188.         SHARED imgPiano& '    need access to piano keyboard image
  189.         SHARED imgAoctave& '  need access to active octave image
  190.         SHARED imgIoctave& '  need access to inactive octave image
  191.         SHARED Octave% '      need access to current octave
  192.      
  193.         DIM Note% '           counter used to open sounds
  194.         DIM Count% '          counter used to close sounds if error
  195.         DIM File$ '           sound file names
  196.      
  197.         FOR Note% = 1 TO 88 '                                          cycle through notes
  198.             File$ = LTRIM$(STR$(Note%)) + ".ogg" '                     construct file name
  199.             IF _FILEEXISTS(File$) THEN '                               sound file exist?
  200.                 Tone&(Note%) = _SNDOPEN(File$, "VOL,SYNC,LEN,PAUSE") ' yes, load sound file
  201.             ELSE '                                                     no, sound file missing
  202.                 PRINT '                                                report error to user
  203.                 PRINT " ERROR: Sound file "; File$; " is missing."
  204.                 IF Note% > 1 THEN '                                    did any sounds load?
  205.                     FOR Count% = Note% TO 1 STEP -1 '                  yes, cycle notes backwards
  206.                         _SNDCLOSE Tone&(Count%) '                      remove sound from RAM
  207.                     NEXT Count%
  208.                     END '                                              end program
  209.                 END IF
  210.             END IF
  211.         NEXT Note%
  212.         IF _FILEEXISTS("piano.png") THEN '                             image file exist?
  213.             imgPiano& = _LOADIMAGE("piano.png", 32) '                  yes, load image file
  214.         ELSE '                                                         no, image file missing
  215.             PRINT '                                                    report error to user
  216.             PRINT " ERROR: piano.png missing."
  217.             END '                                                      end program
  218.         END IF
  219.         IF _FILEEXISTS("active.png") THEN '                            image file exist?
  220.             imgAoctave& = _LOADIMAGE("active.png", 32) '               yes, load image file
  221.         ELSE '                                                         no, image file missing
  222.             PRINT '                                                    report error to user
  223.             PRINT " ERROR: active.png missing."
  224.             _FREEIMAGE imgPiano& '                                     remove image from RAM
  225.             END '                                                      end program
  226.         END IF
  227.         IF _FILEEXISTS(Path$ + "inactive.png") THEN '                  image file exist?
  228.             imgIoctave& = _LOADIMAGE("inactive.png", 32) '             yes, load image file
  229.         ELSE '                                                         no, image file missing
  230.             PRINT '                                                    report error to user
  231.             PRINT " ERROR: inactive.png missing."
  232.             _FREEIMAGE imgPiano& '                                     remove image from RAM
  233.             _FREEIMAGE imgAoctave& '                                   remove image from RAM
  234.             END '                                                      end program
  235.         END IF
  236.      
  237.         K(1).x = 22: K(1).y = 212: K(2).x = 60: K(2).y = 132 '         set indicator coordinates
  238.         K(3).x = 95: K(3).y = 212: K(4).x = 134: K(4).y = 132
  239.         K(5).x = 168: K(5).y = 212: K(6).x = 241: K(6).y = 212
  240.         K(7).x = 278: K(7).y = 132: K(8).x = 314: K(8).y = 212
  241.         K(9).x = 353: K(9).y = 132: K(10).x = 387: K(10).y = 212
  242.         K(11).x = 428: K(11).y = 132: K(12).x = 460: K(12).y = 212
  243.         K(1).l = 100: K(1).u = 68: K(2).l = 114: K(2).u = 82 '         set key case values
  244.         K(3).l = 102: K(3).u = 70: K(4).l = 116: K(4).u = 84
  245.         K(5).l = 103: K(5).u = 71: K(6).l = 104: K(6).u = 72
  246.         K(7).l = 117: K(7).u = 85: K(8).l = 106: K(8).u = 74
  247.         K(9).l = 105: K(9).u = 73: K(10).l = 107: K(10).u = 75
  248.         K(11).l = 111: K(11).u = 79: K(12).l = 108: K(12).u = 76
  249.         Octave% = 2 '                                                  set initial octave
  250.      
  251.     END SUB
  252.      
  253.     '--------------------------------------------------------------------------------------------
  254.  

 
                                                                                                                                         (136 downloads previously)

PIANO Screenshot.png

Pages: [1] 2