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.

Topics - Qwerkey

Pages: 1 2 [3] 4 5 ... 8

QB64 Discussion / Call for Samples and Games

« on: March 17, 2020, 06:22:18 am »

If you would like one of your Projects to be added to Our Samples or Games, please submit a request to the Library Staff. Please see Instructions: https://www.qb64.org/forum/index.php?topic=178.0

We would particularly be interested in receiving submissions from our most prolific members.

@TempodiBasic @Cobalt @SierraKen @Petr @Dav @jack @[banned user] @SirCrow If you have a project (which is not a game) which you consider worthy of our Samples and which you would like us to consider, then please contact the Library Staff.

@SMcNeill @Pete @Cobalt @SierraKen @Petr @Dav @RhoSigma @Richard Frost @jack @[banned user] @SirCrow If you have a project which is a game and which you consider worthy of our Games and which you would like us to consider, then please contact the Library Staff.

You are under no obligation whatsoever.

Your Library Staff: @STxAxTIC @bplus @Qwerkey

SUB _GL / 3D Knots by Ashish

« on: March 14, 2020, 11:59:21 am »

3D Knots

Author: @Ashish
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=169.msg902#msg902
Version: 1
Tags: [3D], [Graphics], [Open_GL]

Description:
Some mathematical knots or geometry, effected by SUB _GL

Source Code:

Code: QB64: [Select]

'Coded in QB64 by Ashish on 9 March, 2018
'http://paulbourke.net/geometry/knots/
_TITLE "3D Knot [Press space for next knot]"
 
SCREEN _NEWIMAGE(700, 700, 32)
 
TYPE vec3
    x AS SINGLE
    y AS SINGLE
    z AS SINGLE
END TYPE
DECLARE LIBRARY 'used for camera.
    SUB gluLookAt (BYVAL eyeX#, BYVAL eyeY#, BYVAL eyeZ#, BYVAL centerX#, BYVAL centerY#, BYVAL centerZ#, BYVAL upX#, BYVAL upY#, BYVAL upZ#)
END DECLARE
 
DIM SHARED glAllow AS _BYTE, knot_type, ma 'knot_type store the type knot being drawn. ma store percentage of knot which is being drawn.
knot_type = 1
glAllow = -1
 
DO
    k& = _KEYHIT
    IF k& = ASC(" ") THEN
        knot_type = knot_type + 1
        ma = 0
        IF knot_type > 7 THEN knot_type = 1 '7 knots are there.
    END IF
    _LIMIT 60
LOOP
 
SUB _GL ()
    STATIC glInit, clock
    ' static r, pos, theta, phi, beta
 
    IF NOT glAllow THEN EXIT SUB
 
    IF NOT glInit THEN
        glInit = -1
        aspect# = _WIDTH / _HEIGHT
        _glViewport 0, 0, _WIDTH, _HEIGHT
    END IF
 
    _glEnable _GL_DEPTH_TEST 'We are doing 3D. This enables Z-Buffer.
 
    'set perspective configuration
    _glMatrixMode _GL_PROJECTION
    _glLoadIdentity
    _gluPerspective 45.0, aspect#, 1.0, 100.0
 
    _glMatrixMode _GL_MODELVIEW
    _glLoadIdentity
    ' gluLookAt 0,0,-1,0,0,0,0,1,0
 
    _glColor3f 1, 1, 1 'set color
    _glTranslatef 0, 0, 0 'not require. becoz, origin is already at 0,0,0
    _glRotatef clock * 90, 0, 1, 0 'rotation along Y-axis
    _glLineWidth 3.0 'width of the line.
 
    SELECT CASE knot_type
        CASE 7 'equations are knots are taken from paulbourke site
            _glBegin _GL_LINE_STRIP
            'for animation, value of ma is gradually increased till a certain constant. In this case, it is pi.
            FOR beta = 0 TO ma STEP .005
                r = .3 + .6 * SIN(6 * beta)
                theta = 2 * beta
                phi = _PI(.6) * SIN(12 * beta)
                x = r * COS(phi) * COS(theta)
                y = r * COS(phi) * SIN(theta)
                z = r * SIN(phi)
                _glColor3f map(x, -1, 1, 0, 1), map(y, -1, 1, 0, 1), map(z, -1, 1, 0, 1)
                _glVertex3f x, y, z 'draws it.
            NEXT
            _glEnd
            IF ma <= _PI THEN ma = ma + .005
            'others are made to be rendered in the same way.
        CASE 6
            _glBegin _GL_LINE_STRIP
            FOR beta = 0 TO ma STEP .005
                r = 1.2 * 0.6 * SIN(_PI(.5) * 6 * beta)
                theta = 4 * beta
                phi = _PI(.2) * SIN(6 * beta)
                x = r * COS(phi) * COS(theta)
                y = r * COS(phi) * SIN(theta)
                z = r * SIN(phi)
                _glColor3f map(x, -1, 1, 0, 1), map(y, -1, 1, 0, 1), map(z, -1, 1, 0, 1)
                _glVertex3f x, y, z
            NEXT
            _glEnd
            IF ma <= _PI(2) THEN ma = ma + .005
        CASE 5
            k = 1
            _glBegin _GL_LINE_STRIP
            FOR u = 0 TO ma STEP .005
                x = COS(u) * (2 - COS(2 * u / (2 * k + 1))) / 5
                y = SIN(u) * (2 - COS(2 * u / (2 * k + 1))) / 5
                z = -SIN(2 * u / (2 * k + 1)) / 5
                _glColor3f map(x, -1, 1, 0, 1), map(y, -1, 1, 0, 1), map(z, -1, 1, 0, 1)
                _glVertex3f x, y, z
            NEXT
            _glEnd
            IF ma < _PI(4 * k + 2) THEN ma = ma + .045
        CASE 4
            k = 2
            _glBegin _GL_LINE_STRIP
            FOR u = 0 TO ma STEP .005
                x = COS(u) * (2 - COS(2 * u / (2 * k + 1))) / 5
                y = SIN(u) * (2 - COS(2 * u / (2 * k + 1))) / 5
                z = -SIN(2 * u / (2 * k + 1)) / 5
                _glColor3f map(x, -1, 1, 0, 1), map(y, -1, 1, 0, 1), map(z, -1, 1, 0, 1)
                _glVertex3f x, y, z
            NEXT
            _glEnd
            IF ma < _PI(4 * k + 2) THEN ma = ma + .045
        CASE 3
            k = 3
            _glBegin _GL_LINE_STRIP
            FOR u = 0 TO ma STEP .005
                x = COS(u) * (2 - COS(2 * u / (2 * k + 1))) / 5
                y = SIN(u) * (2 - COS(2 * u / (2 * k + 1))) / 5
                z = -SIN(2 * u / (2 * k + 1)) / 5
                _glColor3f map(x, -1, 1, 0, 1), map(y, -1, 1, 0, 1), map(z, -1, 1, 0, 1)
                _glVertex3f x, y, z
            NEXT
            _glEnd
            IF ma < _PI(4 * k + 2) THEN ma = ma + .045
        CASE 2
            _glBegin _GL_LINE_STRIP
            FOR u = 0 TO ma STEP .005
                x = (41 * COS(u) - 18 * SIN(u) - 83 * COS(2 * u) - 83 * SIN(2 * u) - 11 * COS(3 * u) + 27 * SIN(3 * u)) / 200
                y = (36 * COS(u) + 27 * SIN(u) - 113 * COS(2 * u) + 30 * SIN(2 * u) + 11 * COS(3 * u) - 27 * SIN(3 * u)) / 200
                z = (45 * SIN(u) - 30 * COS(2 * u) + 113 * SIN(2 * u) - 11 * COS(3 * u) + 27 * SIN(3 * u)) / 200
                _glColor3f map(x, -1, 1, 0, 1), map(y, -1, 1, 0, 1), map(z, -1, 1, 0, 1)
                _glVertex3f x, y, z
            NEXT
            _glEnd
            IF ma < _PI(2) THEN ma = ma + .005
        CASE 1
            _glBegin _GL_LINE_STRIP
            FOR u = 0 TO ma STEP .005
                x = (-22 * COS(u) - 128 * SIN(u) - 44 * COS(3 * u) - 78 * SIN(3 * u)) / 200
                y = (-10 * COS(2 * u) - 27 * SIN(2 * u) + 38 * COS(4 * u) + 46 * SIN(4 * u)) / 200
                z = (70 * COS(3 * u) - 40 * SIN(3 * u)) / 200
                _glColor3f map(x, -1, 1, 0, 1), map(y, -1, 1, 0, 1), map(z, -1, 1, 0, 1)
                _glVertex3f x, y, z
            NEXT
            _glEnd
            IF ma < _PI(2) THEN ma = ma + .005
    END SELECT
    _glFlush
 
    clock = clock + .01
END SUB
 
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 

SUB _GL / 3D : Sierpinski Cube by Ashish

« on: March 14, 2020, 08:56:11 am »

3D : Sierpinski Cube

Author: @Ashish
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2251.msg114913#msg114913
Version: 1
Tags: [3D], [Graphics], [Open_GL]

Description:
This fractal is popularly known as Menger Sponge. It looks beautiful.

Controls:
Move mouse for rotation.

Source Code:

Code: QB64: [Select]

'@Author:Ashish Kushwaha
'28 Feb, 2020s
_TITLE "Menger Sponge"
SCREEN _NEWIMAGE(600, 600, 32)
 
TYPE vec3
    x AS SINGLE
    y AS SINGLE
    z AS SINGLE
END TYPE
 
DECLARE LIBRARY
    SUB glutSolidCube (BYVAL dsize AS DOUBLE) 'use to draw a solid cube by taking the side length as its arguement
END DECLARE
 
'Algorithm
'1. We take a cube.
'2. We divide it into 27 equal cubical parts.
'3. Out of this 27 cubes, 7 cubes are removed.
'4. In the remaining 20 cubes, Step-1 is repeated for each cube.
iteration = 3 'no. of iteration. At each iteration, 7 cubes are removed from parent cube.
size = 0.5 'the size of our first cube
n = (20 ^ iteration) - 1
 
DIM SHARED glAllow, cubeLoc(n) AS vec3, fundamentalCubeSize 'cubeLoc array store the location of cubes to be rendered. They are the smallest cube which are formed in the last iteration
fundamentalCubeSize = size / (3 ^ iteration) 'the size the smallest cube which is formed in the last iteration
initFractal 0, 0, 0, size, iteration 'this sub done all calculation for cube location & other stuff.
 
PRINT (n + 1); " Cubes will rendered with total of "; 8 * (n + 1); " vertices"
PRINT "Hit a Key"
SLEEP
glAllow = 1 'to start rendering in the SUB _GL
DO
    WHILE _MOUSEINPUT: WEND
    _LIMIT 40
LOOP
 
SUB _GL () STATIC
    DIM clr(3)
    IF glAllow = 0 THEN EXIT SUB 'So that rendering will start as soon as initialization is done.
    IF glInit = 0 THEN
        _glViewport 0, 0, _WIDTH, _HEIGHT 'this defines the area in the screen where GL rendering will occur
        aspect# = _WIDTH / _HEIGHT
 
        glInit = 1
    END IF
 
    _glEnable _GL_DEPTH_TEST 'this enable Z-buffer. So that we can do 3D things.
    _glClear _GL_DEPTH_BUFFER_BIT OR _GL_COLOR_BUFFER_BIT 'Not required unless we do softwre rendering as well.
 
    'LIGHTS CONFIG
    _glEnable _GL_LIGHTING 'this enable us to use light. There are max of 8 lights in GL
    _glEnable _GL_LIGHT0
    clr(0) = 0.2: clr(1) = 0.2: clr(2) = 0.2: clr(3) = 1
    _glLightfv _GL_LIGHT0, _GL_AMBIENT, _OFFSET(clr()) 'this define the color of the material where light can hardly reach.
    clr(0) = 0.8: clr(1) = 0.8: clr(2) = 0.8: clr(3) = 1
    _glLightfv _GL_LIGHT0, _GL_SPECULAR, _OFFSET(clr()) 'this define the color of the material where light is directly reflected & reach your eye.
    _glLightfv _GL_LIGHT0, _GL_DIFFUSE, _OFFSET(clr()) 'this define the default/usual color of the light on the material.
    clr(0) = 0: clr(1) = 0: clr(2) = 0: clr(3) = 1
    _glLightfv _GL_LIGHT0, _GL_POSITION, _OFFSET(clr()) 'use to define the direction of light when 4th component is 0. When 4th component is 1, it defines the position of light. In this case, the light looses its intensity as distance increases.
 
    _glMatrixMode _GL_PROJECTION 'usually used for setting up perspective etc.
    _gluPerspective 60, aspect#, 0.1, 10 'first arguement tell angle for FOV (Field of View, for human it is round 70degree for one eye.LOL) next one aspect ratio, next 2 are near & far distance. Objects which are not between these distance are clipped. (or are not rendered.)
 
    _glMatrixMode _GL_MODELVIEW 'rendering takes place here
    _glLoadIdentity
 
    _glTranslatef 0, 0, -1 'move the origin forward by 1 unit
    _glRotatef _MOUSEX, 0, 1, 0 'these are for rotation by the movement of mouse.
    _glRotatef _MOUSEY, 1, 0, 0
 
    drawFractal 'draws the fractal
    _glFlush 'force all the GL command to complete in finite amount of time
END SUB
 
SUB initFractal (x, y, z, s, N) 'x-position, y-position, z-position, size, N-> iteration
    STATIC i
    'As we divide the cube, value of N decreases.
    IF N = 0 THEN 'when the division is done N times (no. of iteration)
        cubeLoc(i).x = x 'store the coordinates of cube
        cubeLoc(i).y = y
        cubeLoc(i).z = z
        i = i + 1
        ' ? "Added #",i
        ' sleep
        EXIT SUB
    END IF
    'top section
    'front row, left to right
    initFractal (x - s / 3), (y + s / 3), (z + s / 3), s / 3, N - 1
    initFractal (x), (y + s / 3), (z + s / 3), s / 3, N - 1
    initFractal (x + s / 3), (y + s / 3), (z + s / 3), s / 3, N - 1
    'behind the previous row, left to right
    initFractal (x - s / 3), (y + s / 3), (z), s / 3, N - 1
    initFractal (x + s / 3), (y + s / 3), (z), s / 3, N - 1
    'behind the previous row, left to right
    initFractal (x - s / 3), (y + s / 3), (z - s / 3), s / 3, N - 1
    initFractal (x), (y + s / 3), (z - s / 3), s / 3, N - 1
    initFractal (x + s / 3), (y + s / 3), (z - s / 3), s / 3, N - 1
    'middle section
    'front row, left to right
    initFractal (x - s / 3), (y), (z + s / 3), s / 3, N - 1
    initFractal (x + s / 3), (y), (z + s / 3), s / 3, N - 1
    'behind the previous row (last one as middle one contain no cube ;) ), left to right
    initFractal (x - s / 3), (y), (z - s / 3), s / 3, N - 1
    initFractal (x + s / 3), (y), (z - s / 3), s / 3, N - 1
    'bottom section
    'front row, left to right
    initFractal (x - s / 3), (y - s / 3), (z + s / 3), s / 3, N - 1
    initFractal (x), (y - s / 3), (z + s / 3), s / 3, N - 1
    initFractal (x + s / 3), (y - s / 3), (z + s / 3), s / 3, N - 1
    'behind the previous row, left to right
    initFractal (x - s / 3), (y - s / 3), (z), s / 3, N - 1
    initFractal (x + s / 3), (y - s / 3), (z), s / 3, N - 1
    'behind the previous row, left to right
    initFractal (x - s / 3), (y - s / 3), (z - s / 3), s / 3, N - 1
    initFractal (x), (y - s / 3), (z - s / 3), s / 3, N - 1
    initFractal (x + s / 3), (y - s / 3), (z - s / 3), s / 3, N - 1 '20
 
END SUB
 
SUB drawFractal ()
    FOR i = 0 TO UBOUND(cubeLoc)
        _glPushMatrix 'save the previous transformation configuration
        _glTranslatef cubeLoc(i).x, cubeLoc(i).y, cubeLoc(i).z 'move at given location
        glutSolidCube fundamentalCubeSize 'draws the solid cube of smallest size which is formed in the last iteration
        _glPopMatrix 'restore the original transformation configuration
    NEXT
END SUB
 

SUB _GL / 3D Double Pendulum by Ashish

« on: March 12, 2020, 12:53:56 pm »

3D Double Pendulum

Author: @ Ashish
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=153.msg828#msg828
Version: 1
Tags: [3D], [Graphics], [Open_GL]

Description:
A double pendulum swinging in 3D.

Source Code:

Code: QB64: [Select]

'Coded By Ashish on 4 March, 2018
 
_TITLE "3D Double Pendulum [Press Space for new settings]"
SCREEN _NEWIMAGE(800, 600, 32)
 
TYPE vec3
    x AS DOUBLE
    y AS DOUBLE
    z AS DOUBLE
END TYPE
 
TYPE pendlm
    POS AS vec3
    r AS DOUBLE
    ang AS DOUBLE
    angInc AS DOUBLE
    angSize AS DOUBLE
END TYPE
 
DECLARE LIBRARY
    SUB gluLookAt (BYVAL eyeX#, BYVAL eyeY#, BYVAL eyeZ#, BYVAL centerX#, BYVAL centerY#, BYVAL centerZ#, BYVAL upX#, BYVAL upY#, BYVAL upZ#)
    SUB glutSolidSphere (BYVAL radius AS DOUBLE, BYVAL slices AS LONG, BYVAL stack AS LONG)
END DECLARE
 
DIM SHARED glAllow AS _BYTE
DIM SHARED pendulum(1) AS pendlm, t1 AS vec3, t2 AS vec3
DIM SHARED tracer(3000) AS vec3, tracerSize AS _UNSIGNED LONG
RANDOMIZE TIMER
 
settings:
tracerSize = 0
g = 0
 
pendulum(0).POS.x = 0
pendulum(0).POS.y = 0
pendulum(0).POS.z = 0
pendulum(0).r = p5random(.7, 1.1)
pendulum(0).angInc = p5random(0, _PI(2))
pendulum(0).angSize = p5random(_PI(.3), _PI(.6))
 
pendulum(1).r = p5random(.25, .5)
pendulum(1).angInc = p5random(0, _PI(2))
pendulum(1).angSize = p5random(_PI(.3), _PI(1.1))
 
glAllow = -1
_GLRENDER _BEHIND
DO
    k& = _KEYHIT
    IF k& = ASC(" ") THEN GOTO settings
    pendulum(0).ang = SIN(pendulum(0).angInc) * pendulum(0).angSize + _PI(.5)
 
    t1.x = COS(pendulum(0).ang) * pendulum(0).r + pendulum(0).POS.x
    t1.y = SIN(pendulum(0).ang) * pendulum(0).r + pendulum(0).POS.y
    t1.z = COS(pendulum(0).ang) * pendulum(0).r + pendulum(0).POS.z
 
    pendulum(1).POS = t1
 
    pendulum(1).ang = SIN(pendulum(1).angInc) * pendulum(1).angSize + pendulum(0).ang
 
    t2.x = COS(pendulum(1).ang) * pendulum(1).r + pendulum(1).POS.x
    t2.y = SIN(pendulum(1).ang) * pendulum(1).r + pendulum(1).POS.y
    t2.z = SIN(pendulum(1).ang) * pendulum(1).r + pendulum(1).POS.z
 
    pendulum(0).angInc = pendulum(0).angInc + .02
    pendulum(1).angInc = pendulum(1).angInc + .043
 
    IF tracerSize < UBOUND(tracer) - 1 AND g > 40 THEN tracer(tracerSize) = t2
    IF g > 40 AND tracerSize < UBOUND(tracer) - 1 THEN tracerSize = tracerSize + 1
 
    g = g + 1
    _LIMIT 60
LOOP
 
SUB _GL () STATIC
    IF NOT glAllow THEN EXIT SUB
 
    IF NOT glInit THEN
        glInit = -1
        aspect# = _WIDTH / _HEIGHT
        _glViewport 0, 0, _WIDTH, _HEIGHT
    END IF
 
    _glEnable _GL_BLEND
    _glEnable _GL_DEPTH_TEST
 
 
    _glShadeModel _GL_SMOOTH
 
    _glMatrixMode _GL_PROJECTION
    _glLoadIdentity
    _gluPerspective 45.0, aspect#, 1.0, 1000.0
 
    _glMatrixMode _GL_MODELVIEW
    _glLoadIdentity
 
    gluLookAt 0, 0, -4, 0, 1, 0, 0, -1, 0
 
    _glRotatef clock# * 90, 0, 1, 0
    _glLineWidth 3.0
 
    _glPushMatrix
 
    _glColor4f 1, 1, 1, .7
 
    _glBegin _GL_LINES
    _glVertex3f pendulum(0).POS.x, pendulum(0).POS.y, pendulum(0).POS.z
    _glVertex3f t1.x, t1.y, t1.z
    _glEnd
    _glPopMatrix
 
    _glPushMatrix
 
    _glBegin _GL_LINES
    _glVertex3f t1.x, t1.y, t1.z
    _glVertex3f t2.x, t2.y, t2.z
    _glEnd
 
    IF tracerSize > 3 THEN
        _glBegin _GL_LINES
        FOR i = 0 TO tracerSize - 2
            _glColor3f 0, map(tracer(i).x, -1, 1, .5, 1), map(tracer(i).y, -1, 1, .5, 1)
            _glVertex3f tracer(i).x, tracer(i).y, tracer(i).z
            _glColor3f 0, map(tracer(i + 1).x, -1, 1, .5, 1), map(tracer(i + 1).y, -1, 1, .5, 1)
            _glVertex3f tracer(i + 1).x, tracer(i + 1).y, tracer(i + 1).z
        NEXT
        _glEnd
    END IF
    _glPopMatrix
 
    _glEnable _GL_LIGHTING
    _glEnable _GL_LIGHT0
    _glPushMatrix
    _glTranslatef t1.x, t1.y, t1.z
 
    _glColor3f .8, .8, .8
    glutSolidSphere .1, 15, 15
    _glPopMatrix
 
    _glPushMatrix
    _glTranslatef t2.x, t2.y, t2.z
 
    _glColor3f .8, .8, .8
    glutSolidSphere .1, 15, 15
    _glPopMatrix
 
    clock# = clock# + .01
 
    _glFlush
END SUB
 
 
 
'taken from p5js.bas
'https://bit.y/p5jsbas
FUNCTION p5random! (mn!, mx!)
    IF mn! > mx! THEN
        SWAP mn!, mx!
    END IF
    p5random! = RND * (mx! - mn!) + mn!
END FUNCTION
 
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 

SUB _GL / OpenGL Lights & Material by Ashish

« on: March 12, 2020, 05:37:47 am »

OpenGL Lights & Material

Author: @ Ashish
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2323.0
A full repository of QB64_OpenGL_Demos by Ashish Kingdom and Petr Preclik, which contains all the supplementary files/resources as well as screenshots and many other GL programs:
https://github.com/AshishKingdom/QB64_OpenGL_Demos/archive/master.zip
Version: 1
Tags: [3D], [Graphics], [Open_GL]

Description:
Stunning 3D effect of moving lights with reflections off the surface of a sphere

Source Code:

Code: QB64: [Select]

'OpenGL Lights & Material By Ashish
 
_TITLE "OpenGL Lights & Material"
 
SCREEN _NEWIMAGE(800, 600, 32)
 
DIM SHARED glAllow AS _BYTE
DECLARE LIBRARY
    SUB gluLookAt (BYVAL eyeX#, BYVAL eyeY#, BYVAL eyeZ#, BYVAL centerX#, BYVAL centerY#, BYVAL centerZ#, BYVAL upX#, BYVAL upY#, BYVAL upZ#)
    SUB glutSolidSphere (BYVAL radius AS DOUBLE, BYVAL slices AS LONG, BYVAL stack AS LONG)
END DECLARE
 
'Used by GLH RGB/etc helper functions
DIM SHARED DONT_USE_GLH_COL_RGBA(1 TO 4) AS SINGLE
 
'Used to manage textures
TYPE DONT_USE_GLH_Handle_TYPE
    in_use AS _BYTE
    handle AS LONG
END TYPE
 
TYPE vec3
    x AS SINGLE
    y AS SINGLE
    z AS SINGLE
END TYPE
 
 
'Used by GLH RGB/etc helper functions
REDIM SHARED DONT_USE_GLH_Handle(1000) AS DONT_USE_GLH_Handle_TYPE
 
DIM SHARED redLight AS vec3
DIM SHARED greenLight AS vec3
DIM SHARED blueLight AS vec3
 
 
 
glAllow = -1
DO
    _LIMIT 40
LOOP UNTIL k& = ASC(CHR$(27))
 
 
SUB _GL () STATIC
    IF NOT glAllow THEN EXIT SUB
 
    _glEnable _GL_DEPTH_TEST
    _glEnable _GL_LIGHTING
    
    _glEnable _GL_LIGHT0 'we need three lights, each for red, green & blue.
    _glEnable _GL_LIGHT1
    _glEnable _GL_LIGHT2
    
    _glLightfv _GL_LIGHT0, _GL_AMBIENT, GLH_RGB(0, 0, 0)
    _glLightfv _GL_LIGHT0, _GL_DIFFUSE, GLH_RGB(.5, 0, 0)
    _glLightfv _GL_LIGHT0, _GL_SPECULAR, GLH_RGB(1, 0, 0)
    _glLightfv _GL_LIGHT0, _GL_POSITION, GLH_RGBA(redLight.x, redLight.y, redLight.z, 0)
    
    _glLightfv _GL_LIGHT1, _GL_AMBIENT, GLH_RGB(0, 0, 0)
    _glLightfv _GL_LIGHT1, _GL_DIFFUSE, GLH_RGB(0, .5, 0)
    _glLightfv _GL_LIGHT1, _GL_SPECULAR, GLH_RGB(0, 1, 0)
    _glLightfv _GL_LIGHT1, _GL_POSITION, GLH_RGBA(greenLight.x, greenLight.y, greenLight.z, 0)
 
    _glLightfv _GL_LIGHT2, _GL_AMBIENT, GLH_RGB(0, 0, 0)
    _glLightfv _GL_LIGHT2, _GL_DIFFUSE, GLH_RGB(0, 0, .5)
    _glLightfv _GL_LIGHT2, _GL_SPECULAR, GLH_RGB(0, 0, 1)
    _glLightfv _GL_LIGHT2, _GL_POSITION, GLH_RGBA(blueLight.x, blueLight.y, blueLight.z, 0)
   
    _glMatrixMode _GL_PROJECTION
    _glLoadIdentity
   
    IF NOT glSetup THEN
        aspect# = _WIDTH / _HEIGHT
        glSetup = -1
        _glViewport 0, 0, _WIDTH, _HEIGHT
    END IF
   
    _gluPerspective 45.0, aspect#, 1.0, 100.0
   
    _glMatrixMode _GL_MODELVIEW
    _glLoadIdentity
   
    gluLookAt 0, 0, 5, 0, 0, 0, 0, 1, 0
    
    _glColor3f 0, 0, 0
    
    _glMaterialfv _GL_FRONT_AND_BACK, _GL_AMBIENT, GLH_RGB(0, 0, 0)
    _glMaterialfv _GL_FRONT_AND_BACK, _GL_DIFFUSE, GLH_RGB(0.8, 0.8, 0.8)
    _glMaterialfv _GL_FRONT_AND_BACK, _GL_SPECULAR, GLH_RGB(.86, .86, .86)
    _glMaterialfv _GL_FRONT_AND_BACK, _GL_SHININESS, GLH_RGB(128 * .566, 0, 0)
    
    glutSolidSphere 1, 100, 100
    
    _glDisable _GL_LIGHTING
    
    _glPushMatrix
    _glTranslatef redLight.x, redLight.y, redLight.z
    _glColor3f 1, 0, 0
    glutSolidSphere .05, 20, 20
    _glPopMatrix
    
    _glPushMatrix
    _glTranslatef greenLight.x, greenLight.y, greenLight.z
    _glColor3f 0, 1, 0
    glutSolidSphere .05, 20, 20
    _glPopMatrix
    
    _glPushMatrix
    _glTranslatef blueLight.x, blueLight.y, .1
    _glColor3f 0, 0, 1
    glutSolidSphere .05, 20, 20
    _glPopMatrix
    
    _glFlush
   
    clock# = clock# + .01
    
    redLight.x = SIN(clock# * 1.5) * 1.5
    redLight.z = COS(clock# * 1.5) * 1.5
    
    greenLight.y = COS(clock# * .8) * 1.5
    greenLight.z = SIN(clock# * .8) * 1.5
    
    blueLight.x = SIN(clock#) * 1.5
    blueLight.y = COS(clock#) * 1.5
END SUB
 
 
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 
 
'below, all functions are coded by Galleon
FUNCTION GLH_Image_to_Texture (image_handle AS LONG) 'turn an image handle into a texture handle
    IF image_handle >= 0 THEN ERROR 258: EXIT FUNCTION 'don't allow screen pages
    DIM m AS _MEM
    m = _MEMIMAGE(image_handle)
    DIM h AS LONG
    h = DONT_USE_GLH_New_Texture_Handle
    GLH_Image_to_Texture = h
    _glBindTexture _GL_TEXTURE_2D, DONT_USE_GLH_Handle(h).handle
    _glTexImage2D _GL_TEXTURE_2D, 0, _GL_RGBA, _WIDTH(image_handle), _HEIGHT(image_handle), 0, &H80E1&&, _GL_UNSIGNED_BYTE, m.OFFSET
    _MEMFREE m
END FUNCTION
 
FUNCTION DONT_USE_GLH_New_Texture_Handle
    handle&& = 0
    _glGenTextures 1, _OFFSET(handle&&)
    DONT_USE_GLH_New_Texture_Handle = handle&&
    FOR h = 1 TO UBOUND(DONT_USE_GLH_Handle)
        IF DONT_USE_GLH_Handle(h).in_use = 0 THEN
            DONT_USE_GLH_Handle(h).in_use = 1
            DONT_USE_GLH_Handle(h).handle = handle&&
            DONT_USE_GLH_New_Texture_Handle = h
            EXIT FUNCTION
        END IF
    NEXT
    REDIM _PRESERVE DONT_USE_GLH_Handle(UBOUND(DONT_USE_GLH_HANDLE) * 2) AS DONT_USE_GLH_Handle_TYPE
    DONT_USE_GLH_Handle(h).in_use = 1
    DONT_USE_GLH_Handle(h).handle = handle&&
    DONT_USE_GLH_New_Texture_Handle = h
END FUNCTION
 
SUB GLH_Select_Texture (texture_handle AS LONG) 'turn an image handle into a texture handle
    IF texture_handle < 1 OR texture_handle > UBOUND(DONT_USE_GLH_HANDLE) THEN ERROR 258: EXIT FUNCTION
    IF DONT_USE_GLH_Handle(texture_handle).in_use = 0 THEN ERROR 258: EXIT FUNCTION
    _glBindTexture _GL_TEXTURE_2D, DONT_USE_GLH_Handle(texture_handle).handle
END SUB
 
 
FUNCTION GLH_RGB%& (r AS SINGLE, g AS SINGLE, b AS SINGLE)
    DONT_USE_GLH_COL_RGBA(1) = r
    DONT_USE_GLH_COL_RGBA(2) = g
    DONT_USE_GLH_COL_RGBA(3) = b
    DONT_USE_GLH_COL_RGBA(4) = 1
    GLH_RGB = _OFFSET(DONT_USE_GLH_COL_RGBA())
END FUNCTION
 
FUNCTION GLH_RGBA%& (r AS SINGLE, g AS SINGLE, b AS SINGLE, a AS SINGLE)
    DONT_USE_GLH_COL_RGBA(1) = r
    DONT_USE_GLH_COL_RGBA(2) = g
    DONT_USE_GLH_COL_RGBA(3) = b
    DONT_USE_GLH_COL_RGBA(4) = a
    GLH_RGBA = _OFFSET(DONT_USE_GLH_COL_RGBA())
END FUNCTION

OpenGL Lights & Materials Screenshot.PNG

2D/3D Graphics / Lissajous Curve Table by FellippeHeitor

« on: March 10, 2020, 11:00:24 am »

Lissajous Curve Table

Author: @FellippeHeitor
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=683.0
Version: « Reply #8 on: October 09, 2018, 02:48:07 PM »
Tags: [2D], [Graphics], [Mathematics]

Description:
Graphical Lissajou's Figures. For added eye-candy-ness, I've changed the plot line to paint using HSB colors so that ink color will vary according to the current rotational angle.

Source Code:

Code: QB64: [Select]

_TITLE "Lissajous Curve Table"
 
$RESIZE:ON
 
TYPE vector
    x AS SINGLE
    y AS SINGLE
END TYPE
 
DIM SHARED angle
DIM SHARED w
DIM SHARED rows, cols
 
SCREEN _NEWIMAGE(800, 800, 32)
 
setup:
angle = 0
w = 80
rows = INT(_HEIGHT / w) - 1
cols = INT(_WIDTH / w) - 1
REDIM dot(rows, cols) AS vector
 
plot = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
_DEST plot
CLS
_DEST 0
 
DO
    IF _RESIZE THEN
        oldScreen = _DEST
        SCREEN _NEWIMAGE(_RESIZEWIDTH, _RESIZEHEIGHT, 32)
        _FREEIMAGE oldScreen
        _FREEIMAGE plot
        GOTO setup
    END IF
 
    _PUTIMAGE , plot
 
    d = w - 0.2 * w
    r = d / 2
 
    FOR i = 0 TO cols
        cx = w + i * w + w / 2
        cy = w / 2
        CIRCLE (cx, cy), r
 
        x = r * COS(angle * (i + 1) - _PI(.5))
        y = r * SIN(angle * (i + 1) - _PI(.5))
 
        LINE (cx + x, 0)-(cx + x, _HEIGHT), _RGB32(127, 127, 127)
        CircleFill cx + x, cy + y, 4, _RGB32(28, 222, 50)
        CircleFill cx + x, cy + y, 2, _RGB32(11, 33, 249)
 
        FOR j = 0 TO rows
            dot(j, i).x = cx + x
        NEXT
    NEXT
 
    FOR i = 0 TO rows
        cx = w / 2
        cy = w + i * w + w / 2
        CIRCLE (cx, cy), r
 
        x = r * COS(angle * (i + 1) - _PI(.5))
        y = r * SIN(angle * (i + 1) - _PI(.5))
 
        LINE (0, cy + y)-(_WIDTH, cy + y), _RGB32(127, 127, 127)
        CircleFill cx + x, cy + y, 4, _RGB32(28, 222, 50)
        CircleFill cx + x, cy + y, 2, _RGB32(11, 33, 249)
 
        FOR j = 0 TO cols
            dot(i, j).y = cy + y
        NEXT
    NEXT
 
    _DEST plot
    LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA32(0, 0, 0, 4), BF
    FOR j = 0 TO rows
        FOR i = 0 TO cols
            CircleFill dot(j, i).x, dot(j, i).y, 1, hsb(_R2D(angle), 127, 127, 255)
        NEXT
    NEXT
 
    angle = angle + 0.01
    IF angle > _PI(2) THEN angle = 0
 
    _DEST 0
 
    _DISPLAY
    _LIMIT 30
LOOP
 
SUB CircleFill (x AS LONG, y AS LONG, R AS LONG, C AS _UNSIGNED LONG)
    DIM x0 AS SINGLE, y0 AS SINGLE
    DIM e AS SINGLE
 
    x0 = R
    y0 = 0
    e = -R
    DO WHILE y0 < x0
        IF e <= 0 THEN
            y0 = y0 + 1
            LINE (x - x0, y + y0)-(x + x0, y + y0), C, BF
            LINE (x - x0, y - y0)-(x + x0, y - y0), C, BF
            e = e + 2 * y0
        ELSE
            LINE (x - y0, y - x0)-(x + y0, y - x0), C, BF
            LINE (x - y0, y + x0)-(x + y0, y + x0), C, BF
            x0 = x0 - 1
            e = e - 2 * x0
        END IF
    LOOP
    LINE (x - R, y)-(x + R, y), C, BF
END SUB
 
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 
FUNCTION hsb~& (__H AS _FLOAT, __S AS _FLOAT, __B AS _FLOAT, A AS _FLOAT)
    DIM H AS _FLOAT, S AS _FLOAT, B AS _FLOAT
 
    H = map(__H, 0, 255, 0, 360)
    S = map(__S, 0, 255, 0, 1)
    B = map(__B, 0, 255, 0, 1)
 
    IF S = 0 THEN
        hsb~& = _RGBA32(B * 255, B * 255, B * 255, A)
        EXIT FUNCTION
    END IF
 
    DIM fmx AS _FLOAT, fmn AS _FLOAT
    DIM fmd AS _FLOAT, iSextant AS INTEGER
    DIM imx AS INTEGER, imd AS INTEGER, imn AS INTEGER
 
    IF B > .5 THEN
        fmx = B - (B * S) + S
        fmn = B + (B * S) - S
    ELSE
        fmx = B + (B * S)
        fmn = B - (B * S)
    END IF
 
    iSextant = INT(H / 60)
 
    IF H >= 300 THEN
        H = H - 360
    END IF
 
    H = H / 60
    H = H - (2 * INT(((iSextant + 1) MOD 6) / 2))
 
    IF iSextant MOD 2 = 0 THEN
        fmd = (H * (fmx - fmn)) + fmn
    ELSE
        fmd = fmn - (H * (fmx - fmn))
    END IF
 
    imx = _ROUND(fmx * 255)
    imd = _ROUND(fmd * 255)
    imn = _ROUND(fmn * 255)
 
    SELECT CASE INT(iSextant)
        CASE 1
            hsb~& = _RGBA32(imd, imx, imn, A)
        CASE 2
            hsb~& = _RGBA32(imn, imx, imd, A)
        CASE 3
            hsb~& = _RGBA32(imn, imd, imx, A)
        CASE 4
            hsb~& = _RGBA32(imd, imn, imx, A)
        CASE 5
            hsb~& = _RGBA32(imx, imn, imd, A)
        CASE ELSE
            hsb~& = _RGBA32(imx, imd, imn, A)
    END SELECT
 
END FUNCTION
 

Games / Battleship with AI by bplus

« on: March 08, 2020, 06:32:03 am »

Battleship with AI

Author: @bplus with @johnno56 and @Petr
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=218.0, « Reply #14 on: May 28, 2018, 08:14:32 AM »
Version: 5_AI
Tags: [2D], [Graphics]

Description:
Cool QB64 version of the classic game. Just like human players, my AI tracks whether it has shot at a cell or not.

Source Code:

Code: QB64: [Select]

_TITLE "Battleship 5_AI.bas by bplus"
'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
'OK this version with AI works though AI needs a fix
'2018-04-25 fixed the AI! yeah
'2018-04-25 PM Show ONLY ships sunk! Post 2018-04-25PM update
'2018-04-26PM add play again loop  Post v 2018-04-26
'  use Johnno's assets, Thanks Johnno
'  water = _loadimag("filename")
' _PUTIMAGE (x, y), water
' Add Petr's idea from today about Player option for automatic setup,
' Thanks Petr for sharing ideas.
'add Johnno's sounds
'2018-05-02 AM for me  Johnno adds explode stuff
'2018-05-02 9PM Battleship3 fix surprise screen shake
'2018-05-12&13 Battleship 4
' added checkClick for improved getClick routine
' option to turn off effects, center text in text box
' install new color system, and showShips on Players Board
' cut 20 lines from autoset, removed fill circle drawing routine
'2018-05-14 post version 05-14
' testing new shoot systems for getting first hits on ships
'2018-05-18 added new shoot subroutine that mods according to ships sunk
'2018-05-20 the 5_AI 5-20 version is working with new hit directions around first hit
'I am now going to add hitx(), hity(), ihit, rehit for going back into sunk ship area for more ships if currentHits <> 0
'it works, keeps hitting an area until currentHits = 0 or all previous hits have been surrounded with misses
'show boats not sunk!!!!
' try mod 3 coverage effectsON and AutosetON  to avoid questions when play a ton of games
'reviewed sound handling and changed to using handles
'changed grid color to blue
' cut m = 7 stuff from shoot reduced from 128 lines to nice size now!
' 5-AI 5-21 backup
' 2018-05-23 post 5_AI with this date
' remove playing soundfiles by handle& and go back to _SNDPLAYFILE but use volume!!!
' add splash screen
 
DIM SHARED main&
CONST xmax = 800
CONST ymax = 600
main& = _NEWIMAGE(xmax, ymax, 32)
SCREEN main&
_SCREENMOVE 360, 60
RANDOMIZE TIMER
 
'setup boards
CONST sq = 32
CONST sqPerSide = 10
CONST n1 = sqPerSide - 1
'screen offsets for AI board and player board
CONST ax = 50
CONST ay = 232
CONST px = 420
CONST py = 232
'setup ships
CONST nShips = 10
CONST ns2 = 5 '     number of ships divide by 2
CONST ns2p1 = 6 '   number of ships divide by 2 plus 1
CONST df = 1 '      delay time
'global arrays and variables
DIM SHARED a(sqPerSide, sqPerSide), p(sqPerSide, sqPerSide), water&, waterHit&, waterMiss&, GameOn, e, pAuto
DIM SHARED shipName$(nShips), shipLen(nShips), shipHits$(nShips), shipHor(nShips), shipX(nShips), shipY(nShips), shipSunk(nShips)
'hits array will track red and white pegs of hits and misses
REDIM SHARED hits(n1, n1) 'hit = 1 and miss = -1 and no shot taken = 0
DIM SHARED colA, row, col, bump
DIM SHARED ihit, rehit 'more hit tracking, this is for making sure all ships sunk in a hit area
REDIM SHARED hitx(0), hity(0)
DIM SHARED x1, y1, bombx, bomby, dir, currentHits, hit2 'for deciding where to bomb next
DIM SHARED carrier&, battleship&, cruiser&, submarine&, destroyer& 'to use in subs
DIM SHARED explode&(16)
 
'Johnno's Assets added to game
banner& = _LOADIMAGE("title.bmp")
water& = _LOADIMAGE("water.bmp")
waterHit& = _LOADIMAGE("water-hit.bmp")
waterMiss& = _LOADIMAGE("water-miss.bmp")
metal& = _LOADIMAGE("frame1.bmp")
setupships& = _LOADIMAGE("setupships.bmp")
notpeek& = _LOADIMAGE("notpeek.bmp")
carrier& = _LOADIMAGE("carrier.bmp")
battleship& = _LOADIMAGE("battleship.bmp")
cruiser& = _LOADIMAGE("cruiser.bmp")
submarine& = _LOADIMAGE("submarine.bmp")
destroyer& = _LOADIMAGE("destroyer.bmp")
again& = _LOADIMAGE("again.bmp")
loadExplode
 
shipLen(1) = 5: shipName$(1) = "   Carrier"
shipLen(2) = 4: shipName$(2) = "Battleship"
shipLen(3) = 3: shipName$(3) = "   Cruiser"
shipLen(4) = 3: shipName$(4) = " Submarine"
shipLen(5) = 2: shipName$(5) = " Destroyer"
shipLen(6) = 5: shipName$(6) = "   Carrier"
shipLen(7) = 4: shipName$(7) = "Battleship"
shipLen(8) = 3: shipName$(8) = "   Cruiser"
shipLen(9) = 3: shipName$(9) = " Submarine"
shipLen(10) = 2: shipName$(10) = " Destroyer"
 
 
shipblack& = _LOADIMAGE("ship-black.png")
shipfire& = _LOADIMAGE("ship-wfire.png")
xxmax = 640: yymax = 75 'pixels too slow
xstep = 1: ystep = 1
DIM pal&(300) 'pallette
FOR i = 1 TO 100
    fr = 240 * i / 100 + 15
    pal&(i) = _RGB(fr, 0, 0)
    pal&(i + 100) = _RGB(255, fr, 0)
    pal&(i + 200) = _RGB(255, 255, fr)
NEXT
DIM f(xxmax, yymax + 2) 'fire array and seed
FOR x = 0 TO xxmax
    f(x, yymax + 1) = INT(RND * 2) * 300
    f(x, yymax + 2) = 300
NEXT
 
_PUTIMAGE , shipblack&
getClick mx, my, q
IF q = 27 THEN END
ticker = 0
WHILE ticker < 3
    CLS
    IF ticker < 2.95 THEN _PUTIMAGE , shipblack& ELSE _PUTIMAGE , shipfire&
    FOR x = 1 TO xxmax - 1 'shift fire seed a bit
        r = RND
        IF r < .15 THEN
            f(x, yymax + 1) = f(x - 1, yymax + 1)
        ELSEIF r < .3 THEN
            f(x, yymax + 1) = f(x + 1, yymax + 1)
        ELSEIF r < .35 THEN
            f(x, yymax + 1) = INT(RND * 2) * 300
        END IF
    NEXT
    FOR y = 0 TO yymax 'fire based literally on 4 pixels below it like cellular automata
        FOR x = 1 TO xxmax - 1
            f(x, y) = max((f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x - 1, y + 2)) / 4 - 5, 0)
            LINE (80 + x * xstep, 230 + y * ystep)-STEP(xstep, ystep), pal&(f(x, y)), BF
        NEXT
    NEXT
    ticker = ticker + .025
    _DISPLAY
    _LIMIT 50
WEND
_DELAY 1.5
_AUTODISPLAY
rgb 0
LINE (0, 0)-(xmax, ymax), , BF
 
'   Display banner   and get the Players setting questions asked once and for all games until restart program
_PUTIMAGE (220, 10), banner&
TxtBx 509, "m", "Special Effects? press [y] yes or [n] no"
IF GetYN$ = "y" THEN e = -1 ELSE e = 0
ClearTextBox
_PUTIMAGE (150, 155), setupships&
IF GetYN$ = "y" THEN pAuto = -1 ELSE pAuto = 0
 
 
restart: '===================================================== restart new game
 
'reset all critical variables and arrays
ERASE a, p, shipHor, shipX, shipY, shipSunk
REDIM hits(n1, n1)
FOR i = 1 TO nShips
    shipHits$(i) = SPACE$(shipLen(i))
NEXT
'AI tracking
pTurn = 0: dir = 0: currentHits = 0: colA = -1
CLS
'start screen drawing
 
'   Display Grid frame
_PUTIMAGE (18, 200), metal&
rgb 9
drawGrid ax, ay, sq, sqPerSide
drawGrid px, py, sq, sqPerSide
FOR bannerx = 220 TO 15 STEP -1
    _PUTIMAGE (bannerx, 10), banner&
    _DELAY 0.01
NEXT
 
'setup a board with ships, Computer or AI's setup
autoset 1
 
'setup player's ships
IF pAuto THEN
    ClearTextBox
    _PUTIMAGE (277, 155), notpeek&
    autoset 0
    FOR s = ns2p1 TO nShips
        showShip s, shipX(s), shipY(s), shipHor(s)
    NEXT
 
ELSE 'player sets up his ships
    FOR s = ns2p1 TO nShips
        OK = 0
        WHILE OK = 0
            ClearTextBox
            ClearUpdateBox
            IF s = 1 OR s = 6 THEN _PUTIMAGE (480, 30), carrier&
            IF s = 2 OR s = 7 THEN _PUTIMAGE (474, 45), battleship&
            IF s = 3 OR s = 8 THEN _PUTIMAGE (496, 50), cruiser&
            IF s = 4 OR s = 9 THEN _PUTIMAGE (496, 45), submarine&
            IF s = 5 OR s = 10 THEN _PUTIMAGE (512, 50), destroyer&
            rgb 990
            '   Position text in UpdateTextBox beneath the ship.
            _PRINTSTRING (430, 100), "Setting up the " + LTRIM$(shipName$(s)) + ":  Length of" + STR$(shipLen(s)) + "."
            TxtBx 85, "t", "Position it Horizontally: Press [ H ]"
            TxtBx 942, "b", "  Position it Vertically: Press [ V ]"
            nogo = 1
            WHILE nogo
                hor$ = INKEY$
                IF hor$ = "v" OR hor$ = "h" THEN nogo = 0
                _LIMIT 200
            WEND
            ClearTextBox
            IF hor$ = "v" THEN
                TxtBx 942, "t", "Vertial it is."
                TxtBx 970, "b", "Now click the top most position of the ship."
                shipHor(s) = 0
            ELSE
                TxtBx 85, "t", "Horizontal it is:"
                TxtBx 970, "b", "Now click the left most position of the ship."
                shipHor(s) = -1
            END IF
 
            checkClick px, py, sq, sqPerSide, sx, sy, escape
            IF escape THEN CLS: END
 
            IF shipHor(s) THEN
                IF sx <= sqPerSide - shipLen(s) THEN
                    OK = 1
                    FOR xx = 0 TO shipLen(s) - 1
                        IF p(sx + xx, sy) < 0 THEN OK = 0: EXIT FOR
                    NEXT
                    IF OK THEN
                        shipX(s) = sx: shipY(s) = sy
                        FOR xx = 0 TO shipLen(s) - 1
                            p(sx + xx, sy) = -1 * s
                        NEXT
                    END IF
                END IF
            ELSE
                IF sy <= sqPerSide - shipLen(s) THEN
                    OK = 1
                    FOR yy = 0 TO shipLen(s) - 1
                        IF p(sx, sy + yy) < 0 THEN OK = 0: EXIT FOR
                    NEXT
                    IF OK THEN
                        shipX(s) = sx: shipY(s) = sy
                        FOR yy = 0 TO shipLen(s) - 1
                            p(sx, sy + yy) = -1 * s
                        NEXT
                    END IF
                END IF
            END IF
        WEND
        'update player board
        showShip s, shipX(s), shipY(s), shipHor(s)
        _LIMIT 30
    NEXT
END IF
 
 
'start the shooting match
GameOn = 1
WHILE GameOn
    updateStatus
    pTurn = 1 - pTurn
 
    IF pTurn THEN
        TxtBx 63, "m", "Player. Your turn.  Click on the computer's board."
        checkClick ax, ay, sq, sqPerSide, bx, by, escape
        IF escape THEN CLS: END
        IF e THEN
            _SNDPLAYFILE ("launch-hi.wav"), , 1
            _DELAY 3
        END IF
        IF a(bx, by) < 0 THEN
            IF e THEN
                playPutExplode ax + bx * sq, ay + by * sq, 0
                '_DELAY df
            END IF
            _PUTIMAGE (ax + bx * sq, ay + by * sq), waterHit&
            hitEval "a", bx, by 'game could end here
        ELSE
            _PUTIMAGE (ax + bx * sq, ay + by * sq), waterMiss&
            IF e THEN
                _SNDPLAYFILE ("splash-hi.wav"), , .3
                _DELAY 1
            END IF
        END IF
    ELSE
        'AI's turn if it gets a hit it will bomb around the ship until it is finished
        'could be trouble if 2 ships are next to each other, damn until just now I hadn't anticipated this
        'hits board tracks red and white pegs like a human player for AI
 
        '   Try to display random computer messages before it fires! - Humour...
        '   Possibly use select.. case.. end select?
        ClearTextBox
        choice = rand(1, 10)
        SELECT CASE choice
            CASE 1: m$ = "Hold onto something! My turn!"
            CASE 2: m$ = "Are you sure you want to do this?"
            CASE 3: m$ = "Close your eyes and start praying!"
            CASE 4: m$ = "Are you ready for what's coming?"
            CASE 5: m$ = "My turn! Buckle up Princess!"
            CASE 6: m$ = "Prepare for a world of hurt!"
            CASE 7: m$ = "Airmail... Special delivery!"
            CASE 8: m$ = "You have nowhere to hide!"
            CASE 9: m$ = "I have a surprise for you!"
            CASE 10: m$ = "Let's play catch! My turn!"
        END SELECT
        TxtBx 970, "m", m$
 
        IF dir THEN 'we have a bomb location all set to test
            IF p(bombx, bomby) < 0 THEN 'hit!
                IF e THEN
                    _SNDPLAYFILE ("launch-hi.wav"), , .3
                    _DELAY 3
                    playPutExplode px + bombx * sq, py + bomby * sq, 1
 
                    ClearTextBox
                    choice = rand(1, 10)
                    SELECT CASE choice
                        CASE 1: m$ = "No point crying about it!"
                        CASE 2: m$ = "You'll get over it."
                        CASE 3: m$ = "It's either you or me."
                        CASE 4: m$ = "No pain. No gain."
                        CASE 5: m$ = "Now that's gotta hurt!"
                        CASE 6: m$ = "You can always go home!"
                        CASE 7: m$ = "No shame in quitting."
                        CASE 8: m$ = "It'll buff right out."
                        CASE 9: m$ = "Side dish of scrap to go!"
                        CASE 10: m$ = "May you rust in peace."
                    END SELECT
                    TxtBx 930, "m", m$
                END IF
 
                hit2 = 1
                hits(bombx, bomby) = 1
                currentHits = currentHits + 1
                ihit = ihit + 1 'take a history  of hits since dir has been activated
                REDIM _PRESERVE hitx(ihit)
                REDIM _PRESERVE hity(ihit)
                hitx(ihit) = bombx
                hity(ihit) = bomby
 
                _PUTIMAGE (px + bombx * sq, py + bomby * sq), waterHit&
 
                'we need to know stuff but can't use this info for AI finding the ship
                'when hitEval announces a ship sunk we can reduce the currentHits count by that ships amount
                'if still have more current hits, continue bombing area as another ship is there
                hitEval "p", bombx, bomby 'this will reduce currentHits by the amount a ship could take when sunk
                IF currentHits = 0 THEN 'clear our checklist we sank all ships we hit, call off bombing of area
                    x1 = 0: y1 = 0: dir = 0
                ELSE
                    decideWhereToBombNext
                END IF
            ELSE 'no hit from checklist scratch off one item
                IF e THEN
                    _SNDPLAYFILE ("launch-hi.wav"), , .3
                    _DELAY 3
                END IF
                hit2 = 0
                hits(bombx, bomby) = -1
                _PUTIMAGE (px + bombx * sq, py + bomby * sq), waterMiss&
                ClearTextBox
                TxtBx 509, "m", "MISSED!!"
                IF e THEN
                    _SNDPLAYFILE ("splash-hi.wav"), , 1
                    _DELAY 1
                END IF
                decideWhereToBombNext
            END IF ' are we still working on hit
 
        ELSE
            'not working on any hits x1, y1 = 0, dir = 0, currentHits might be = 0
            'random but systematic shooting, bring up next good shooting location
 
            shoot tryx, tryy
 
            'consider that shot just fired was it a hit or miss
            IF p(tryx, tryy) < 0 THEN ' test our shot just fired is hit!
                IF e THEN
                    _SNDPLAYFILE ("launch-hi.wav"), , .3
                    _DELAY 3
                END IF
                ClearTextBox
                x1 = tryx: y1 = tryy 'save first hit to come back to
                hits(x1, y1) = 1
                currentHits = currentHits + 1
                IF e THEN
                    playPutExplode px + x1 * sq, py + y1 * sq, 1
                END IF
                _PUTIMAGE (px + x1 * sq, py + y1 * sq), waterHit&
 
                'we need to know stuff but can't use this info for AI finding the ship
                'it's the same as for the player
                hitEval "p", x1, y1
                'did we just happen to finish off a ship?  current hits = 0
                IF currentHits = 0 THEN 'must of finished off an ship
                    x1 = 0: x2 = 0: dir = 0 'we are done
                ELSE
                    dir = -1
                    decideWhereToBombNext
                END IF
            ELSE 'no hit
                IF e THEN
                    _SNDPLAYFILE ("launch-hi.wav"), , .3
                    _DELAY 3
                END IF
                _PUTIMAGE (px + tryx * sq, py + tryy * sq), waterMiss&
                ClearTextBox
                TxtBx 509, "m", "MISSED!!"
                IF e THEN
                    _SNDPLAYFILE ("splash-hi.wav"), , 1
                    _DELAY 1
                END IF
                hits(tryx, tryy) = -1
            END IF
 
        END IF 'rI (now tryx, tryy) was hit or not
    END IF 'whose turn is it
    _LIMIT 5
WEND
CLS
_PUTIMAGE (125, 265), again&
IF GetYN$ = "n" THEN CLS: END
GOTO restart
 
SUB updateStatus
    ClearTextBox
    ClearUpdateBox
    rgb 990
    LOCATE 2, 70: PRINT "Computer"
    rgb 63
    LOCATE 2, 83: PRINT "Player"
    FOR i = 1 TO 5
        rgb 85: LOCATE i + 2, 55: PRINT shipName$(i)
        IF shipSunk(i) THEN LOCATE i + 2, 72: rgb 940: PRINT "SUNK": rgb 999
        IF shipSunk(i + ns2) THEN LOCATE i + 2, 84: rgb 940: PRINT "SUNK": rgb 999
    NEXT
END SUB
 
SUB decideWhereToBombNext
    'find next good location, mark the direction we took
    IF dir = -1 THEN '    we just got a fresh hit the rest of the ship is in 1 of 4 directions
        'fresh slate
        REDIM hitx(0): REDIM hity(0): ihit = 0: rehit = 0
        redirect:
        hit2 = 0 'when direction = 0 reset 2nd hit signal to 0
        IF x1 + 1 <= n1 THEN
            IF hits(x1 + 1, y1) = 0 THEN
                bombx = x1 + 1: bomby = y1: dir = 1: EXIT SUB 'always the first direction to try
            END IF
        END IF
        'still here?
        IF x1 - 1 >= 0 THEN
            IF hits(x1 - 1, y1) = 0 THEN
                bombx = x1 - 1: bomby = y1: dir = 3: EXIT SUB
            END IF
        END IF
        'still here?
        IF y1 + 1 <= n1 THEN
            IF hits(x1, y1 + 1) = 0 THEN
                bombx = x1: bomby = y1 + 1: dir = 2: EXIT SUB
            END IF
        END IF
        'still here OK this has to do it!
        IF y1 - 1 >= 0 THEN
            IF hits(x1, y1 - 1) = 0 THEN
                bombx = x1: bomby = y1 - 1: dir = 4: EXIT SUB
            END IF
        END IF
        'still here ???? damn! give up and go back to random shots
        rehit = rehit + 1
        IF rehit > ihit THEN
            dir = 0: EXIT SUB 'back to random bombing
        ELSE
            x1 = hitx(rehit): y1 = hity(rehit)
            GOTO redirect
        END IF
 
        dir = 0: EXIT SUB '   <    this signals that
    END IF
 
    'setup next bombx, bomby
    IF hit2 THEN 'whatever direction we are taking, continue if we can
        SELECT CASE dir
            CASE 1
                IF bombx + 1 <= n1 THEN
                    IF hits(bombx + 1, bomby) = 0 THEN
                        bombx = bombx + 1: EXIT SUB
                    END IF
                END IF
            CASE 2
                IF bomby + 1 <= n1 THEN
                    IF hits(bombx, bomby + 1) = 0 THEN
                        bomby = bomby + 1: EXIT SUB
                    END IF
                END IF
            CASE 3
                IF bombx - 1 >= 0 THEN
                    IF hits(bombx - 1, bomby) = 0 THEN
                        bombx = bombx - 1: EXIT SUB
                    END IF
                END IF
            CASE 4
                IF bomby - 1 >= 0 THEN
                    IF hits(bombx, bomby - 1) = 0 THEN
                        bomby = bomby - 1: dir = 4: EXIT SUB
                    END IF
                END IF
        END SELECT
    END IF
 
    'still here? then we have to change direction  and go back to x1, y1 the first hit
    hit2 = 0 'reset this for the new direction check
    WHILE dir < 4 AND dir > 0
 
        'dir = dir + 1   want to try 180 direction before changing 90
 
        IF dir = 1 THEN
            dir = 3
        ELSEIF dir = 2 THEN
            dir = 4
        ELSEIF dir = 3 THEN
            dir = 2
        ELSEIF dir = 4 THEN
            rehit = rehit + 1
            IF rehit > ihit THEN
                dir = 0: EXIT SUB 'back to random bombing
            ELSE
                x1 = hitx(rehit): y1 = hity(rehit)
                GOTO redirect
            END IF
        END IF
        SELECT CASE dir
            CASE 2
                IF y1 + 1 <= n1 THEN
                    IF hits(x1, y1 + 1) = 0 THEN
                        bombx = x1: bomby = y1 + 1: EXIT SUB
                    END IF
                END IF
            CASE 3
                IF x1 - 1 >= 0 THEN
                    IF hits(x1 - 1, y1) = 0 THEN
                        bombx = x1 - 1: bomby = y1: EXIT SUB
                    END IF
                END IF
            CASE 4
                IF y1 - 1 >= 0 THEN
                    IF hits(x1, y1 - 1) = 0 THEN
                        bombx = x1: bomby = y1 - 1: EXIT SUB
                    END IF
                END IF
        END SELECT
    WEND
    'still here, well we've run out of directions
    rehit = rehit + 1
    IF rehit > ihit THEN
        dir = 0: EXIT SUB 'back to random bombing
    ELSE
        x1 = hitx(rehit): y1 = hity(rehit)
        GOTO redirect
    END IF
 
    'dir = 0 'back to random bombing
END SUB
 
SUB hitEval (board$, bbx, bby)
    'this is like a referee / judge for both players  to announce a ship sunk and a game won?
    IF board$ <> "p" THEN
        s = -1 * a(bbx, bby)
        you$ = "Player"
        my$ = "Computer's"
        istart = 1
        istop = ns2
    ELSE
        s = -1 * p(bbx, bby)
        you$ = "Computer"
        my$ = "Player's"
        istart = ns2p1
        istop = nShips
    END IF
    IF shipHor(s) THEN d = bbx - shipX(s) + 1 ELSE d = bby - shipY(s) + 1
    MID$(shipHits$(s), d) = "X"
    IF shipHits$(s) = STRING$(shipLen(s), "X") THEN
        IF board$ = "p" THEN currentHits = currentHits - shipLen(s)
        updateStatus
        TxtBx 995, "m", you$ + " sank the " + my$ + " " + LTRIM$(shipName$(s)) + "!"
        _DELAY 1
        shipSunk(s) = 1
        tot = 0
        FOR i = istart TO istop
            IF shipSunk(i) = 1 THEN tot = tot + 1
        NEXT
        IF tot = ns2 THEN
            updateStatus
            TxtBx 995, "m", "Congratulations " + you$ + "!!  You sank the " + my$ + " fleet!  GameOver..."
            IF you$ = "Computer" THEN
                FOR y = 0 TO sqPerSide - 1
                    FOR x = 0 TO sqPerSide - 1
                        IF a(x, y) < 0 THEN
                            rgb 900
                            FOR i = 1 TO 5 'show ships locations for Player that lost
                                IF i MOD 2 THEN rgb 900 ELSE rgb 999
                                LINE (ax + x * sq + i, ay + y * sq + i)-STEP(sq - 2 * i, sq - 2 * i), , B
                            NEXT
                        END IF
                    NEXT
                NEXT
                _DELAY 5
            END IF
            _DELAY 4
            GameOn = 0
        END IF
    END IF
END SUB
 
SUB autoset (AItf) '  there is surely a shorter way to do this but I am eager to get on with other stuff
    'setup a board with ships, AItf if true setup for Computer else for Player
    FOR i = 1 TO ns2
        IF AItf THEN s = i ELSE s = i + 5
        OK = 0
        WHILE OK = 0
            shipHor(s) = rand(0, 1)
            IF shipHor(s) THEN
                sy = rand(0, n1)
                sx = rand(0, sqPerSide - shipLen(s))
                OK = 1
                FOR xx = 0 TO shipLen(s) - 1
                    IF AItf THEN
                        IF a(sx + xx, sy) < 0 THEN OK = 0: EXIT FOR
                    ELSE
                        IF p(sx + xx, sy) < 0 THEN OK = 0: EXIT FOR
                    END IF
                NEXT
                IF OK THEN
                    shipX(s) = sx: shipY(s) = sy
                    FOR xx = 0 TO shipLen(s) - 1
                        IF AItf THEN
                            a(sx + xx, sy) = -1 * s
                        ELSE
                            p(sx + xx, sy) = -1 * s
                        END IF
                    NEXT
                END IF
            ELSE
                sx = rand(0, n1)
                sy = rand(0, sqPerSide - shipLen(s))
                OK = 1
                FOR yy = 0 TO shipLen(s) - 1
                    IF AItf THEN
                        IF a(sx, sy + yy) < 0 THEN OK = 0: EXIT FOR
                    ELSE
                        IF p(sx, sy + yy) < 0 THEN OK = 0: EXIT FOR
                    END IF
                NEXT
                IF OK THEN
                    shipX(s) = sx: shipY(s) = sy
                    FOR yy = 0 TO shipLen(s) - 1
                        IF AItf THEN
                            a(sx, sy + yy) = -1 * s
                        ELSE
                            p(sx, sy + yy) = -1 * s
                        END IF
                    NEXT
                END IF
            END IF
        WEND
    NEXT
END SUB
 
SUB showShip (shipn, bxhead, byhead, hTF)
    'setup to combine use with RotoZoom code Wiki
    SELECT CASE shipn 'player's ships only, get ship len and
        CASE 6: shipLen = 5: sh& = carrier&
        CASE 7: shipLen = 4: sh& = battleship&
        CASE 8: shipLen = 3: sh& = cruiser&
        CASE 9: shipLen = 3: sh& = submarine&
        CASE 10: shipLen = 2: sh& = destroyer&
    END SELECT
    IF hTF THEN 'horizontal True
        dx1 = px + sq * bxhead + 1
        dy1 = py + sq * byhead + 1
        dx2 = px + sq * (bxhead + shipLen) - 1
        dy2 = py + sq * (byhead + 1) - 1
        _PUTIMAGE (dx1, dy1)-(dx2, dy2), sh&, main&
    ELSE
        DIM px(3) AS SINGLE: DIM py(3) AS SINGLE
        W& = _WIDTH(sh&): H& = _HEIGHT(sh&)
        px(0) = -W& / 2: py(0) = -H& / 2: px(1) = -W& / 2: py(1) = H& / 2
        px(2) = W& / 2: py(2) = H& / 2: px(3) = W& / 2: py(3) = -H& / 2
        sinr! = SIN(-90 / 57.2957795131): cosr! = COS(-90 / 57.2957795131)
 
        xsqlen = 30: ysqlen = 32 * shipLen - 2
        xscale = xsqlen / H&: yscale = ysqlen / W&
        xpivot = px + sq * bxhead + .5 * sq: ypivot = py + sq * byhead + .5 * sq * shipLen
        FOR i& = 0 TO 3
            x2& = (px(i&) * cosr! + sinr! * py(i&)) * xscale + xpivot: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yscale + ypivot
            px(i&) = x2&: py(i&) = y2&
        NEXT
        _MAPTRIANGLE (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), sh& TO(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
        _MAPTRIANGLE (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), sh& TO(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
    END IF
END SUB
 
'want the board square bx, by from board with grid xoff, yoff, sq pixels, n x n square board
SUB checkClick (xoff, yoff, sq, n, bx, by, escape)
    WHILE 1
        getClick mx, my, q ' get players move
        IF q = 27 OR q = 113 OR q = 81 THEN escape = 1: EXIT SUB
        row = (my - yoff) / sq
        IF row > 0 AND row < n THEN
            by = INT(row)
            col = (mx - xoff) / sq
            IF col > 0 AND col < n THEN
                bx = INT(col)
                EXIT WHILE
            ELSE 'this is beeping right after setup (not after a click)
                IF mx <> -1 AND my <> -1 THEN BEEP
            END IF
        ELSE 'this is beeping right after setup (not after a click)
            IF mx <> -1 AND my <> -1 THEN BEEP
        END IF
        _LIMIT 1000
    WEND
END SUB
 
SUB getClick (mx, my, q)
    WHILE _MOUSEINPUT: WEND ' clear previous mouse activity
    mx = -1: my = -1: q = 0
    DO WHILE mx = -1 AND my = -1
        q = _KEYHIT
        IF q = 27 OR (q > 31 AND q < 126) THEN EXIT SUB
        i = _MOUSEINPUT: mb = _MOUSEBUTTON(1)
        IF mb THEN
            DO WHILE mb 'wait for release
                q = _KEYHIT
                IF q = 27 OR (q > 31 AND q < 126) THEN EXIT SUB
                i = _MOUSEINPUT: mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
                _LIMIT 1000
            LOOP
            EXIT SUB
        END IF
        _LIMIT 1000
    LOOP
END SUB
 
SUB drawGrid (x, y, sq, n)
    d = sq * n
    FOR i = 0 TO n
        LINE (x + sq * i, y)-(x + sq * i, y + d)
        LINE (x, y + sq * i)-(x + d, y + sq * i)
    NEXT
    FOR yy = 0 TO n - 1
        FOR xx = 0 TO n - 1
            _PUTIMAGE (x + sq * xx, y + sq * yy), water&
        NEXT
    NEXT
END SUB
 
FUNCTION rand% (lo%, hi%)
    rand% = INT(RND * (hi% - lo% + 1)) + lo%
END FUNCTION
 
SUB TxtBx (n, L$, Message$)
    rgb n
    IF L$ = "t" THEN y = 150
    IF L$ = "m" THEN y = 160
    IF L$ = "b" THEN y = 170
    x = (769 - LEN(Message$) * 8) / 2 + 18
    _PRINTSTRING (x, y), Message$
END SUB
 
SUB ClearTextBox
    rgb 0
    LINE (18, 141)-(769, 194), , BF
END SUB
 
SUB ClearUpdateBox
    rgb 0
    LINE (380, 11)-(769, 129), , BF
END SUB
 
SUB loadExplode ()
    FOR i = 1 TO 16
        x$ = RIGHT$("0" + LTRIM$(STR$(i)), 2)
        f$ = "exp_" + x$ + ".bmp"
        explode&(i) = _LOADIMAGE(f$)
        ' _PUTIMAGE (i * 32, i * 32), explode&(i)   '< test load of file
    NEXT
END SUB
 
SUB playPutExplode (x, y, shake)
    IF shake THEN _SNDPLAYFILE ("explosion-hi.wav"), , 1 ELSE _SNDPLAYFILE ("explosion-hi.wav"), , .3
    FOR i = 1 TO 16
        _PUTIMAGE (x + 1, y + 1), explode&(i)
        _DELAY .05
        IF shake THEN
            _SCREENMOVE 360 + rand(-10, 10), 60 + rand(-10, 10)
            _SCREENMOVE 360 + rand(-10, 10), 60 + rand(-10, 10)
        END IF
    NEXT
    IF shake THEN _SCREENMOVE 360, 60
    _DELAY .1
END SUB
 
SUB rgb (n) ' New (even less typing!) New Color System 1000 colors with up to 3 digits
    s3$ = RIGHT$("000" + LTRIM$(STR$(n)), 3)
    r = VAL(MID$(s3$, 1, 1)): IF r THEN r = 28 * r + 3
    g = VAL(MID$(s3$, 2, 1)): IF g THEN g = 28 * g + 3
    b = VAL(MID$(s3$, 3, 1)): IF b THEN b = 28 * b + 3
    COLOR _RGB32(r, g, b)
END SUB
 
FUNCTION GetYN$ ()
    k$ = "": WHILE k$ <> "n" AND k$ <> "y": k$ = INKEY$: _LIMIT 200: WEND
    GetYN$ = k$
END FUNCTION
 
SUB shoot (col, row) 'col, row aren't inputs so mush as outputs like a double function return wo input parameters
    i = nShips
    WHILE shipSunk(i) 'find smallest ship not sunk
        i = i - 1
    WEND
    SELECT CASE i 'm for modulus, d for direction to run a check from
        CASE nShips: m = 3 'still have destroyer, for more exciting game testng m = 3
        CASE nShips - 1: m = 3 'still have sub
        CASE nShips - 2: m = 3 'still have cruiser
        CASE nShips - 3: m = 4 'still have battleship
        CASE nShips - 4: m = 5 'still have carrier
    END SELECT
    bc = 0
    IF colA = -1 THEN 'col the Attact starts from notice it is random so player can't anticipate
        colA = rand%(0, n1): col = colA: row = rand(0, n1): bump = rand(0, m - 1)
    END IF
    WHILE bc < m
        cc = 1
        WHILE cc <= sqPerSide
            rc = 0
            WHILE rc <= sqPerSide 'find a space to hit if one left in this column
                IF cover(m, bump, col, row) THEN 'are we on a place to cover board
                    IF hits(col, row) = 0 THEN EXIT SUB 'good to go!
                END IF
                row = (row + 1) MOD sqPerSide
                rc = rc + 1
            WEND
            row = row - 1
            IF row < 0 THEN row = n1
            'still here means we checked all rows in col so check next col
            col = (col + 1) MOD sqPerSide
            cc = cc + 1
        WEND
        'still here ? then up the bump
        bump = (bump + 1) MOD m
        bc = bc + 1
    WEND
END SUB
 
'using a modulus m coverage with a bump so that opponent can't predict where
'the hardest place to plant the Detroyer
FUNCTION cover (m, bump, c, r)
    bm = bump MOD m 'make sure bump is in modulus
    cm = (c + bm) MOD m
    rm = r MOD m
    IF rm = cm THEN cover = -1 ELSE cover = 0
END FUNCTION
 
FUNCTION max (a, b)
    IF a > b THEN max = a ELSE max = b
END FUNCTION
 

Battleship 5-AI 2018-05-24.zip

Bplus edit fixed download .zip

SUB _GL / Moving into the Matrix Rain by Ashish

« on: March 07, 2020, 10:11:51 am »

Author: @Ashish
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1453
Version: 1
Tags: [3D], [Graphics]

Description:
I was just inspired by Bplus's Matrix rain on this topic - https://www.qb64.org/forum/index.php?topic=1152.msg106362
So, I decided to create a similar matrix rain having depth effect.

Source Code:

Code: QB64: [Select]

'Moving into the Matrix Rain
'By Ashish Kushwaha
'23 Jun, 2019
'
'Inspire by B+ Matrix Rain.
_TITLE "Moving into the Matrix Rain"
 
RANDOMIZE TIMER
 
SCREEN _NEWIMAGE(800, 600, 32)
 
TYPE matRain
    x AS SINGLE 'x location
    y AS SINGLE 'y location
    z AS SINGLE 'z location
    ay AS SINGLE 'rain velocity
    strData AS STRING 'string data of each matrix rain
END TYPE
 
DIM SHARED charImg(74) AS LONG, matRainWidth, matRainHeight 'ascii char from 48 to 122, i.e, total 75 type of chars
DIM SHARED glAllow AS _BYTE, matrixRain(700) AS matRain, matrixRainTex(74) AS LONG, mov
matRainWidth = _FONTWIDTH * 0.005
matRainHeight = _FONTHEIGHT * 0.005
CLS , _RGB32(255)
tmp& = _NEWIMAGE(_FONTWIDTH - 1, _FONTHEIGHT, 32)
FOR i = 0 TO 74
    charImg(i) = _NEWIMAGE(_FONTWIDTH * 5, _FONTHEIGHT * 5, 32)
    _DEST tmp&
    CLS , _RGBA(0, 0, 0, 0)
    COLOR _RGB32(0, 255, 0), 1
    _PRINTSTRING (0, 0), CHR$(i + 48)
    _DEST charImg(i)
    _PUTIMAGE , tmp&
    _DEST 0
NEXT
 
 
glAllow = -1
DO
    FOR i = 0 TO UBOUND(matrixRain)
        matrixRain(i).y = matrixRain(i).y - matrixRain(i).ay
        IF RND > 0.9 THEN
            d$ = ""
            FOR k = 1 TO LEN(matrixRain(i).strData)
                d$ = d$ + CHR$(48 + p5random(0, 74)) 'change the character of rain randomly by a chance of 10%
            NEXT
            matrixRain(i).strData = d$
        END IF
        matrixRain(i).z = matrixRain(i).z + 0.00566 'move into the rain
        IF matrixRain(i).z > 0.1 THEN 'when behind screen
            matrixRain(i).x = p5random(-2, 2)
            matrixRain(i).y = p5random(2, 3.7)
            matrixRain(i).z = map((i / UBOUND(matrixRain)), 0, 1, -8, -0.2)
            matrixRain(i).ay = p5random(0.006, 0.02)
        END IF
    NEXT
    _LIMIT 60
LOOP
 
SUB _GL ()
    STATIC glInit
    mov = mov + 0.01
    IF NOT glAllow THEN EXIT SUB
 
    IF glInit = 0 THEN
        glInit = 1
 
        FOR i = 0 TO UBOUND(matrixRainTex) 'create texture for each ascii character
            _glGenTextures 1, _OFFSET(matrixRainTex(i))
 
            DIM m AS _MEM
            m = _MEMIMAGE(charImg(i))
 
            _glBindTexture _GL_TEXTURE_2D, matrixRainTex(i)
            _glTexImage2D _GL_TEXTURE_2D, 0, _GL_RGBA, _WIDTH(charImg(i)), _HEIGHT(charImg(i)), 0, _GL_BGRA_EXT, _GL_UNSIGNED_BYTE, m.OFFSET
 
            _MEMFREE m
 
            _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MAG_FILTER, _GL_NEAREST
            _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MIN_FILTER, _GL_NEAREST
            _FREEIMAGE charImg(i)
        NEXT
 
        FOR i = 0 TO UBOUND(matrixRain) 'initialization
            n = p5random(1, 15)
            FOR j = 1 TO n
                v$ = CHR$(p5random(48, 122))
                matrixRain(i).strData = matrixRain(i).strData + v$
            NEXT
            matrixRain(i).x = p5random(-2, 2)
            matrixRain(i).y = p5random(2, 3.7)
            matrixRain(i).z = map((i / UBOUND(matrixRain)), 0, 1, -8, -0.2)
            matrixRain(i).ay = p5random(0.006, 0.02)
        NEXT
 
        _glViewport 0, 0, _WIDTH, _HEIGHT
    END IF
 
    _glEnable _GL_BLEND 'enabling necessary stuff
    _glEnable _GL_DEPTH_TEST
    _glEnable _GL_TEXTURE_2D
 
 
    _glClearColor 0, 0, 0, 1
    _glClear _GL_COLOR_BUFFER_BIT OR _GL_DEPTH_BUFFER_BIT
 
 
    _glMatrixMode _GL_PROJECTION
    _glLoadIdentity
    _gluPerspective 60, _WIDTH / _HEIGHT, 0.01, 10.0
 
    _glRotatef SIN(mov) * 20, 1, 0, 0 'rotating x-axis a bit, just to get Depth effect.
 
 
    _glMatrixMode _GL_MODELVIEW
    _glLoadIdentity
 
    'rendering the rain
    FOR i = 0 TO UBOUND(matrixRain)
        n = LEN(matrixRain(i).strData)
        FOR j = 1 TO n
            ca$ = MID$(matrixRain(i).strData, j, 1)
            'selecting texture on the basis of ascii code.
            _glBindTexture _GL_TEXTURE_2D, matrixRainTex(ASC(ca$) - 48)
            _glBegin _GL_QUADS
            _glTexCoord2f 0, 1
            _glVertex3f matrixRain(i).x - matRainWidth, matrixRain(i).y - matRainHeight + 2 * (j - 1) * matRainHeight, matrixRain(i).z
            _glTexCoord2f 0, 0
            _glVertex3f matrixRain(i).x - matRainWidth, matrixRain(i).y + matRainHeight + 2 * (j - 1) * matRainHeight, matrixRain(i).z
            _glTexCoord2f 1, 0
            _glVertex3f matrixRain(i).x + matRainWidth, matrixRain(i).y + matRainHeight + 2 * (j - 1) * matRainHeight, matrixRain(i).z
            _glTexCoord2f 1, 1
            _glVertex3f matrixRain(i).x + matRainWidth, matrixRain(i).y - matRainHeight + 2 * (j - 1) * matRainHeight, matrixRain(i).z
            _glEnd
        NEXT
    NEXT
 
    _glFlush
END SUB
 
'taken from p5js.bas
'https://bit.ly/p5jsbas
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 
 
FUNCTION p5random! (mn!, mx!)
    IF mn! > mx! THEN
        SWAP mn!, mx!
    END IF
    p5random! = RND * (mx! - mn!) + mn!
END FUNCTION
 

Moving into the Matrix Rain Screenshot.jpg

Games / Hunter's Revenge by Ashish

« on: March 05, 2020, 05:50:56 am »

Hunter's Revenge

Author: @Ashish
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=345.msg2322#msg2322
Version: « Reply #7 on: July 18, 2018, 12:48:12 PM »
Tags: [Graphics], [2D], [Shoot 'Em]

Description:
You got a gun, and what you have to do is shoot down the objects you see on screen. The game have different weather conditions as well as different areas.

Controls:
Use mouse movement to change your target. Use left click to shoot and right click to change gun. Use 'Esc' or Middle button to pause during gameplay.

Source Code:

Code: QB64: [Select]

'################################################################
'      H U N T E R ' S    R E V E N G E    2 0 1 7 - 1 8
'                  By Ashish Kushwaha
'         **** Hit F5 and Enjoy the Game!! ****
'Note :-
'The executable should be inside Hunter-Revenge folder
'If you are facing any problem, report it at Qb64.org Forum
'
'*** Tell Me You You Think About This Game On Twitter with @KingOfCoders ***
'
'################################################################
 
'$CONSOLE
'_CONSOLETITLE "Hunter's Revenge [DEBUG_OUTPUT]"
 
IF COMMAND$(1) = "--reset" THEN
    INPUT "Are you sure that you want to reset the game? (Y/N) ", dummy$1
    IF UCASE$(dummy$1) = "Y" THEN KILL "Save_Game/save.dat": createConfig: SYSTEM
END IF
 
'App icon
$EXEICON:'Hunter-Revenge-master/Images/game.ico'
tmp_icon& = _LOADIMAGE("Images/cursor.png", 32)
_CLEARCOLOR _RGB(255, 255, 255), tmp_icon&
_ICON tmp_icon&
_FREEIMAGE tmp_icon&
 
DO: LOOP UNTIL _SCREENEXISTS
RANDOMIZE TIMER
'$include:'Vendor/spritetop.bi'
_DELAY 1
_MOUSEHIDE
 
_TITLE "Hunter's Revenge"
 
SCREEN _NEWIMAGE(800, 600, 32)
DO: LOOP UNTIL _SCREENEXISTS
 
' ON ERROR GOTO 404
 
_DISPLAYORDER _SOFTWARE , _HARDWARE , _GLRENDER , _HARDWARE1
 
'Notification Section
DIM SHARED NEvent, NFPSCount%, NImage&, NText$, NShow AS _BYTE
 
'Frame Rate Section
DIM SHARED FPSEvent, FPSEvt, FPSCurrent%, FPSRate%, FPSBg&
 
'Loader Section
DIM SHARED Loader&, LoaderX%, LoaderY%, LoaderCF%, LoaderEvt!
LoaderX% = 730: LoaderY% = 500
 
'Game Types
TYPE GameMenu
    click AS _BYTE
    hover AS _BYTE
    y AS INTEGER
    img AS LONG
    img2 AS LONG 'software image
END TYPE
 
TYPE Mousetype
    x AS INTEGER
    y AS INTEGER
    lclick AS _BYTE
    rclick AS _BYTE
    mclick AS _BYTE
    cursor AS LONG
    cursor2 AS LONG
    hovering AS _BYTE
END TYPE
 
TYPE fonttype
    smaller AS LONG
    normal AS LONG
    bigger AS LONG
    biggest AS LONG
END TYPE
'game objects
 
TYPE explosiontype
    x AS INTEGER
    y AS INTEGER
    img AS INTEGER
    active AS _BYTE
    currentFrame AS INTEGER
    totalFrames AS INTEGER
    f AS INTEGER
    n AS INTEGER
END TYPE
 
TYPE guntype
    name AS STRING * 32
    damage AS INTEGER
    id AS INTEGER
    img AS LONG
END TYPE
 
TYPE Enemies
    x AS INTEGER ' x position
    y AS INTEGER ' y position
    typ AS STRING * 16 'type of enemie
    life AS INTEGER 'life of the enemie
    life2 AS INTEGER 'backup of life
    damage AS INTEGER 'useless
    ending AS _BYTE 'enemie is dead or not
    img AS INTEGER 'sprite handle
    active AS _BYTE 'enemie is active or not
    u AS LONG 'delay (in milliseconds) after which enemie will show up in his scene in gameplay
    n AS INTEGER 'delay between change of frame of animation
    f AS INTEGER 'increment varible, if greater than above 'n', then frame is change
    m AS DOUBLE 'movement speed
    points AS INTEGER 'holds point
    scene AS INTEGER 'hold scene
    snd AS LONG 'hold sound handle
    sndPaused AS _BYTE ' = true when sound is paused.
END TYPE
 
TYPE Levels
    enemies AS INTEGER 'total enemies in a level
    scenes AS INTEGER 'total scenes in a level
    currentScene AS INTEGER 'current scene of the gameplay
    completed AS _BYTE 'level has been completed or not
    u AS LONG 'current frame of the gameplay (always increases during gameplay)
    over AS _BYTE ' level has been over or not
    background AS STRING * 64 'background image path of the level
    bg AS LONG 'background image handle of the level
    mode AS INTEGER 'MODs of the game. Can be either THUNDERMODE, STORMMODE, FOGMODE, THUNDERMODE+FOGMODE, THUNDERMODE+STORMMODE
    cancel AS _BYTE 'level has been cancel or not
    time AS _UNSIGNED INTEGER 'number of seconds a level has to be completed in (in seconds).
END TYPE
 
TYPE fog
    x AS INTEGER
    move AS INTEGER
    handle AS LONG
END TYPE
 
TYPE drops
    x AS INTEGER
    y AS INTEGER
    z AS INTEGER
    len AS DOUBLE
    yspeed AS DOUBLE
    gravity AS DOUBLE
END TYPE
 
TYPE Settings
    fullscreen AS _BYTE
    music AS _BYTE
    sfx AS _BYTE
    musicV AS DOUBLE
    sfxV AS DOUBLE
    SE AS _BYTE
    fps AS INTEGER
    done AS _BYTE
END TYPE
 
'score flasher
TYPE scoreFlasher
    x AS SINGLE
    y AS SINGLE
    img AS LONG
    active AS _BYTE
    sclX AS SINGLE
    sclY AS SINGLE
    __ops AS SINGLE
END TYPE
 
' TYPE Vector_Particles_Text_Type
' x AS SINGLE 'x position
' y AS SINGLE 'y position
' vx AS SINGLE 'visual x
' vy AS SINGLE 'visual y
' delX AS SINGLE 'delta velocity
' delY AS SINGLE 'delta velocity
' dist AS SINGLE 'distance
' distX AS SINGLE ' distance x
' distY AS SINGLE 'distance y
' k AS SINGLE
' END TYPE
 
'$DYNAMIC
 
RANDOMIZE TIMER
DIM SHARED W AS Settings
readConfig
 
'DIM SHARED Paused AS _BYTE
 
'REDIM SHARED Text_Particles(1) AS Vector_Particles_Text_Type
 
'DIM SHARED Text_Particles_Status, Text_Particles_Color AS _UNSIGNED LONG
 
DIM SHARED randomLevels AS _BYTE 'Computer chooses level! ^_*
 
DIM SHARED Menubg&, GlobalEvent, TimerEvent, GameRenderingEvent, Minutes%, Seconds%
 
DIM SHARED Mouse AS Mousetype
 
DIM SHARED Fonts AS fonttype
 
DIM SHARED GameMenus(19) AS GameMenu
 
DIM SHARED MenuBlood%, MenuChoice
 
DIM SHARED ShotScore(5) AS scoreFlasher
 
DIM SHARED explosions(20) AS explosiontype, Gun AS guntype, Bloods(50) AS explosiontype
 
DIM SHARED Level AS Levels
 
DIM SHARED HighScore%, LevelStage%, LevelStage2%, CurrentScore%
 
DIM SHARED ScoreBoard&, GunImg&(1), OldScore%, OldSeconds%
 
DIM SHARED Musics&(2)
 
RANDOMIZE TIMER
'Rains
DIM SHARED Drop(700) AS drops
DIM SHARED Rainx8&, Rainx16&, RainLight&, RainSound&, RainVol#, ThunderCount, ThunderEvent
 
 
 
'max level
CONST MAX_LEVEL = 14
'storm
DIM SHARED StormImg&, StormX%
 
'Sparks
DIM SHARED ExplosionsZ(1) AS explosiontype
 
'MODS
CONST FOGMODE = 1
CONST THUNDERMODE = 3
CONST STORMMODE = 5
DIM SHARED Fogs AS fog
 
'SFXs
DIM SHARED Eagle&
DIM SHARED Bird&
DIM SHARED Crow&
DIM SHARED Expos&
DIM SHARED Jet&
DIM SHARED Gun1&
DIM SHARED Gun2&
 
'Enemies scores image
DIM SHARED scoresImage(5) AS LONG
 
REDIM SHARED Enemie(0) AS Enemies
 
DIM SHARED Jet1_Sheet%
DIM SHARED Jet2_Sheet%
DIM SHARED Jet3_Sheet%
DIM SHARED Bird_Sheet%
DIM SHARED Crow_Sheet%
DIM SHARED eagle_Sheet%
DIM SHARED blood_Sheet%
DIM SHARED explosion_Sheet%
DIM SHARED spark_Sheet%
DIM SHARED lifeBars(99) AS LONG
 
FPSEvent = _FREETIMER 'Event for showing current FPS (Frame Per Second)
FPSEvt = _FREETIMER 'Event for calculating current FPS (Frame Per Second)
GlobalEvent = _FREETIMER 'Event for game main menu
TimerEvent = _FREETIMER 'Event of timer which is displayed during gameplay
GameRenderingEvent = _FREETIMER 'Event in which level objects are rendered.
NEvent = _FREETIMER ' Global Event for notification
 
'Splash Screen
 
Splash
 
 
LoaderStart
 
loadComponents
'cursors
Mouse.cursor = _LOADIMAGE("Images/cursor.png", 33)
Mouse.cursor2 = _LOADIMAGE("Images/cursor2.png", 33)
 
'fonts
Fonts.biggest = _LOADFONT("Font/ARDESTINE.ttf", 68)
Fonts.bigger = _LOADFONT("Font/ARDESTINE.ttf", 40)
Fonts.smaller = _LOADFONT("Font/arial.ttf", 12, "dontblend")
Fonts.normal = _LOADFONT("Font/ARDESTINE.ttf", 24)
 
'scores image
 
scoresImage(0) = _LOADIMAGE("Images/10.png", 33)
scoresImage(1) = _LOADIMAGE("Images/20.png", 33)
scoresImage(2) = _LOADIMAGE("Images/35.png", 33)
scoresImage(3) = _LOADIMAGE("Images/50.png", 33)
scoresImage(4) = _LOADIMAGE("Images/75.png", 33)
scoresImage(5) = _LOADIMAGE("Images/100.png", 33)
 
'fogs
Fogs.x = 0
Fogs.move = 1
Fogs.handle = _LOADIMAGE("Images/fogs_.png", 33)
 
'rains
Rainx8& = _LOADIMAGE("Images/rainx8.png", 33)
Rainx16& = _LOADIMAGE("Images/rainx16.png", 33)
 
 
'storm
StormImg& = _LOADIMAGE("Images\storm.png", 33) 'we're using hardware image
 
'LifeBars
DIM i AS INTEGER, r AS INTEGER, g AS INTEGER
FOR i = 0 TO 99
    lifeBars(i) = _NEWIMAGE(100, 6, 32)
    _DEST lifeBars(i)
    r = p5map(i + 1, 1, 100, 255, 0)
    g = p5map(i + 1, 1, 100, 0, 255)
    LINE (0, 0)-(100, 6), _RGB(0, 0, 0), BF
    LINE (0, 0)-(i + 1, 6), _RGB(r, g, 0), BF
    LINE (0, 0)-(99, 5), _RGB(255, 255, 255), B
    _DEST 0
NEXT
 
DIM tmp&
FOR i = 0 TO 99
    tmp& = _COPYIMAGE(lifeBars(i))
    _FREEIMAGE lifeBars(i)
    lifeBars(i) = _COPYIMAGE(tmp&, 33)
    _FREEIMAGE tmp&
NEXT
 
Gun.damage = 3
Gun.id = 1
Gun.name = "Shot Gun"
 
Menubg& = _LOADIMAGE("Images\farm1.jpg")
GunImg&(0) = _LOADIMAGE("Images\gun_shot.png")
GunImg&(1) = _LOADIMAGE("Images\Gun_ak-47.png")
ScoreBoard& = _LOADIMAGE("Images\score_board.png")
 
blood_Sheet% = SPRITESHEETLOAD("Images\blood.png", 64, 62, _RGB(0, 0, 0))
Jet1_Sheet% = SPRITESHEETLOAD("Images\Jet.png", 120, 122, _RGB(0, 0, 0))
Jet2_Sheet% = SPRITESHEETLOAD("Images\Jet_2.png", 120, 122, _RGB(0, 0, 0))
Jet3_Sheet% = SPRITESHEETLOAD("Images\Jet_3.png", 150, 122, _RGB(0, 0, 0))
eagle_Sheet% = SPRITESHEETLOAD("Images\eagle.png", 40, 40, _RGB(0, 0, 0))
Crow_Sheet% = SPRITESHEETLOAD("Images\crow.png", 97, 120, _RGB(0, 0, 0))
Bird_Sheet% = SPRITESHEETLOAD("Images\bird.png", 180, 170, _RGB(0, 0, 0))
 
explosion_Sheet% = SPRITESHEETLOAD("Images\explosion.png", 100, 100, _RGB(0, 0, 0))
 
FOR i = 0 TO 1
    ExplosionsZ(i).img = SPRITENEW(explosion_Sheet%, 1, SAVE)
    SPRITEANIMATESET ExplosionsZ(i).img, 1, 81
    ExplosionsZ(i).y = 300
NEXT
 
ExplosionsZ(0).x = 100: ExplosionsZ(1).x = 700
 
FOR i = 0 TO 20
    Bloods(i).img = SPRITENEW(blood_Sheet%, 1, SAVE)
    SPRITEANIMATESET Bloods(i).img, 1, 6
    explosions(i).img = SPRITENEW(explosion_Sheet%, 1, SAVE)
    SPRITEANIMATESET explosions(i).img, 1, 81
    Bloods(i).totalFrames = 6
    Bloods(i).n = 5
    explosions(i).totalFrames = 81
    explosions(i).n = 4
NEXT
MenuBlood% = SPRITENEW(blood_Sheet%, 1, SAVE)
SPRITEANIMATESET MenuBlood%, 1, 6
 
 
 
'Setup Notificaton stuff
ON TIMER(NEvent, .013) Notify
TIMER(NEvent) ON
 
_FONT Fonts.bigger
 
tmp& = _NEWIMAGE(400, 60, 32)
_DEST tmp&
_FONT Fonts.bigger
COLOR , _RGBA(0, 0, 0, 0)
_PRINTSTRING (CenterPrintX("Play"), 0), "Play"
_DEST 0
GameMenus(0).img = _COPYIMAGE(tmp&, 33)
GameMenus(0).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(0).y = 150
 
tmp& = _NEWIMAGE(400, 60, 32)
_DEST tmp&
_FONT Fonts.bigger
COLOR , _RGBA(0, 0, 0, 0)
_PRINTSTRING (CenterPrintX("Options"), 0), "Options"
_DEST 0
GameMenus(1).img = _COPYIMAGE(tmp&, 33)
GameMenus(1).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(1).y = GameMenus(0).y + 60
 
tmp& = _NEWIMAGE(400, 60, 32)
_DEST tmp&
_FONT Fonts.bigger
COLOR , _RGBA(0, 0, 0, 0)
_PRINTSTRING (CenterPrintX("Help"), 0), "Help"
_DEST 0
GameMenus(2).img = _COPYIMAGE(tmp&, 33)
GameMenus(2).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(2).y = GameMenus(1).y + 60
 
tmp& = _NEWIMAGE(400, 60, 32)
_DEST tmp&
_FONT Fonts.bigger
COLOR , _RGBA(0, 0, 0, 0)
_PRINTSTRING (CenterPrintX("Credits"), 0), "Credits"
_DEST 0
GameMenus(3).img = _COPYIMAGE(tmp&, 33)
GameMenus(3).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(3).y = GameMenus(2).y + 60
 
tmp& = _NEWIMAGE(400, 60, 32)
_DEST tmp&
_FONT Fonts.bigger
COLOR , _RGBA(0, 0, 0, 0)
_PRINTSTRING (CenterPrintX("Exit"), 0), "Exit"
_DEST 0
GameMenus(4).img = _COPYIMAGE(tmp&, 33)
GameMenus(4).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(4).y = GameMenus(3).y + 60
 
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "Fullscreen"
_DEST 0
GameMenus(5).img = _COPYIMAGE(tmp&, 33)
GameMenus(5).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(5).y = 113
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "Fullscreen Method "
_DEST 0
GameMenus(6).img = _COPYIMAGE(tmp&, 33)
GameMenus(6).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(6).y = GameMenus(5).y + 34
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "Music "
_DEST 0
GameMenus(7).img = _COPYIMAGE(tmp&, 33)
GameMenus(7).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(7).y = GameMenus(6).y + 34
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "SFX "
_DEST 0
GameMenus(8).img = _COPYIMAGE(tmp&, 33)
GameMenus(8).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(8).y = GameMenus(7).y + 34
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "Music Volume "
_DEST 0
GameMenus(9).img = _COPYIMAGE(tmp&, 33)
GameMenus(9).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(9).y = GameMenus(8).y + 34
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "SFX Volume"
_DEST 0
GameMenus(10).img = _COPYIMAGE(tmp&, 33)
GameMenus(10).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(10).y = GameMenus(9).y + 34
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "3D Sound Effect"
_DEST 0
GameMenus(11).img = _COPYIMAGE(tmp&, 33)
GameMenus(11).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(11).y = GameMenus(10).y + 34
 
tmp& = _NEWIMAGE(400, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "Frame Rate "
_DEST 0
GameMenus(12).img = _COPYIMAGE(tmp&, 33)
GameMenus(12).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(12).y = GameMenus(11).y + 34
 
tmp& = _NEWIMAGE(500, 30, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (CenterPrintX("Default Settings"), 0), "Default Settings"
_DEST 0
GameMenus(13).img = _COPYIMAGE(tmp&, 33)
GameMenus(13).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(13).y = GameMenus(12).y + 34
 
tmp& = _NEWIMAGE(500, 200, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (CenterPrintX("Apply Settings"), 0), "Apply Settings"
_DEST 0
GameMenus(14).img = _COPYIMAGE(tmp&, 33)
GameMenus(14).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(14).y = GameMenus(13).y + 34
 
tmp& = _NEWIMAGE(500, 200, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (CenterPrintX("Go Back To Main Menu"), 0), "Go Back To Main Menu"
_DEST 0
GameMenus(15).img = _COPYIMAGE(tmp&, 33)
GameMenus(15).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(15).y = GameMenus(14).y + 34
 
tmp& = _NEWIMAGE(500, 200, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "Fullscreen"
_DEST 0
GameMenus(16).img = _COPYIMAGE(tmp&, 33)
GameMenus(16).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(16).y = 232
 
tmp& = _NEWIMAGE(500, 200, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "Music Volume"
_DEST 0
GameMenus(17).img = _COPYIMAGE(tmp&, 33)
GameMenus(17).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(17).y = GameMenus(16).y + 34
 
tmp& = _NEWIMAGE(500, 200, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (20, 0), "SFX Volume"
_DEST 0
GameMenus(18).img = _COPYIMAGE(tmp&, 33)
GameMenus(18).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(18).y = GameMenus(17).y + 34
 
tmp& = _NEWIMAGE(500, 200, 32)
_DEST tmp&
COLOR , _RGBA(0, 0, 0, 0)
_FONT Fonts.normal
_PRINTSTRING (CenterPrintX("Exit to Main Menu"), 0), "Exit to Main Menu"
_DEST 0
GameMenus(19).img = _COPYIMAGE(tmp&, 33)
GameMenus(19).img2 = _COPYIMAGE(tmp&, 32)
_FREEIMAGE tmp&
GameMenus(19).y = GameMenus(18).y + 34
 
 
 
 
 
 
LoaderEnd
 
start:
 
COLOR _RGB(255, 255, 255), _RGBA(0, 0, 0, 0)
 
' echo COMMAND$(1)
' echo COMMAND$(2)
' IF COMMAND$(1) = "-loadlevel" AND VAL(COMMAND$(2)) > 0 THEN
' LevelStage% = VAL(COMMAND$(2))
' LevelStage2% = LevelStage%
' GOTO newgame
' END IF
 
GameMenu
 
 
 
 
IF MenuChoice = 1 THEN MenuChoice = 0: GOTO newgame
IF MenuChoice = 2 THEN
    MenuChoice = 0
 
    'save current settings in dummy variable :P
    DIM preConfig AS Settings
    preConfig = W ' W is a global variable which stored all game settings
 
    DIM on_switch&, off_switch&, bd&, cj&, gfx&, ac& 'images surface
    on_switch& = _LOADIMAGE("Images/on.png", 33)
    off_switch& = _LOADIMAGE("Images/off.png", 33)
    FOR i = 0 TO 4
        _PUTIMAGE (200, GameMenus(i).y), GameMenus(i).img2
    NEXT
 
    bd& = _COPYIMAGE(0)
    cj& = _COPYIMAGE(bd&)
 
    BLURIMAGE cj&, 5
    gfx& = _NEWIMAGE(500, 340, 32)
    _DEST gfx&
    CLS , 0 'make it transparent
    LINE (0, 0)-STEP(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, 150), BF
    FOR i = 5 TO 14
        _PUTIMAGE (0, GameMenus(i).y - 103), GameMenus(i).img2
    NEXT
 
    _DEST 0
 
    FOR i = 0 TO 255 STEP 10
        _SETALPHA i, , cj&
        _PUTIMAGE , bd&
        _PUTIMAGE , cj&
        LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i / 3), BF
        _PUTIMAGE (150, 103), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 340))
        _DISPLAY
    NEXT
    ac& = _COPYIMAGE(cj&)
    _DEST ac&
    LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, 85), BF
    _DEST 0
    DO
        WHILE _MOUSEINPUT: WEND
        Mouse.x = _MOUSEX: Mouse.y = _MOUSEY
        Mouse.lclick = 0
        Mouse.rclick = 0
        IF _MOUSEBUTTON(1) THEN
            WHILE _MOUSEBUTTON(1): WHILE _MOUSEINPUT: WEND: WEND
            Mouse.lclick = -1
        END IF
        IF _MOUSEBUTTON(2) THEN
            WHILE _MOUSEBUTTON(2): WHILE _MOUSEINPUT: WEND: WEND
            Mouse.rclick = -1
        END IF
        _PUTIMAGE , ac&
        LINE (150, 103)-STEP(500, 374), _RGBA(0, 0, 0, 150), BF
        FOR i = 5 TO 15
            IF Mouse.x > 150 AND Mouse.x < 650 AND Mouse.y > GameMenus(i).y - 10 AND Mouse.y < GameMenus(i).y + 24 THEN
                LINE (150, GameMenus(i).y - 10)-(650, GameMenus(i).y + 24), _RGBA(255, 100, 0, 100), BF
                IF Mouse.lclick THEN
                    SELECT CASE i
                        CASE 5
                            IF W.fullscreen > 0 THEN W.fullscreen = 0 ELSE W.fullscreen = 1
                        CASE 6
                            W.fullscreen = W.fullscreen + 1
                            IF W.fullscreen > 2 THEN W.fullscreen = 1
                        CASE 7
                            IF W.music THEN W.music = 0 ELSE W.music = -1
                        CASE 8
                            IF W.sfx THEN W.sfx = 0 ELSE W.sfx = -1
                        CASE 9
                            W.musicV = W.musicV + .1
                            IF W.musicV > 1.0 THEN W.musicV = .1
                        CASE 10
                            W.sfxV = W.sfxV + .1
                            IF W.sfxV > 1 THEN W.sfxV = 0.1
                        CASE 11
                            IF W.SE THEN W.SE = 0 ELSE W.SE = -1
                        CASE 12
                            W.fps = W.fps + 30
                            IF W.fps > 240 THEN W.fps = 30
                        CASE 13
                            W.fullscreen = 0
                            W.music = -1
                            W.sfx = -1
                            W.musicV = 1
                            W.sfxV = 1
                            W.SE = -1
                            W.fps = 30
                        CASE 14
                            writeConfig
                            loadComponents
                            showNotification "Settings have been applied."
                        CASE 15
                            EXIT DO
                    END SELECT
                END IF
            END IF
            _PUTIMAGE (150, GameMenus(i).y), GameMenus(i).img
            SELECT CASE i
                CASE 5
                    IF W.fullscreen > 0 THEN _PUTIMAGE (580, GameMenus(i).y - 3), on_switch& ELSE _PUTIMAGE (580, GameMenus(i).y - 3), off_switch&
                CASE 6
                    _FONT Fonts.normal
                    SELECT CASE W.fullscreen
                        CASE 1
                            _PRINTSTRING (630 - txtWidth("Stretch"), GameMenus(i).y), "Stretch"
                        CASE 2
                            _PRINTSTRING (630 - txtWidth("Square Pixels"), GameMenus(i).y), "Square Pixels"
                        CASE ELSE
                            _PRINTSTRING (630 - txtWidth("Disable"), GameMenus(i).y), "Disable"
                    END SELECT
                CASE 7
                    IF W.music THEN _PUTIMAGE (580, GameMenus(i).y - 3), on_switch& ELSE _PUTIMAGE (580, GameMenus(i).y - 3), off_switch&
                CASE 8
                    IF W.sfx THEN _PUTIMAGE (580, GameMenus(i).y - 3), on_switch& ELSE _PUTIMAGE (580, GameMenus(i).y - 3), off_switch&
                CASE 9
                    _FONT Fonts.normal
                    IF W.musicV > .9 THEN
                        _PRINTSTRING (630 - txtWidth(" 10"), GameMenus(i).y), " 10 "
                    ELSE
                        _PRINTSTRING (630 - txtWidth(STR$(INT(W.musicV * 10))), GameMenus(i).y), STR$(INT(W.musicV * 10))
                    END IF
                CASE 10
                    _FONT Fonts.normal
                    IF W.sfxV > .9 THEN
                        _PRINTSTRING (630 - txtWidth(" 10"), GameMenus(i).y), " 10 "
                    ELSE
                        _PRINTSTRING (630 - txtWidth(STR$(INT(W.sfxV * 10))), GameMenus(i).y), STR$(INT(W.sfxV * 10))
                    END IF
                CASE 11
                    IF W.SE THEN _PUTIMAGE (580, GameMenus(i).y - 3), on_switch& ELSE _PUTIMAGE (580, GameMenus(i).y - 3), off_switch&
                CASE 12
                    _FONT Fonts.normal
                    _PRINTSTRING (630 - txtWidth(STR$(W.fps)), GameMenus(i).y), STR$(W.fps)
            END SELECT
        NEXT
        _LIMIT W.fps
        IF Mouse.hovering THEN
            _PUTIMAGE (Mouse.x - 16, Mouse.y - 16), Mouse.cursor2
            _DISPLAY
        ELSE
            _PUTIMAGE (Mouse.x - 16, Mouse.y - 16), Mouse.cursor
            _DISPLAY
        END IF
 
    LOOP
    FOR i = 255 TO 0 STEP -10
        _SETALPHA i, , cj&
        _PUTIMAGE , bd&
        _PUTIMAGE , cj&
        LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i / 3), BF
        _PUTIMAGE (150, 103), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 340))
        _DISPLAY
    NEXT
    _FREEIMAGE bd&
    _FREEIMAGE cj&
    _FREEIMAGE ac&
    _FREEIMAGE gfx&
    _FREEIMAGE on_switch&
    _FREEIMAGE off_switch&
    GOTO start
END IF
IF MenuChoice = 3 THEN
    MenuChoice = 0
    FOR i = 0 TO 4
        _PUTIMAGE (200, GameMenus(i).y), GameMenus(i).img2
    NEXT
    bd& = _COPYIMAGE(0)
    cj& = _COPYIMAGE(bd&)
 
    BLURIMAGE cj&, 5
    DIM k&
    k& = _LOADIMAGE("Images\help.png")
 
    FOR i = 0 TO 255 STEP 10
        _SETALPHA i, , cj&
        _PUTIMAGE , bd&
        _PUTIMAGE , cj&
        _SETALPHA i / 1.25, , k&
        LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i / 5), BF
        centerImage k&
        _DISPLAY
    NEXT
 
    DO
        'mouse input
        WHILE _MOUSEINPUT: WEND
        Mouse.x = _MOUSEX: Mouse.y = _MOUSEY
 
        IF _MOUSEBUTTON(1) THEN
            WHILE _MOUSEBUTTON(1): WHILE _MOUSEINPUT: WEND: WEND
            Mouse.lclick = -1
        ELSE
            Mouse.lclick = 0
        END IF
 
        IF _MOUSEBUTTON(2) THEN
            WHILE _MOUSEBUTTON(2): WHILE _MOUSEINPUT: WEND: WEND
            Mouse.rclick = -1
        ELSE
            Mouse.rclick = 0
        END IF
 
        _LIMIT W.fps
 
        _DISPLAY
 
        IF Mouse.lclick OR Mouse.rclick OR _KEYHIT = 27 THEN EXIT DO
    LOOP
 
    FOR i = 255 TO 0 STEP -10
        _SETALPHA i, , cj&
        _PUTIMAGE , bd&
        _PUTIMAGE , cj&
        _SETALPHA i / 1.25, , k&
        LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i / 5), BF
        centerImage k&
        _DISPLAY
    NEXT
 
    _PUTIMAGE , bd&
    _FREEIMAGE bd&
    _FREEIMAGE cj&
    _FREEIMAGE k&
    GOTO start
 
END IF
 
IF MenuChoice = 4 THEN
    FOR i = 0 TO 4
        _PUTIMAGE (200, GameMenus(i).y), GameMenus(i).img2
    NEXT
 
    bd& = _COPYIMAGE(0)
 
    FOR i = 0 TO 255 STEP 5
        _PUTIMAGE , bd&
        LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i), BF
        _DISPLAY
    NEXT
 
    showCredits
 
    FOR i = 255 TO 0 STEP -5
        _PUTIMAGE , bd&
        LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i), BF
        _DISPLAY
    NEXT
 
    _FREEIMAGE bd&
    MenuChoice = 0
    GOTO start
 
END IF
 
IF MenuChoice = 5 THEN SYSTEM 1
MenuChoice = 0
END
newgame:
 
 
CLS
 
LoaderStart
SetupRain
IF COMMAND$(1) = "-loadlevel" THEN
    LoadLevel
ELSE
    IF getCurrentLevel > MAX_LEVEL THEN randomLevels = -1 ELSE randomLevels = 0: LoadLevel
END IF
 
 
_FONT Fonts.bigger
 
'################### Random Levels ################################
DIM F AS INTEGER
IF randomLevels THEN
    Level.completed = 0
    Level.over = 0
    LevelStage% = p5random(1, MAX_LEVEL)
    F = FREEFILE
    'LevelStage% = VAL(COMMAND$(2))
    OPEN "stages/stage" + RTRIM$(LTRIM$(STR$(LevelStage%))) + ".dat" FOR INPUT AS #F
    INPUT #F, Level.enemies
    INPUT #F, Level.scenes
    INPUT #F, Seconds%
    INPUT #F, Level.mode
    INPUT #F, Level.background
    CLOSE #F
    Level.bg = _LOADIMAGE("Images\" + RTRIM$(Level.background))
    OldSeconds% = Seconds%
END IF
 
IF randomLevels THEN _PRINTSTRING (CenterPrintX("Random Levels"), 300), "Random Levels" ELSE _PRINTSTRING (CenterPrintX("Stage " + LTRIM$(RTRIM$(STR$(LevelStage%)))), 300), "Stage " + LTRIM$(RTRIM$(STR$(LevelStage%)))
 
_DELAY RND * 3
 
' if randomLevels then LoaderEnd : goto game_rendering_begin
' _DELAY 0.5
 
 
'############################# Custom Levels #############################
 
ERASE Enemie 'clear all previous enemie data
 
REDIM SHARED Enemie(Level.enemies) AS Enemies
 
'Enemie Configuirations
 
F = FREEFILE
Level.completed = 0
Level.over = 0
Level.cancel = 0
CurrentScore% = 0
Level.u = 0
Level.currentScene = 1
 
OPEN "Stages\Stage" + LTRIM$(RTRIM$(STR$(LevelStage%))) + ".lvl" FOR INPUT AS #F
 
FOR i = 1 TO Level.enemies
    INPUT #F, Enemie(i).typ
 
    SELECT CASE RTRIM$(Enemie(i).typ)
 
        CASE "bird"
            Enemie(i).img = SPRITENEW(Bird_Sheet%, 1, SAVE)
            SPRITEANIMATESET Enemie(i).img, 1, 14
            SPRITEZOOM Enemie(i).img, 50
            Enemie(i).n = 6
            Enemie(i).points = 10
            Enemie(i).life = 4
            Enemie(i).life2 = Enemie(i).life
            Enemie(i).snd = _SNDCOPY(Bird&)
        CASE "crow"
            Enemie(i).img = SPRITENEW(Crow_Sheet%, 1, SAVE)
            SPRITEANIMATESET Enemie(i).img, 1, 4
            SPRITEZOOM Enemie(i).img, 70
            Enemie(i).n = 12
            Enemie(i).points = 20
            Enemie(i).life = 7
            Enemie(i).life2 = Enemie(i).life
            Enemie(i).snd = _SNDCOPY(Crow&)
        CASE "eagle"
            Enemie(i).img = SPRITENEW(eagle_Sheet%, 7, SAVE)
            SPRITEANIMATESET Enemie(i).img, 7, 9
            Enemie(i).n = 12
            Enemie(i).points = 35
            Enemie(i).life = 14
            Enemie(i).life2 = Enemie(i).life
            Enemie(i).snd = _SNDCOPY(Eagle&)
        CASE "jet1"
            Enemie(i).img = SPRITENEW(Jet1_Sheet%, 1, SAVE)
            SPRITEANIMATESET Enemie(i).img, 1, 3
            SPRITEZOOM Enemie(i).img, 70
            Enemie(i).n = 10
            Enemie(i).points = 50
            Enemie(i).life = 30
            Enemie(i).life2 = Enemie(i).life
            Enemie(i).snd = _SNDCOPY(Jet&)
        CASE "jet2"
            Enemie(i).img = SPRITENEW(Jet2_Sheet%, 1, SAVE)
            SPRITEANIMATESET Enemie(i).img, 1, 3
            SPRITEZOOM Enemie(i).img, 70
            Enemie(i).n = 10
            Enemie(i).points = 75
            Enemie(i).life = 45
            Enemie(i).life2 = Enemie(i).life
            Enemie(i).snd = _SNDCOPY(Jet&)
        CASE "jet3"
            Enemie(i).img = SPRITENEW(Jet3_Sheet%, 1, SAVE)
            SPRITEANIMATESET Enemie(i).img, 1, 3
            SPRITEZOOM Enemie(i).img, 70
            Enemie(i).n = 10
            Enemie(i).points = 100
            Enemie(i).life = 70
            Enemie(i).life2 = Enemie(i).life
            Enemie(i).snd = _SNDCOPY(Jet&)
    END SELECT
    INPUT #F, Enemie(i).u
    INPUT #F, Enemie(i).y
    INPUT #F, Enemie(i).m
    IF Enemie(i).m < 0 THEN Enemie(i).x = _WIDTH: SPRITEFLIP Enemie(i).img, HORIZONTAL ELSE Enemie(i).x = 0
 
    INPUT #F, Enemie(i).scene
NEXT
 
CLOSE #F
 
LoaderEnd
 
game_rendering_begin:::
 
_PUTIMAGE (0, 0)-(_WIDTH, _HEIGHT), Level.bg
_PUTIMAGE (0, 520), ScoreBoard&
_PUTIMAGE (50, 550)-(170, 590), GunImg&(Gun.id - 1)
_FONT Fonts.smaller
_PRINTSTRING (40, 580), RTRIM$(Gun.name)
_FONT Fonts.normal
 
IF randomLevels THEN _PRINTSTRING (CenterPrintX("Random Levels"), 560), "Random Levels" ELSE _PRINTSTRING (CenterPrintX("Stage " + STR$(LevelStage%)), 560), "Stage " + STR$(LevelStage%)
_FONT Fonts.smaller
 
Minutes% = (Seconds% - (Seconds% MOD 60)) / 60
DIM t AS INTEGER
t = Seconds% MOD 60
 
_PRINTSTRING (600, 560), "Score - " + STR$(CurrentScore%)
_PRINTSTRING (600, 580), "Time Left -" + STR$(Minutes%) + ":" + STR$(t)
StartLevel
 
FOR i = 1 TO Level.enemies 'free all the sound buffer stream (sound stream will reload again when next gameplay starts.
    _SNDCLOSE Enemie(i).snd
NEXT
 
COLOR _RGB(255, 255, 255), _RGBA(0, 0, 0, 0)
'checking if the level has benn canceled by the user.
IF Level.cancel THEN
    'free the level background image
    _FREEIMAGE Level.bg
    Level.cancel = 0
    GOTO start
END IF
 
'checking if game is completed
 
IF Level.completed THEN
    ' IF COMMAND$(1) = "-loadlevel" THEN
    ' echo "Level : " + STR$(LevelStage%)
    ' echo "Time taken to complete : " + STR$(Level.time - Seconds%)
    ' END IF
 
    _PUTIMAGE (0, 0)-(_WIDTH, _HEIGHT), Level.bg
 
    'crosfading start here -
    DIM blured&
 
    blured& = _COPYIMAGE(Level.bg)
    BLURIMAGE blured&, 5
    FOR i = 1 TO 255 STEP 20
        _SETALPHA i, , blured&
        _PUTIMAGE , Level.bg
        _PUTIMAGE , blured&
        _DISPLAY
    NEXT
 
    _FREEIMAGE blured&
 
    LINE (200, 200)-(_WIDTH - 200, _HEIGHT - 200), _RGBA(0, 0, 0, 180), BF
    _FONT Fonts.normal
    _PRINTSTRING (CenterPrintX("Stage " + STR$(LevelStage%) + "Completed!"), 210), "Stage " + STR$(LevelStage%) + " Completed"
    _FONT Fonts.smaller
    DIM a$
    a$ = "Congratulations!! You created new high score!"
 
    IF CurrentScore% > HighScore% THEN _PRINTSTRING (CenterPrintX(a$), 250), a$
 
    _PRINTSTRING (CenterPrintX("Score - " + STR$(CurrentScore%)), 300), "Score - " + STR$(CurrentScore%)
    _PRINTSTRING (CenterPrintX("Bonus Score - " + STR$(Seconds% * 2)), 320), "Bonus Score - " + STR$(Seconds% * 2)
    _PRINTSTRING (CenterPrintX("Total Score - " + STR$(Seconds% * 2 + CurrentScore%)), 340), "Total Score - " + STR$(Seconds% * 2 + CurrentScore%)
 
    IF LevelStage% = MAX_LEVEL THEN a$ = "Game Completed" ELSE a$ = "Be ready for next stage. Wait a moment..."
    _PRINTSTRING (CenterPrintX(a$), 380), a$
 
    DO
        IF F = 1 THEN SPRITESHOW ExplosionsZ(0).img: SPRITESHOW ExplosionsZ(1).img
        FOR i = 0 TO 1
            SPRITENEXT ExplosionsZ(i).img
            SPRITEPUT ExplosionsZ(i).x, ExplosionsZ(i).y, ExplosionsZ(i).img
        NEXT
        _LIMIT W.fps
        _DISPLAY
        F = F + 1
    LOOP UNTIL F > 180
    SPRITEHIDE ExplosionsZ(0).img
    SPRITEHIDE ExplosionsZ(1).img
    
    F = 0
    IF COMMAND$(1) = "-loadlevel" THEN SYSTEM
    SaveGame
 
    IF LevelStage% > MAX_LEVEL THEN
        bd& = _COPYIMAGE(0)
        FOR i = 0 TO 255 STEP 5
            _PUTIMAGE , bd&
            LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i), BF
            _DISPLAY
        NEXT
        showCredits
 
        GOTO start
    END IF
    'free the level background image
    _FREEIMAGE Level.bg
 
    GOTO newgame
END IF
IF Level.over THEN
    COLOR _RGB(255, 0, 0)
    ' IF COMMAND$(1) = "-loadlevel" THEN
    ' echo "Level failed to compete"
    ' END IF
 
    _PUTIMAGE (0, 0)-(_WIDTH, _HEIGHT), Level.bg
    'crosfading start here -
    blured& = _COPYIMAGE(Level.bg)
    BLURIMAGE blured&, 5
    FOR i = 1 TO 255 STEP 20
        _SETALPHA i, , blured&
        _PUTIMAGE , Level.bg
        _PUTIMAGE , blured&
        _DISPLAY
    NEXT
 
    _FREEIMAGE blured&
    LINE (200, 250)-(_WIDTH - 200, _HEIGHT - 250), _RGBA(0, 0, 0, 180), BF
    _FONT Fonts.bigger
    _PRINTSTRING (CenterPrintX("Game Over"), 260), "Game Over"
    _FONT Fonts.smaller
    _PRINTSTRING (CenterPrintX("Click To Continue..."), _HEIGHT - 280), "Click to Continue..."
    _DISPLAY
 
    DO
        WHILE _MOUSEINPUT: WEND
        IF _MOUSEBUTTON(1) THEN
            WHILE _MOUSEBUTTON(1): WHILE _MOUSEINPUT: WEND: WEND
            EXIT DO
        END IF
        _LIMIT 30
    LOOP
    GOTO start
    'free the level background image
    _FREEIMAGE Level.bg
 
END IF
 
404
_MOUSESHOW
_FONT 16
CLS
COLOR _RGB(255, 255, 255)
CIRCLE (_WIDTH / 2, 200), 100
CIRCLE (_WIDTH / 2 - 50, 150), 5
CIRCLE (_WIDTH / 2 + 50, 150), 5
CIRCLE (_WIDTH / 2, 250), 50, , 0, _PI
 
centerPrint "An Error has ocurred!", 350
centerPrint "Error Code - " + STR$(ERR), 366
IF _INCLERRORFILE$ <> "" THEN
    centerPrint "Error File - " + _INCLERRORFILE$, 382
    centerPrint "Error Line - " + STR$(_INCLERRORLINE), 398
ELSE
    centerPrint "Error File - Main_File", 382
    centerPrint "Error Line - " + STR$(_ERRORLINE), 398
END IF
END
 
 
 
 
 
 
 
SUB echo (m$) 'always write to console
    DIM preDest AS LONG
    preDest = _DEST
    _DEST _CONSOLE
    PRINT m$
    _DEST preDest
END SUB
 
SUB showNotification (message$)
    NText$ = message$
    NShow = -1
END SUB
 
SUB Notify ()
    STATIC imgy
    IF NShow = -1 THEN
        IF NFPSCount% = 0 THEN
            _FONT 16
            DIM __w AS INTEGER, h AS INTEGER, tmp&, preDest AS LONG
            __w = LEN(NText$) * 8 + 40
            h = 36
 
            tmp& = _NEWIMAGE(__w, h, 32)
 
            preDest = _DEST
            _DEST tmp&
 
            COLOR _RGB(10, 10, 10), _RGB(355, 245, 245)
            CLS , _RGB(255, 245, 245)
            _PRINTSTRING (20, 10), NText$
 
            _DEST preDest
            NImage& = _COPYIMAGE(tmp&, 33)
            _FREEIMAGE tmp&
 
            imgy = -40
        END IF
        IF NFPSCount% > 0 AND NFPSCount% < 40 THEN
            imgy = imgy + 1
            _PUTIMAGE (_WIDTH / 2 - _WIDTH(NImage&) / 2, imgy), NImage&
        END IF
        IF NFPSCount% > 40 AND NFPSCount% < 160 THEN
            _PUTIMAGE (_WIDTH / 2 - _WIDTH(NImage&) / 2, imgy), NImage&
        END IF
        IF NFPSCount% > 160 AND NFPSCount% < 200 THEN
            _PUTIMAGE (_WIDTH / 2 - _WIDTH(NImage&) / 2, imgy), NImage&
            imgy = imgy - 1
        END IF
        NFPSCount% = NFPSCount% + 1
        IF NFPSCount% > 200 THEN
            _FREEIMAGE NImage&
            NFPSCount% = 0
            NShow = 0
        END IF
    END IF
END SUB
 
 
SUB readConfig ()
    DIM F AS INTEGER
 
    IF NOT _FILEEXISTS("Settings/settings.dat") THEN writeConfig
    F = FREEFILE
    OPEN "Settings/settings.dat" FOR INPUT AS #F
    INPUT #F, W.fullscreen
    INPUT #F, W.music
    INPUT #F, W.sfx
    INPUT #F, W.musicV
    INPUT #F, W.sfxV
    INPUT #F, W.SE
    INPUT #F, W.fps
    CLOSE #F
END SUB
 
SUB writeConfig ()
    DIM f AS INTEGER
 
    f = FREEFILE
    OPEN "Settings/settings.dat" FOR OUTPUT AS #f
    PRINT #f, W.fullscreen
    PRINT #f, W.music
    PRINT #f, W.sfx
    PRINT #f, W.musicV
    PRINT #f, W.sfxV
    PRINT #f, W.SE
    PRINT #f, W.fps
    CLOSE #f
END SUB
 
SUB createConfig ()
    W.fullscreen = 0
    W.music = -1
    W.sfx = -1
    W.musicV = 1
    W.sfxV = 1
    W.SE = -1
    W.fps = 90
    writeConfig
END SUB
 
SUB loadComponents ()
    IF W.fullscreen = 0 THEN
        IF _FULLSCREEN <> 0 THEN _FULLSCREEN _OFF
    ELSEIF W.fullscreen = 1 THEN
        IF _FULLSCREEN <> 1 THEN _FULLSCREEN _STRETCH , _SMOOTH
    ELSEIF W.fullscreen = 2 THEN
        IF _FULLSCREEN <> 2 THEN _FULLSCREEN _SQUAREPIXELS , _SMOOTH
    END IF
 
    'SFXs
    ' screen_conf:
    IF Gun1& = 0 THEN Gun1& = _SNDOPEN("SFX/Gun1.ogg", "sync,vol,pause")
    IF Gun2& = 0 THEN Gun2& = _SNDOPEN("SFX/Gun2.ogg", "sync,vol,pause")
    IF Bird& = 0 THEN Bird& = _SNDOPEN("SFX/bird.ogg", "sync,vol,pause")
    IF Crow& = 0 THEN Crow& = _SNDOPEN("SFX/Crow.ogg", "sync,vol,pause")
    IF Eagle& = 0 THEN Eagle& = _SNDOPEN("SFX/Eagle.ogg", "sync,vol,pause")
    IF Expos& = 0 THEN Expos& = _SNDOPEN("SFX/Explosion.mp3", "sync,vol,pause")
    IF Jet& = 0 THEN Jet& = _SNDOPEN("SFX/Jet.ogg", "sync,vol,pause")
    IF RainSound& = 0 THEN RainSound& = _SNDOPEN("SFX/Rain.mp3", "vol,sync,pause")
 
    IF Musics&(0) = 0 THEN Musics&(0) = _SNDOPEN("Musics/Hunter's_Revenge-Against_Evil.mp3", "sync,vol,pause")
    IF Musics&(1) = 0 THEN Musics&(1) = _SNDOPEN("Musics/Hunter's_Revenge-End_Of_Game.mp3", "sync,vol,pause")
    IF Musics&(2) = 0 THEN Musics&(2) = _SNDOPEN("Musics/Hunter's_Revenge-Who's_Next.mp3", "sync,vol,pause")
 
    setMusicVol W.musicV
    IF NOT W.music THEN 'if menu background music disable, then stop the musics, regardless of whether the are being played or not.
        _SNDSTOP Musics&(0)
        _SNDSTOP Musics&(1)
        _SNDSTOP Musics&(2)
    END IF
 
    W.done = -1
END SUB
 
SUB Splash ()
 
    CLS
 
    DIM stars&, x AS INTEGER, y AS INTEGER, F AS INTEGER
 
    stars& = _NEWIMAGE(_WIDTH * 2, _HEIGHT, 32)
    _DEST stars&
    DO
        x = INT(RND * _WIDTH(stars&))
        y = INT(RND * _HEIGHT)
        PSET (x, y), _RGB(255, 255, 255)
        F = F + 1
    LOOP UNTIL F > 700
 
    DIM spT&, sp&, eft1&, p AS INTEGER, a AS INTEGER, xx AS INTEGER
 
    _DEST 0
    spT& = _LOADIMAGE("Images\splash.png")
    _CLEARCOLOR _RGB(0, 0, 0), spT&
    sp& = _COPYIMAGE(spT&, 33)
    F = 0
    eft1& = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
    _DEST eft1&
    LINE (0, 0)-(_WIDTH, _HEIGHT), _RGB(0, 0, 50), BF
    _DEST 0
 
    p = 6
    FPSStart
    DO
        _SETALPHA a, , eft1&: _PUTIMAGE , eft1&
        _PUTIMAGE (xx, 0), stars&
        _PUTIMAGE , sp&
        xx = xx - 1
        IF xx < -_WIDTH - 2 THEN xx = 0
        _LIMIT 60
        a = a + p
        IF a > 250 THEN p = -p
        IF a < 6 THEN p = 6
        _DISPLAY
        F% = F% + 1
        FPSCurrent% = FPSCurrent% + 1
    LOOP UNTIL F% > 360
 
    FPSEnd
    CLS
 
    _FREEIMAGE sp&
    _FREEIMAGE spT&
    _FREEIMAGE eft1&
    _FREEIMAGE stars&
END SUB
 
SUB FPSStart ()
    ON TIMER(FPSEvent, 1) FPS
    ON TIMER(FPSEvt, 0.01) FPSShow
    TIMER(FPSEvent) ON
    TIMER(FPSEvt) ON
END SUB
 
SUB FPS ()
    FPSRate% = FPSCurrent%
    FPSCurrent% = 0
END SUB
 
SUB FPSShow ()
    COLOR _RGB(255, 255, 255)
    _PRINTSTRING (720, 0), STR$(FPSRate%) + " FPS"
END SUB
 
SUB FPSEnd ()
    TIMER(FPSEvent) OFF
    TIMER(FPSEvt) OFF
END SUB
 
SUB LoaderStart ()
    Loader& = _LOADIMAGE("Images\loader.gif", 33)
    LoaderEvt! = _FREETIMER
    ON TIMER(LoaderEvt!, 0.1) ShowLoader
    TIMER(LoaderEvt!) ON
END SUB
 
SUB LoaderEnd ()
    TIMER(LoaderEvt!) OFF
    _FREEIMAGE Loader&
END SUB
 
SUB ShowLoader ()
    IF LoaderCF% = 0 THEN LoaderCF% = 1
    _PUTIMAGE (LoaderX%, LoaderY%), Loader&, 0, (LoaderCF% * 48 - 48, 0)-(LoaderCF% * 48 - 1, 48)
    LoaderCF% = LoaderCF% + 1
    IF LoaderCF% > 8 THEN LoaderCF% = 1
    _DISPLAY
END SUB
 
' SUB PlayMovie (m$)
' LoaderStart
 
' DIM f AS INTEGER, n AS LONG, i AS LONG, k AS INTEGER
 
' f = FREEFILE
' OPEN "Movies\" + m$ + "\" + m$ + ".txt" FOR INPUT AS #f
' INPUT #f, n
' CLOSE #f
' DIM Temps_Buffers&(n)
' FOR i = 1 TO n
' Temps_Buffers&(i) = _LOADIMAGE("Movies\" + m$ + "\produce" + LTRIM$(RTRIM$(STR$(i))) + ".jpg", 33)
' NEXT
' LoaderEnd
' FOR i = 1 TO n
' FOR k = 1 TO 3
' _PUTIMAGE , Temps_Buffers&(i)
' _DISPLAY
' NEXT
' _DELAY .05
' _FREEIMAGE Temps_Buffers&(i)
' NEXT
' ERASE Temps_Buffers&
' END SUB
 
SUB GameMenu ()
    _PUTIMAGE , Menubg&
    DIM n%
    'Menu background music
    IF W.music THEN
        n% = p5random(0, 2)
        IF NOT (_SNDPLAYING(Musics&(0)) OR _SNDPLAYING(Musics&(1)) OR _SNDPLAYING(Musics&(2))) THEN _SNDPLAY Musics&(n%)
    END IF
 
    ON TIMER(GlobalEvent, 0.01) GameMenu2
    TIMER(GlobalEvent) ON
    DO
        WHILE _MOUSEINPUT: WEND
        Mouse.x = _MOUSEX: Mouse.y = _MOUSEY
        Mouse.lclick = _MOUSEBUTTON(1)
        _LIMIT W.fps
        IF MenuChoice > 0 THEN EXIT DO
    LOOP
    TIMER(GlobalEvent) OFF
END SUB
 
SUB GameMenu2 ()
    IF _SCREENICON THEN EXIT SUB
 
    _PUTIMAGE , Menubg&
    LINE (200, 130)-(_WIDTH - 200, 450), _RGBA(0, 0, 0, 150), BF
 
    DIM i AS INTEGER
 
    FOR i = 0 TO 4
        COLOR _RGB(255, 255, 255), _RGBA(0, 0, 0, 0)
        IF Mouse.x > 200 AND Mouse.x < 600 AND Mouse.y > GameMenus(i).y - 20 AND Mouse.y < GameMenus(i).y + _FONTHEIGHT(Fonts.bigger) THEN
            LINE (200, GameMenus(i).y - 20)-(600, GameMenus(i).y + _FONTHEIGHT(Fonts.bigger)), _RGBA(255, 100, 0, 100), BF
            SPRITEPUT 150, GameMenus(i).y + 20, MenuBlood%
            SPRITENEXT MenuBlood%
            '       _PRINTSTRING (GameMenus(i).x, GameMenus(i).y), RTRIM$(GameMenus(i).text)
            _PUTIMAGE (200, GameMenus(i).y), GameMenus(i).img
            IF Mouse.lclick THEN
                TIMER(GlobalEvent!) OFF
                SELECT CASE i
                    CASE 0
                        MenuChoice = 1
                    CASE 1
                        MenuChoice = 2
                    CASE 2
                        MenuChoice = 3
                    CASE 3
                        MenuChoice = 4
                    CASE 4
                        MenuChoice = 5
 
                END SELECT
            END IF
        ELSE
            '      _PRINTSTRING (GameMenus(i).x, GameMenus(i).y), RTRIM$(GameMenus(i).text)
            _PUTIMAGE (200, GameMenus(i).y), GameMenus(i).img
        END IF
    NEXT
    IF Mouse.hovering THEN
        _PUTIMAGE (Mouse.x - 16, Mouse.y - 16), Mouse.cursor2
        _DISPLAY
    ELSE
        _PUTIMAGE (Mouse.x - 16, Mouse.y - 16), Mouse.cursor
        _DISPLAY
    END IF
 
END SUB
 
 
FUNCTION CenterPrintX (m$)
    DIM i AS INTEGER, a AS INTEGER
    FOR i = 1 TO LEN(m$)
        a = a + _PRINTWIDTH(MID$(m$, i, 1))
    NEXT
    CenterPrintX = (_WIDTH / 2) - (a / 2)
END FUNCTION
 
FUNCTION getCurrentLevel% ()
    IF NOT _FILEEXISTS("Save_Game/save.dat") THEN getCurrentLevel% = 1: EXIT FUNCTION
    DIM F AS INTEGER
    F = FREEFILE
    OPEN "Save_Game\save.dat" FOR BINARY AS #F
    SEEK F, 3
    GET #F, , getCurrentLevel%
    CLOSE #F
END FUNCTION
 
SUB LoadLevel ()
    Level.completed = 0
    Level.over = 0
    DIM F AS INTEGER
    F = FREEFILE
    ' IF COMMAND$(1) = "-loadlevel" THEN
    ' GOTO skip_game_save_info
    ' END IF
    IF NOT _FILEEXISTS("Save_Game\save.dat") THEN
        OPEN "Save_Game\save.dat" FOR BINARY AS #F
        LevelStage% = 1
        HighScore% = 0
        PUT #F, , HighScore%
        PUT #F, , LevelStage%
        CLOSE #F
    ELSE
        OPEN "Save_Game\save.dat" FOR BINARY AS #F
        GET #F, , HighScore%
        GET #F, , LevelStage%
        CLOSE #F
    END IF
    skip_game_save_info:::
    ' echo "loading level/stage : " + STR$(LevelStage%)
    OPEN "Stages\Stage" + RTRIM$(LTRIM$(STR$(LevelStage%))) + ".dat" FOR INPUT AS #F
    INPUT #F, Level.enemies
    INPUT #F, Level.scenes
    INPUT #F, Level.time
    INPUT #F, Level.mode
    INPUT #F, Level.background
    CLOSE #F
    LevelStage2% = LevelStage%
    Level.bg = _LOADIMAGE("Images\" + RTRIM$(Level.background))
    Seconds% = Level.time
    OldSeconds% = Seconds%
    'LevelStage% = clevel%
END SUB
 
SUB StartLevel ()
 
    'Stop music during gameplay
    DIM i AS INTEGER, k&, onn&, offf&, bd&, bd2&, ac&, gfx&
    IF W.music THEN
        FOR i = 0 TO 2
            _SNDSTOP Musics&(i)
        NEXT 'stops all musics
    END IF
    IF W.sfx THEN updateSfxVolume
 
    ON TIMER(GameRenderingEvent, 1 / W.fps) UpdateStatus
    ON TIMER(TimerEvent, 1) UpdateTime
    TIMER(GameRenderingEvent) ON
    TIMER(TimerEvent) ON
    Mouse.lclick = 0
    Mouse.rclick = 0
    Mouse.mclick = 0
    DO
        WHILE _MOUSEINPUT: WEND
 
        Mouse.x = _MOUSEX: Mouse.y = _MOUSEY
        IF _MOUSEBUTTON(1) THEN
            WHILE _MOUSEBUTTON(1): WHILE _MOUSEINPUT: WEND: WEND
            Mouse.lclick = -1
        END IF
        IF _MOUSEBUTTON(2) THEN
            WHILE _MOUSEBUTTON(2): WHILE _MOUSEINPUT: WEND: WEND
            Mouse.rclick = -1
        END IF
        IF _MOUSEBUTTON(3) THEN
            WHILE _MOUSEBUTTON(3): WHILE _MOUSEINPUT: WEND: WEND
            Mouse.mclick = -1
        ELSE Mouse.mclick = 0
        END IF
 
        k& = _KEYHIT
        IF k& = 27 OR Mouse.mclick THEN
            TIMER(GameRenderingEvent) OFF
            TIMER(TimerEvent) OFF
            IF W.sfx THEN PauseSound 'Pause the sounds
 
            onn& = _LOADIMAGE("Images/on.png", 33)
            offf& = _LOADIMAGE("Images/off.png", 33)
 
            bd& = _COPYIMAGE(0)
            bd2& = _COPYIMAGE(0)
 
            BLURIMAGE bd2&, 5
            gfx& = _NEWIMAGE(500, 156, 32)
            _DEST gfx&
            CLS , 0 'make it transparent
            LINE (0, 0)-STEP(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, 150), BF
            FOR i = 16 TO 19
                _PUTIMAGE (0, GameMenus(i).y - 222), GameMenus(i).img2
            NEXT
            _DEST 0
 
            FOR i = 0 TO 255 STEP 10
                _SETALPHA i, , bd2&
                _PUTIMAGE , bd&
                _PUTIMAGE , bd2&
                LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i / 3), BF
                _PUTIMAGE (150, 222), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 136))
                _DISPLAY
            NEXT
            ac& = _COPYIMAGE(0)
            DO
                WHILE _MOUSEINPUT: WEND
                Mouse.x = _MOUSEX: Mouse.y = _MOUSEY
                Mouse.lclick = 0
                Mouse.rclick = 0
                IF _MOUSEBUTTON(1) THEN
                    WHILE _MOUSEBUTTON(1): WHILE _MOUSEINPUT: WEND: WEND
                    Mouse.lclick = -1
                END IF
                IF _MOUSEBUTTON(2) THEN
                    WHILE _MOUSEBUTTON(2): WHILE _MOUSEINPUT: WEND: WEND
                    Mouse.rclick = -1
                END IF
 
                _PUTIMAGE , ac&
                LINE (150, 222)-STEP(500, 136), _RGBA(0, 0, 0, 50), BF
                FOR i = 16 TO 19
                    IF Mouse.x > 150 AND Mouse.x < 650 AND Mouse.y > GameMenus(i).y - 10 AND Mouse.y < GameMenus(i).y + 24 THEN
                        IF Mouse.lclick THEN
                            SELECT CASE i
                                CASE 16
                                    IF W.fullscreen > 0 THEN W.fullscreen = 0 ELSE W.fullscreen = 1
                                CASE 17
                                    W.musicV = W.musicV + .1
                                    IF W.musicV > 1 THEN W.musicV = .1
                                CASE 18
                                    W.sfxV = W.sfxV + .1
                                    IF W.sfxV > 1 THEN W.sfxV = .1
                                CASE 19
                                    Level.cancel = -1
                                    EXIT DO
                            END SELECT
                        END IF
                        LINE (150, GameMenus(i).y - 10)-(650, GameMenus(i).y + 24), _RGBA(255, 100, 0, 100), BF
                    END IF
                    _PUTIMAGE (150, GameMenus(i).y), GameMenus(i).img
                    SELECT CASE i
                        CASE 16
                            IF W.fullscreen > 0 THEN _PUTIMAGE (580, GameMenus(i).y - 3), onn& ELSE _PUTIMAGE (580, GameMenus(i).y - 3), offf&
                        CASE 17
                            _FONT Fonts.normal
                            IF W.musicV > .9 THEN
                                _PRINTSTRING (630 - txtWidth(" 10"), GameMenus(i).y), " 10 "
                            ELSE
                                _PRINTSTRING (630 - txtWidth(STR$(INT(W.musicV * 10))), GameMenus(i).y), STR$(INT(W.musicV * 10))
                            END IF
                        CASE 18
                            _FONT Fonts.normal
                            IF W.sfxV > .9 THEN
                                _PRINTSTRING (630 - txtWidth(" 10"), GameMenus(i).y), " 10 "
                            ELSE
                                _PRINTSTRING (630 - txtWidth(STR$(INT(W.sfxV * 10))), GameMenus(i).y), STR$(INT(W.sfxV * 10))
                            END IF
                    END SELECT
                NEXT
                IF _KEYHIT = 27 OR _MOUSEBUTTON(3) THEN EXIT DO
                _LIMIT W.fps
                _PUTIMAGE (Mouse.x - 8, Mouse.y - 8), Mouse.cursor
                _DISPLAY
            LOOP
            FOR i = 255 TO 0 STEP -10
                _SETALPHA i, , bd2&
                _PUTIMAGE , bd&
                _PUTIMAGE , bd2&
                LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, i / 3), BF
                _PUTIMAGE (150, 222), gfx&, 0, (0, 0)-(500, p5map(i, 0, 255, 0, 222))
                _DISPLAY
            NEXT
 
            _PUTIMAGE , bd& 'Erase that menu line
            _FREEIMAGE bd&
            _FREEIMAGE bd2&
            _FREEIMAGE ac&
            _FREEIMAGE gfx&
            _FREEIMAGE onn&
            _FREEIMAGE offf&
            loadComponents
 
            IF W.sfx THEN 'update the sfx volume and play the paused sound.
                updateSfxVolume
                IF NOT Level.cancel THEN PlayPausedSound
            END IF
 
            TIMER(GameRenderingEvent) ON
            TIMER(TimerEvent) ON
 
            IF Level.cancel THEN EXIT DO
        END IF
        _LIMIT W.fps
    LOOP UNTIL Level.completed OR Level.over
    TIMER(GameRenderingEvent) OFF
    CloseTime
    FOR i = 0 TO 20
        IF Bloods(i).active THEN
            Bloods(i).active = 0
            SPRITEHIDE Bloods(i).img
        END IF
        IF explosions(i).active THEN
            explosions(i).active = 0
            SPRITEHIDE explosions(i).img
        END IF
    NEXT
    FOR i = 0 TO UBOUND(ShotScore)
        ShotScore(i).active = 0
    NEXT
END SUB
 
SUB UpdateStatus ()
    ' $checking:off
    STATIC thunder_f_count, thunder_ha_count, thunder_ha_count_limit
    DIM i AS INTEGER, t AS INTEGER, tmp&, tmp2&
 
    IF Seconds% < OldSeconds% OR OldScore% < CurrentScore% THEN _PUTIMAGE (0, 0)-(_WIDTH, _HEIGHT), Level.bg
 
    IF _SCREENICON THEN EXIT SUB
    FOR i = 1 TO Level.enemies
        IF Enemie(i).u = Level.u AND Enemie(i).active = 0 AND Enemie(i).scene = Level.currentScene THEN
            Enemie(i).active = -1
            PlayEnemieMusic i
            'echo "[New Enemie] (Scene " + STR$(Level.currentScene) + ")"
            'echo "Type : " + Enemie(i).typ
            'echo "u : " + STR$(Enemie(i).u)
            'echo "Current u : " + STR$(Enemie(i).u)
            'echo " Enemie Scene : " + STR$(Enemie(i).scene)
            'echo "Enemie Movement : " + STR$(Enemie(i).m)
        END IF
    NEXT
    FOR i = 1 TO Level.enemies
        IF Enemie(i).active AND Enemie(i).scene = Level.currentScene THEN
            'IF Enemie(i).u = Level.u THEN
            '    echo "Rendered"
            '    echo "********************************************************************************"
            'END IF
            IF Enemie(i).f > Enemie(i).n THEN SPRITENEXT Enemie(i).img: Enemie(i).f = 0
 
            SPRITEPUT Enemie(i).x, Enemie(i).y, Enemie(i).img
 
            Enemie(i).x = Enemie(i).x + Enemie(i).m
            Enemie(i).f = Enemie(i).f + 1
 
            IF W.SE THEN _SNDBAL Enemie(i).snd, p5map(Enemie(i).x, 0, _WIDTH, -1, 1), p5map(Enemie(i).y, 0, _HEIGHT, 1, -1), , 2
 
            IF Enemie(i).x > _WIDTH + SPRITECURRENTWIDTH(Enemie(i).img) THEN Enemie(i).m = -Enemie(i).m: SPRITEFLIP Enemie(i).img, HORIZONTAL: PlayEnemieMusic i
            IF Enemie(i).x < -SPRITECURRENTWIDTH(Enemie(i).img) THEN Enemie(i).m = -Enemie(i).m: SPRITEFLIP Enemie(i).img, NONE: PlayEnemieMusic i
 
            IF Mouse.x > SPRITEX1(Enemie(i).img) AND Mouse.x < SPRITEX2(Enemie(i).img) AND Mouse.y > SPRITEY1(Enemie(i).img) AND Mouse.y < SPRITEY2(Enemie(i).img) THEN
                Mouse.hovering = -1
 
                IF Mouse.lclick THEN Enemie(i).life = Enemie(i).life - Gun.damage
                IF Enemie(i).life < 0 THEN Enemie(i).life = 0
 
                'Showing Enemie current life with life bar
                IF Enemie(i).life = 0 THEN
                    _PUTIMAGE (Enemie(i).x - SPRITECURRENTWIDTH(Enemie(i).img) / 2, Enemie(i).y - 30), lifeBars(0)
                ELSE
                    _PUTIMAGE (Enemie(i).x - SPRITECURRENTWIDTH(Enemie(i).img) / 2, Enemie(i).y - 30), lifeBars(INT(Enemie(i).life / Enemie(i).life2 * 100) - 1) 'shows life bar :)
                END IF
            END IF
            'checking if any enemie is dead :D
            IF Enemie(i).life = 0 THEN
                SPRITEHIDE Enemie(i).img
                Enemie(i).ending = -1
                Enemie(i).active = 0
                StopEnemieMusic i
                'echo "[Enemie Dead]"
                'echo "Type : " + Enemie(i).typ
                'echo "Enemie Scene" + STR$(Enemie(i).scene)
                'echo "--------------------------------------------------------------------------------------"
                'You will get more score with ShotGun :P
 
                IF Gun.id = 1 THEN CurrentScore% = CurrentScore% + INT(Enemie(i).points * 1.4)
 
                MakeScoreFlash Enemie(i).x, Enemie(i).y, Enemie(i).points
                CurrentScore% = CurrentScore% + Enemie(i).points
                MakeBloods Enemie(i).x, Enemie(i).y, Enemie(i).typ
            END IF
        END IF
    NEXT
 
    IF Mouse.rclick THEN
        IF Gun.id = 1 THEN Gun.id = 2: Gun.name = "Ak-47": Gun.damage = 6 ELSE Gun.id = 1: Gun.name = "Shot Gun": Gun.damage = 3
        Mouse.rclick = 0
    END IF
    FOR i = 0 TO 20
        IF Bloods(i).active THEN
            IF Bloods(i).f > Bloods(i).n THEN SPRITENEXT Bloods(i).img: Bloods(i).f = 0: Bloods(i).currentFrame = Bloods(i).currentFrame + 1
            Bloods(i).f = Bloods(i).f + 1
            SPRITEPUT Bloods(i).x, Bloods(i).y, Bloods(i).img
            IF Bloods(i).currentFrame > Bloods(i).totalFrames * 2 THEN Bloods(i).active = 0: SPRITEHIDE Bloods(i).img
        END IF
    NEXT
    FOR i = 0 TO 20
        IF explosions(i).active THEN
            IF explosions(i).f > explosions(i).n THEN SPRITENEXT explosions(i).img: explosions(i).f = 0: explosions(i).currentFrame = explosions(i).currentFrame + 1
            explosions(i).f = explosions(i).f + 1
            SPRITEPUT explosions(i).x, explosions(i).y, explosions(i).img
            IF explosions(i).currentFrame > explosions(i).totalFrames THEN explosions(i).active = 0: SPRITEHIDE explosions(i).img
        END IF
    NEXT
 
    IF Seconds% < OldSeconds% OR OldScore% < CurrentScore% THEN
        IF Seconds% < 1 THEN Level.over = -1
        OldSeconds% = Seconds%
        OldScore% = CurrentScore%
        IF Seconds% < 11 THEN COLOR _RGB(255, 0, 0) ELSE COLOR _RGB(255, 255, 255)
        'redraw scoreboard
        _PUTIMAGE (0, 520), ScoreBoard&
        _PUTIMAGE (50, 550)-(170, 590), GunImg&(Gun.id - 1)
        _FONT Fonts.smaller
        _PRINTSTRING (40, 580), RTRIM$(Gun.name)
        _PRINTSTRING (600, 560), "Score - " + STR$(CurrentScore%)
        IF Seconds% >= 60 THEN t = Seconds% MOD 60 ELSE t = Seconds%
        _PRINTSTRING (600, 580), "Time left - " + STR$(Minutes%) + ":" + STR$(t)
        _FONT Fonts.normal
        IF randomLevels THEN _PRINTSTRING (CenterPrintX("Random Levels"), 560), "Random Levels" ELSE _PRINTSTRING (CenterPrintX("Stage " + STR$(LevelStage%)), 560), "Stage " + STR$(LevelStage%)
 
    END IF
 
    Level.u = Level.u + 1
    'creating new game scene
    IF SceneEnd(Level.currentScene) THEN
        Level.currentScene = Level.currentScene + 1
        Level.u = 0
        'echo "Current Scene : " + STR$(Level.currentScene)
        IF Level.currentScene > Level.scenes THEN Level.completed = -1
    END IF
 
    'game MODS
    SELECT CASE Level.mode
        CASE FOGMODE
            Fogs.x = Fogs.x - Fogs.move
            IF Fogs.x < -1600 OR Fogs.x > 0 THEN Fogs.move = -Fogs.move
            _PUTIMAGE (Fogs.x, 0), Fogs.handle
 
        CASE THUNDERMODE
            FallDrops
            DrawDrops
 
        CASE STORMMODE
            _PUTIMAGE (StormX%, 0), StormImg&
            StormX% = StormX% - 1
            IF StormX% < -2300 THEN StormX% = 0
 
        CASE FOGMODE + THUNDERMODE
            Fogs.x = Fogs.x - Fogs.move
            IF Fogs.x < -1600 OR Fogs.x > 0 THEN Fogs.move = -Fogs.move
            _PUTIMAGE (Fogs.x, 0), Fogs.handle
 
            FallDrops
            DrawDrops
 
        CASE FOGMODE + THUNDERMODE + 7
            Fogs.x = Fogs.x - Fogs.move
            IF Fogs.x < -1600 OR Fogs.x > 0 THEN Fogs.move = -Fogs.move
            _PUTIMAGE (Fogs.x, 0), Fogs.handle
 
            FallDrops
            DrawDrops
        CASE STORMMODE + THUNDERMODE
            _PUTIMAGE (StormX%, 0), StormImg&
            StormX% = StormX% - 1
            IF StormX% < -2300 THEN StormX% = 0
 
            FallDrops
            DrawDrops
 
        CASE STORMMODE + FOGMODE + THUNDERMODE
            Fogs.x = Fogs.x - Fogs.move
            IF Fogs.x < -1600 OR Fogs.x > 0 THEN Fogs.move = -Fogs.move
            _PUTIMAGE (Fogs.x, 0), Fogs.handle
 
            _PUTIMAGE (StormX%, 0), StormImg&
            StormX% = StormX% - 1
            IF StormX% < -2300 THEN StormX% = 0
 
            FallDrops
            DrawDrops
 
    END SELECT
 
    'scores effect
    FOR i = 0 TO UBOUND(ShotScore)
        IF ShotScore(i).active = -1 THEN
            ShotScore(i).sclX = SIN(ShotScore(i).__ops) * .5 + .5
            _PUTIMAGE (ShotScore(i).x - (ShotScore(i).sclX * _WIDTH(ShotScore(i).img) / 2), ShotScore(i).y - (ShotScore(i).sclX * _HEIGHT(ShotScore(i).img)) / 2)-(ShotScore(i).x + (ShotScore(i).sclX * _WIDTH(ShotScore(i).img)) / 2, ShotScore(i).y + (ShotScore(i).sclX * _HEIGHT(ShotScore(i).img)) / 2), ShotScore(i).img
            ShotScore(i).__ops = ShotScore(i).__ops + .1
            IF ShotScore(i).__ops > _PI(1.5) THEN
                ShotScore(i).active = 0
            END IF
        END IF
    NEXT
 
    'countdown when game time is less or equal to 10s
    IF Seconds% < 11 THEN
        COLOR _RGB(255, 0, 0)
        _FONT Fonts.biggest
        _PRINTSTRING (CenterPrintX(RTRIM$(LTRIM$(STR$(Seconds%)))), _HEIGHT / 2 - _FONTHEIGHT / 2), RTRIM$(LTRIM$(STR$(Seconds%)))
    END IF
 
    'cursors
    IF Mouse.lclick THEN
        Mouse.lclick = 0
        IF W.sfx THEN
            IF Gun.id = 1 THEN _SNDPLAYCOPY Gun1& ELSE _SNDPLAYCOPY Gun2&
        END IF
    END IF
    IF Mouse.hovering THEN
        Mouse.hovering = 0
        _PUTIMAGE (Mouse.x - 16, Mouse.y - 16), Mouse.cursor2
    ELSE
        _PUTIMAGE (Mouse.x - 16, Mouse.y - 16), Mouse.cursor
    END IF
 
    IF Level.mode = THUNDERMODE OR Level.mode = THUNDERMODE + FOGMODE + 7 THEN
        IF thunder_ha_count_limit = 0 THEN thunder_ha_count_limit = p5random(1, 4)
        IF ThunderEvent = 0 THEN ThunderEvent = p5random(30, 340)
        ThunderCount = ThunderCount + 1
        IF ThunderCount > ThunderEvent THEN
            thunder_f_count = thunder_f_count + 1
            tmp& = _COPYIMAGE(0)
            tmp2& = _COPYIMAGE(0)
            MakeThunderImage tmp&
            _PUTIMAGE , tmp&
            _DISPLAY
            _PUTIMAGE , tmp2&
            _FREEIMAGE tmp&
            _FREEIMAGE tmp2&
            IF thunder_f_count > 3 THEN
                IF thunder_ha_count < thunder_ha_count_limit THEN
                    ' ThunderCount = 0
                    thunder_f_count = 0
                    ThunderEvent = ThunderEvent + p5random(4, 25) + 3
                    thunder_ha_count = thunder_ha_count + 1
                ELSE
                    thunder_ha_count = 0
                    thunder_f_count = 0
                    ThunderEvent = 0
                    ThunderCount = 0
                    thunder_ha_count_limit = p5random(1, 4)
                END IF
            END IF
        ELSE
            _DISPLAY
        END IF
    ELSE
        _DISPLAY
    END IF
    ' $checking:on
END SUB
 
SUB MakeBloods (x, y, typ AS STRING * 16)
    SELECT CASE RTRIM$(typ)
        CASE "jet1", "jet2", "jet3"
            MakeExplosions x, y
            EXIT SUB
    END SELECT
    DIM i AS INTEGER
    FOR i = 0 TO 20
        IF Bloods(i).active = 0 THEN
            Bloods(i).active = -1
            Bloods(i).x = x
            Bloods(i).y = y
            Bloods(i).currentFrame = 1
            SPRITESHOW Bloods(i).img
            EXIT SUB
        END IF
    NEXT
END SUB
 
SUB MakeExplosions (x, y)
    DIM i AS INTEGER
    FOR i = 0 TO 20
        IF explosions(i).active = 0 THEN
            explosions(i).active = -1
            explosions(i).x = x
            explosions(i).y = y
            explosions(i).currentFrame = 1
            SPRITESHOW explosions(i).img
            IF W.sfx THEN _SNDPLAY Expos&
            EXIT SUB
        END IF
    NEXT
END SUB
 
SUB MakeScoreFlash (x, y, s)
    DIM i AS INTEGER
    FOR i = 0 TO UBOUND(ShotScore)
        IF ShotScore(i).active = 0 THEN
            ShotScore(i).active = -1
            ShotScore(i).x = x
            ShotScore(i).y = y
            ShotScore(i).__ops = -_PI(.5)
            SELECT CASE s
                CASE 10
                    ShotScore(i).img = scoresImage(0)
                CASE 20
                    ShotScore(i).img = scoresImage(1)
                CASE 35
                    ShotScore(i).img = scoresImage(2)
                CASE 50
                    ShotScore(i).img = scoresImage(3)
                CASE 75
                    ShotScore(i).img = scoresImage(4)
                CASE 100
                    ShotScore(i).img = scoresImage(5)
            END SELECT
        END IF
    NEXT
END SUB
 
SUB UpdateTime ()
    Seconds% = Seconds% - 1
    Minutes% = (Seconds% - (Seconds% MOD 60)) / 60
END SUB
 
SUB CloseTime
    TIMER(TimerEvent) OFF
END SUB
 
SUB PlayEnemieMusic (which&)
    IF W.sfx = 0 THEN EXIT SUB
 
    _SNDPLAY Enemie(which&).snd
END SUB
 
SUB StopEnemieMusic (which&)
    _SNDSTOP Enemie(which&).snd
    Enemie(which&).sndPaused = 2 '2 for stop and 1 for paused
END SUB
 
SUB updateSfxVolume ()
    IF NOT W.sfx THEN EXIT SUB
 
    DIM i AS INTEGER
    FOR i = 1 TO Level.enemies
        _SNDVOL Enemie(i).snd, W.sfxV
    NEXT
    _SNDVOL RainSound&, W.sfxV
END SUB
 
SUB setMusicVol (v!)
    IF NOT W.music THEN EXIT SUB
    _SNDVOL Musics&(0), v!
    _SNDVOL Musics&(1), v!
    _SNDVOL Musics&(2), v!
END SUB
 
SUB PlayPausedSound ()
    DIM i AS INTEGER
    FOR i = 1 TO Level.enemies
        IF Enemie(i).sndPaused = 1 THEN Enemie(i).sndPaused = 0: _SNDPLAY Enemie(i).snd
    NEXT
    IF Level.mode = THUNDERMODE OR Level.mode = FOGMODE + THUNDERMODE THEN
        IF NOT _SNDPLAYING(RainSound&) THEN _SNDPLAY RainSound&
    END IF
END SUB
 
SUB PauseSound ()
 
    DIM i AS INTEGER
    FOR i = 1 TO Level.enemies
        IF Enemie(i).sndPaused = 0 THEN _SNDSTOP Enemie(i).snd: Enemie(i).sndPaused = 1
    NEXT
 
    IF _SNDPLAYING(RainSound&) THEN _SNDSTOP RainSound&
 
END SUB
 
FUNCTION SceneEnd (which%)
    DIM i AS INTEGER, d AS _BYTE
 
    FOR i = 1 TO Level.enemies
        IF Enemie(i).ending = 0 AND Enemie(i).scene = which% THEN d = -1: EXIT FOR
    NEXT
    IF d = 0 THEN SceneEnd = -1 ELSE SceneEnd = 0
END FUNCTION
 
SUB SaveGame ()
    DIM a$, F AS INTEGER
    a$ = "Save_Game\save.dat"
    KILL a$
    F = FREEFILE
    LevelStage% = LevelStage% + 1
    OPEN a$ FOR BINARY AS #F
    IF HighScore% < CurrentScore% THEN PUT #F, , CurrentScore% ELSE PUT #F, , HighScore%
    PUT #F, , LevelStage%
    CLOSE #F
END SUB
 
SUB SetupRain ()
    DIM i AS INTEGER
    FOR i = 0 TO UBOUND(Drop)
        Drop(i).x = RND * _WIDTH
        Drop(i).y = -(RND * (_HEIGHT * 3))
        Drop(i).z = INT(RND * 1)
        Drop(i).yspeed = Map(Drop(i).z, 0, 1, 1, 2)
        Drop(i).len = Map(Drop(i).z, 0, 1, 8, 16)
        Drop(i).gravity = Map(Drop(i).z, 0, 1, 0.1, 0.3)
    NEXT
    RainVol# = -1.0
END SUB
 
SUB FallDrops ()
    DIM i AS INTEGER
    FOR i = 0 TO UBOUND(drop)
        Drop(i).y = Drop(i).y + Drop(i).yspeed
        Drop(i).yspeed = Drop(i).yspeed + Drop(i).gravity
        IF Drop(i).y > _HEIGHT THEN Drop(i).y = RND * -400: Drop(i).yspeed = Map(Drop(i).z, 0, 1, 1, 2)
    NEXT
END SUB
 
SUB DrawDrops ()
    DIM i AS INTEGER
    IF W.sfx THEN
        ' IF RainVol# < .98 THEN RainVol# = RainVol# + 0.01: _SNDBAL RainSound&, 0, 0, RainVol#
        IF NOT _SNDPLAYING(RainSound&) THEN _SNDPLAY RainSound&
    END IF
    FOR i = 0 TO UBOUND(drop)
        IF Drop(i).z = 0 THEN _PUTIMAGE (Drop(i).x, Drop(i).y), Rainx8& ELSE _PUTIMAGE (Drop(i).x, Drop(i).y), Rainx16&
    NEXT
 
END SUB
 
 
FUNCTION Map (value, r1, r2, e1, e2)
    IF value = r1 THEN Map = e1
    IF value = r2 THEN Map = e2
END FUNCTION
 
SUB MakeThunderImage (original_img&)
    IF original_img& = -1 THEN EXIT SUB
 
    $CHECKING:OFF
    DIM buffer AS _MEM, o AS _OFFSET, o2 AS _OFFSET
    DIM b AS _UNSIGNED _BYTE, n AS _BYTE
    n = p5random(30, 120)
 
    buffer = _MEMIMAGE(original_img&)
    o = buffer.OFFSET
    o2 = o + _WIDTH(original_img&) * _HEIGHT(original_img&) * 4
    DO
        ' echo str$(o)
        b = _MEMGET(buffer, o, _UNSIGNED _BYTE)
        IF b + n < 256 THEN b = b + n ELSE b = 255
        _MEMPUT buffer, o, b AS _UNSIGNED _BYTE
        b = _MEMGET(buffer, o + 1, _UNSIGNED _BYTE)
        IF b + n < 256 THEN b = b + n ELSE b = 255
        _MEMPUT buffer, o + 1, b AS _UNSIGNED _BYTE
        b = _MEMGET(buffer, o + 2, _UNSIGNED _BYTE)
        IF b + n < 256 THEN b = b + n ELSE b = 255
        _MEMPUT buffer, o + 2, b AS _UNSIGNED _BYTE
        o = o + 4
    LOOP UNTIL o = o2
    _MEMFREE buffer
    $CHECKING:ON
END SUB
 
SUB centerImage (img&)
    _PUTIMAGE ((_WIDTH / 2) - (_WIDTH(img&) / 2), (_HEIGHT / 2) - (_HEIGHT(img&) / 2))-STEP(_WIDTH(img&), _HEIGHT(img&)), img&
END SUB
 
SUB showCredits ()
    DIM k&, f&, i AS INTEGER, f2&, yy AS INTEGER
 
    k& = _LOADIMAGE("Images/credits.png", 33)
    f& = _NEWIMAGE(_WIDTH(k&), _HEIGHT(k&), 32)
    _DEST f&
    FOR i = 0 TO 255
        LINE (0, (_HEIGHT - 255) + i)-(_WIDTH, (_HEIGHT - 255) + i), _RGBA(0, 0, 0, i)
        LINE (0, 255 - i)-(_WIDTH, 255 - i), _RGBA(0, 0, 0, i)
    NEXT
    _DEST 0
    f2& = _COPYIMAGE(f&, 33)
    SWAP f&, f2&
    _FREEIMAGE f2&
    yy = _HEIGHT + 50
    DO
 
        _PUTIMAGE (50, yy), k&
        _PUTIMAGE , f&
        yy = yy - 1
 
        _DISPLAY
        _LIMIT W.fps
    LOOP UNTIL yy < -_HEIGHT(k&)
    _FREEIMAGE f&
    _FREEIMAGE k&
END SUB
 
' SUB showCredits2 ()
' CLS
' _FONT Fonts.bigger
' _PRINTSTRING (CenterPrintX("Super Hunters 2017-18"), 250), "Super Hunters 2017-18"
' _FONT Fonts.normal
' _PRINTSTRING (CenterPrintX("By Ashish Kushwaha"), 290), "By Ashish Kushwaha"
' initTextParticles _RGB(255, 255, 255)
' CLS
' DO
' CLS
' moveTextParticles
' _LIMIT W.fps
' _DISPLAY
' LOOP UNTIL Text_Particles_Status = 1
' _DELAY 1
' fallTextParticles "fall"
' CLS
' _FONT Fonts.bigger
' _PRINTSTRING (CenterPrintX("Programmer"), 250), "Programmer"
' _FONT Fonts.normal
' _PRINTSTRING (CenterPrintX("Ashish Kushwaha"), 290), "Ashish Kushwaha"
' initTextParticles _RGB(255, 255, 255)
' ' _DISPLAY: SLEEP
' CLS
' DO
' CLS
' moveTextParticles
' _LIMIT W.fps
' _DISPLAY
' LOOP UNTIL Text_Particles_Status = 1
' _DELAY 1
' fallTextParticles "lessgravity"
' CLS
' _FONT Fonts.bigger
' _PRINTSTRING (CenterPrintX("Graphic Designer"), 250), "Graphic Designer"
' _FONT Fonts.normal
' _PRINTSTRING (CenterPrintX("Google Images & Ashish Kushwaha"), 290), "Google Images & Ashish Kushwaha"
' initTextParticles _RGB(255, 255, 255)
' CLS
' DO
' CLS
' moveTextParticles
' _LIMIT W.fps
' _DISPLAY
' LOOP UNTIL Text_Particles_Status = 1
' _DELAY 1
' fallTextParticles "explode"
' CLS
' _FONT Fonts.bigger
' _PRINTSTRING (CenterPrintX("Level Designer"), 250), "Level Designer"
' _FONT Fonts.normal
' _PRINTSTRING (CenterPrintX("Ashish Kushwaha"), 290), "Ashish Kushwaha"
' initTextParticles _RGB(255, 255, 255)
' CLS
' DO
' CLS
' moveTextParticles
' _LIMIT W.fps
' _DISPLAY
' LOOP UNTIL Text_Particles_Status = 1
' _DELAY 1
' fallTextParticles "horizontal"
' CLS
' _FONT Fonts.bigger
' _PRINTSTRING (CenterPrintX("Special Thanks -"), 230), "Special Thanks -"
' _FONT Fonts.normal
' _PRINTSTRING (CenterPrintX("Terry Ritchie for sprite library"), 270), "Terry Ritchie for sprite library"
' _PRINTSTRING (CenterPrintX("Unseenmachine & [banned user] for BlurImage"), 320), "Unseenmachine & [banned user] for BlurImage"
' _PRINTSTRING (CenterPrintX("and player of this game!"), 345), "and player of this game!"
' initTextParticles _RGB(255, 255, 255)
' CLS
' DO
' CLS
' moveTextParticles
' _LIMIT W.fps
' _DISPLAY
' LOOP UNTIL Text_Particles_Status = 1
' _DELAY 1
' fallTextParticles "boom"
 
' END SUB
 
' SUB initTextParticles (which~&)
' SHARED Text_Particles() AS Vector_Particles_Text_Type
' FOR y = 0 TO _HEIGHT - 1
' FOR x = 0 TO _WIDTH - 1
' col~& = POINT(x, y)
' IF col~& = which~& THEN n = n + 1
' NEXT x, y
 
' REDIM Text_Particles(n) AS Vector_Particles_Text_Type
' n = 0
' Text_Particles_Color = which~&
' FOR x = 0 TO _WIDTH - 1
' FOR y = 0 TO _HEIGHT - 1
' col~& = POINT(x, y)
' IF col~& = which~& THEN
' Text_Particles(n).x = x
' Text_Particles(n).y = y
' Text_Particles(n).vx = p5random(0, _WIDTH)
' Text_Particles(n).vy = p5random(0, _HEIGHT)
' Text_Particles(n).dist = dist(Text_Particles(n).vx, Text_Particles(n).vy, Text_Particles(n).x, Text_Particles(n).y)
' Text_Particles(n).distX = ABS(Text_Particles(n).x - Text_Particles(n).vx)
' Text_Particles(n).distY = ABS(Text_Particles(n).y - Text_Particles(n).vy)
' n = n + 1
' END IF
' NEXT y, x
' END SUB
 
' SUB moveTextParticles ()
' SHARED Text_Particles() AS Vector_Particles_Text_Type
' FOR i = 0 TO UBOUND(Text_Particles)
' IF Text_Particles(i).k < Text_Particles(i).dist THEN
' PSET (Text_Particles(i).vx + Text_Particles(i).delX, Text_Particles(i).vy + Text_Particles(i).delY), Text_Particles_Color
' IF Text_Particles(i).vx > Text_Particles(i).x THEN Text_Particles(i).delX = Text_Particles(i).delX - Text_Particles(i).distX / Text_Particles(i).dist ELSE Text_Particles(i).delX = Text_Particles(i).delX + Text_Particles(i).distX / Text_Particles(i).dist
' IF Text_Particles(i).vy > Text_Particles(i).y THEN Text_Particles(i).delY = Text_Particles(i).delY - Text_Particles(i).distY / Text_Particles(i).dist ELSE Text_Particles(i).delY = Text_Particles(i).delY + Text_Particles(i).distY / Text_Particles(i).dist
' Text_Particles(i).k = Text_Particles(i).k + 1
' ELSE
' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color
' check = check + 1
' END IF
' NEXT
' IF check >= UBOUND(text_particles) THEN Text_Particles_Status = 1: EXIT SUB ELSE Text_Particles_Status = 0
 
' END SUB
 
' SUB fallTextParticles (typ$)
' SHARED Text_Particles() AS Vector_Particles_Text_Type
' typ$ = LCASE$(typ$)
' SELECT CASE typ$
' CASE "explode"
' FOR i = 0 TO UBOUND(Text_Particles)
' Text_Particles(i).vx = 0
' Text_Particles(i).vy = 0
' Text_Particles(i).delX = p5random(-0.1, 0.1)
' Text_Particles(i).delY = p5random(-0.1, 0.1)
' NEXT
' DO
' CLS
' z = 0
' FOR i = 0 TO UBOUND(Text_Particles)
 
' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color
' IF i < array_len THEN
' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx
' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy
' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX
' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY
' END IF
' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1
' NEXT
' IF array_len < UBOUND(Text_Particles) THEN array_len = array_len + steps
' _DISPLAY
' _LIMIT W.fps
' steps = steps + 1
' IF z > UBOUND(Text_Particles) THEN EXIT DO
' LOOP UNTIL INKEY$ <> ""
' EXIT SUB
' CASE "fall"
' FOR i = 0 TO UBOUND(text_particles)
' Text_Particles(i).vx = 0
' Text_Particles(i).vy = 0
' Text_Particles(i).delX = p5random(-.02, .02)
' Text_Particles(i).delY = p5random(0.1, 0.2)
' NEXT
' DO
' CLS
' z = 0
' FOR i = 0 TO UBOUND(text_particles)
' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color
' IF i < array_len THEN
' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx
' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy
' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX
' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY
' END IF
' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1
' NEXT
' IF array_len < UBOUND(text_particles) THEN array_len = array_len + steps
' _DISPLAY
' _LIMIT W.fps
' steps = steps + 1
' IF z = UBOUND(text_particles) THEN EXIT DO
' LOOP
' EXIT SUB
 
' CASE "lessgravity"
' FOR i = 0 TO UBOUND(Text_Particles)
' Text_Particles(i).vx = 0
' Text_Particles(i).vy = 0
' Text_Particles(i).delX = p5random(-.02, .02)
' Text_Particles(i).delY = p5random(-0.1, -0.2)
' NEXT
' DO
' CLS
' z = 0
' FOR i = 0 TO UBOUND(Text_Particles)
' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color
' IF i < array_len THEN
' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx
' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy
' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX
' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY
' END IF
' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1
' NEXT
' IF array_len < UBOUND(Text_Particles) THEN array_len = array_len + steps
' _DISPLAY
' _LIMIT W.fps
' steps = steps + 1
' LOOP UNTIL INKEY$ <> "" OR z >= UBOUND(text_particles)
' EXIT SUB
' CASE "horizontal"
' FOR i = 0 TO UBOUND(Text_Particles)
' Text_Particles(i).vx = 0
' Text_Particles(i).vy = 0
' Text_Particles(i).delX = p5random(-.2, .2)
' Text_Particles(i).delY = 0
' NEXT
' DO
' CLS
' z = 0
' FOR i = 0 TO UBOUND(Text_Particles)
' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color
' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx
' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy
' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX
' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY
' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1
' NEXT
' _DISPLAY
' _LIMIT W.fps
' LOOP UNTIL INKEY$ <> "" OR z >= UBOUND(text_particles)
' EXIT SUB
' CASE "vertical"
' FOR i = 0 TO UBOUND(Text_Particles)
' Text_Particles(i).vx = 0
' Text_Particles(i).vy = 0
' Text_Particles(i).delX = 0
' Text_Particles(i).delY = p5random(-0.2, 0.2)
' NEXT
' DO
' CLS
' z = 0
' FOR i = 0 TO UBOUND(Text_Particles)
' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color
 
' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx
' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy
' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX
' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY
 
' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN z = z + 1
' NEXT
' _DISPLAY
' _LIMIT W.fps
' LOOP UNTIL INKEY$ <> "" OR z >= UBOUND(text_particles)
' EXIT SUB
 
' CASE "boom"
' FOR i = 0 TO UBOUND(Text_Particles)
' Text_Particles(i).vx = 0
' Text_Particles(i).vy = 0
' Text_Particles(i).delX = p5random(-.1, .1)
' Text_Particles(i).delY = p5random(-0.1, 0.1)
' NEXT
' DO
' CLS
' steps = 0
' FOR i = 0 TO UBOUND(Text_Particles)
' PSET (Text_Particles(i).x, Text_Particles(i).y), Text_Particles_Color
' Text_Particles(i).x = Text_Particles(i).x + Text_Particles(i).vx
' Text_Particles(i).y = Text_Particles(i).y + Text_Particles(i).vy
' Text_Particles(i).vx = Text_Particles(i).vx + Text_Particles(i).delX
' Text_Particles(i).vy = Text_Particles(i).vy + Text_Particles(i).delY
' IF Text_Particles(i).x > _WIDTH OR Text_Particles(i).x < 0 OR Text_Particles(i).y > _HEIGHT OR Text_Particles(i).y < 0 THEN steps = steps + 1
' NEXT
' _DISPLAY
' _LIMIT W.fps
' IF steps > UBOUND(Text_Particles) THEN EXIT DO
' LOOP UNTIL INKEY$ <> "" OR steps > UBOUND(text_particles)
' EXIT SUB
' END SELECT
' END SUB
 
SUB centerPrint (a$, b)
    DIM i AS INTEGER, v AS INTEGER
    FOR i = 1 TO LEN(a$)
        v = v + _PRINTWIDTH(MID$(a$, i, 1))
    NEXT
    _PRINTSTRING (_WIDTH / 2 - v / 2, b), a$
END SUB
 
FUNCTION txtWidth (a$)
    DIM i AS INTEGER, v AS INTEGER, g AS INTEGER
    FOR i = 1 TO LEN(a$)
        g = _PRINTWIDTH(MID$(a$, i, 1))
        v = v + g
    NEXT
    txtWidth = v
END FUNCTION
'these p5random(), p5map! (original map!) and dist() functions are taken from p5js.bas
FUNCTION p5random! (mn!, mx!)
    DIM tmp!
 
    IF mn! > mx! THEN
        tmp! = mn!
        mn! = mx!
        mx! = tmp!
    END IF
    p5random! = RND * (mx! - mn!) + mn!
END FUNCTION
 
FUNCTION dist! (x1!, y1!, x2!, y2!)
    dist! = SQR((x2! - x1!) ^ 2 + (y2! - y1!) ^ 2)
END FUNCTION
 
FUNCTION p5map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    p5map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 
 
'By UnseenMachine & [banned user]
'http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=12658
SUB BLURIMAGE (Image AS LONG, Blurs AS _UNSIGNED INTEGER)
 
    DIM ImageMemory AS _MEM
    DIM ImageOffsetCurrent AS _OFFSET
    DIM ImageOffsetStart AS _OFFSET
    DIM ImageOffsetEnd AS _OFFSET
 
    DIM TopOffset AS _OFFSET
    DIM LeftOffset AS _OFFSET
    DIM RightOffset AS _OFFSET
    DIM BottomOffset AS _OFFSET
 
    DIM Red1 AS _UNSIGNED _BYTE
    DIM Green1 AS _UNSIGNED _BYTE
    DIM Blue1 AS _UNSIGNED _BYTE
    DIM Alpha1 AS _UNSIGNED _BYTE
 
    DIM Red2 AS _UNSIGNED _BYTE
    DIM Green2 AS _UNSIGNED _BYTE
    DIM Blue2 AS _UNSIGNED _BYTE
    DIM Alpha2 AS _UNSIGNED _BYTE
 
    DIM Red3 AS _UNSIGNED _BYTE
    DIM Green3 AS _UNSIGNED _BYTE
    DIM Blue3 AS _UNSIGNED _BYTE
    DIM Alpha3 AS _UNSIGNED _BYTE
 
    DIM Red4 AS _UNSIGNED _BYTE
    DIM Green4 AS _UNSIGNED _BYTE
    DIM Blue4 AS _UNSIGNED _BYTE
    DIM Alpha4 AS _UNSIGNED _BYTE
 
    ImageMemory = _MEMIMAGE(Image)
 
    $CHECKING:OFF
 
    DIM iterations%
 
    FOR iterations% = 0 TO Blurs - 1
 
        ImageOffsetStart = ImageMemory.OFFSET
        ImageOffsetCurrent = ImageOffsetStart
        ImageOffsetEnd = ImageOffsetStart + _WIDTH(Image) * _HEIGHT(Image) * 4
 
        DO
            TopOffset = ImageOffsetCurrent - _WIDTH(Image) * 4
            LeftOffset = ImageOffsetCurrent - 4
            RightOffset = ImageOffsetCurrent + 4
            BottomOffset = ImageOffsetCurrent + _WIDTH(Image) * 4
 
            ' *** Let's go ahead and set the color values to zero, and only change them when required.
            Red1 = 0: Green1 = 0: Blue1 = 0: Alpha1 = 0
            Red2 = 0: Green2 = 0: Blue2 = 0: Alpha2 = 0
            Red3 = 0: Green3 = 0: Blue3 = 0: Alpha3 = 0
            Red4 = 0: Green4 = 0: Blue4 = 0: Alpha4 = 0
 
            ' *** Get the color values from the pixel above the current pixel, if it is with the image.
            IF TopOffset >= ImageOffsetStart THEN
                Red1 = _MEMGET(ImageMemory, TopOffset + 2, _UNSIGNED _BYTE)
                Green1 = _MEMGET(ImageMemory, TopOffset + 1, _UNSIGNED _BYTE)
                Blue1 = _MEMGET(ImageMemory, TopOffset, _UNSIGNED _BYTE)
                Alpha1 = _MEMGET(ImageMemory, TopOffset + 3, _UNSIGNED _BYTE)
            END IF
 
            ' *** Get the color values from the pixel to the left of the current pixel, if it is with the image.
            IF ((((LeftOffset - ImageOffsetStart) / 4) MOD _WIDTH(Image)) < (((ImageOffsetCurrent - ImageOffsetStart) / 4) MOD _WIDTH(Image))) THEN
                Red2 = _MEMGET(ImageMemory, LeftOffset + 2, _UNSIGNED _BYTE)
                Green2 = _MEMGET(ImageMemory, LeftOffset + 1, _UNSIGNED _BYTE)
                Blue2 = _MEMGET(ImageMemory, LeftOffset, _UNSIGNED _BYTE)
                Alpha2 = _MEMGET(ImageMemory, LeftOffset + 3, _UNSIGNED _BYTE)
            END IF
 
            ' *** Get the color values from the pixel to the right of the current pixel, if it is with the image.
            IF ((((RightOffset - ImageOffsetStart) / 4) MOD _WIDTH(Image)) > (((ImageOffsetCurrent - ImageOffsetStart) / 4) MOD _WIDTH(Image))) THEN
                Red3 = _MEMGET(ImageMemory, RightOffset + 2, _UNSIGNED _BYTE)
                Green3 = _MEMGET(ImageMemory, RightOffset + 1, _UNSIGNED _BYTE)
                Blue3 = _MEMGET(ImageMemory, RightOffset, _UNSIGNED _BYTE)
                Alpha3 = _MEMGET(ImageMemory, RightOffset + 3, _UNSIGNED _BYTE)
            END IF
 
            ' *** Get the color values from the pixel below the current pixel, if it is with the image.
            IF BottomOffset < ImageOffsetEnd THEN
                Red4 = _MEMGET(ImageMemory, BottomOffset + 2, _UNSIGNED _BYTE)
                Green4 = _MEMGET(ImageMemory, BottomOffset + 1, _UNSIGNED _BYTE)
                Blue4 = _MEMGET(ImageMemory, BottomOffset, _UNSIGNED _BYTE)
                Alpha4 = _MEMGET(ImageMemory, BottomOffset + 3, _UNSIGNED _BYTE)
            END IF
 
            ' *** draw the current pixel with a newly defined _RGBA color value.
            _MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA((Red1 + Red2 + Red3 + Red4) / 4, (Green1 + Green2 + Green3 + Green4) / 4, (Blue1 + Blue2 + Blue3 + Blue4) / 4, (Alpha1 + Alpha2 + Alpha3 + Alpha4) / 4) AS _UNSIGNED LONG
 
            '' *** These are here for fun nd testing purposes.
            '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA((Red1 + Red2 + Red3 + Red4) / 4, (Green1 + Green2 + Green3 + Green4) / 4, (Blue1 + Blue2 + Blue3 + Blue4) / 4, 255) AS _UNSIGNED LONG
            '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA(0, 0, (Blue1 + Blue2 + Blue3 + Blue4) / 4, 255) AS _UNSIGNED LONG
            '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA(0, (Green1 + Green2 + Green3 + Green4) / 4, 0, 255) AS _UNSIGNED LONG
            '_MEMPUT ImageMemory, ImageOffsetCurrent, _RGBA((Red1 + Red2 + Red3 + Red4) / 4, 0, 0, 255) AS _UNSIGNED LONG
 
            ImageOffsetCurrent = ImageOffsetCurrent + 4
 
        LOOP UNTIL ImageOffsetCurrent = ImageOffsetEnd
 
    NEXT
 
    $CHECKING:ON
    _MEMFREE ImageMemory
 
END SUB
'$include:'Vendor\sprite.bi'
 
'End of Code ! :)
 

General, Math & Geometry / Dropping Balls by bplus

« on: March 05, 2020, 05:10:08 am »

Dropping Balls

Author: @bplus
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=194.0
Version: 2020
Tags: [gravity], [spherical collisions]

Description:
Dropping Balls an attempt to build a pile by adjusting drop rate, elasticity, and gravity.
Bplus used tools from SMcNeill for fill circle and STxAxTIC for non-overlapping balls.

This thread is a fun continuation of ball collision experiments from a number of members including: @_vince who offered an hourglass challenge, @[banned user], @SMcNeill, @STxAxTIC, creating a collection of interesting variations. The code given here is just one program from a variety produced. Look through the whole of the designated thread, it continues into Hourglass thread linked near end of URL above.

Source Code:

Code: QB64: [Select]

    _TITLE "Dropping Balls: Pile Attempt #3" ' bplus started 2018-04-03"
    ' Attempt to build a pile by adjusting drop rate, elasticity, and gravity.
    ' Built from Dropping balls 4 w snd and STATIC created 2018-04-3
    ' Add STATIC's ball moving before figuring any bounce from collision
    ' which was a mod in Dropping Balls 2 w sound posted 2018-03-31.
    ' 2020-03-04 Pile Attempt #3 revive and tidy up
     
    RANDOMIZE TIMER
    CONST xmax = 750, ymax = 720, elastic = .8, gravity = .75, balls = 400, br = 15
    SCREEN _NEWIMAGE(xmax, ymax, 32)
    _SCREENMOVE 360, 20
    DIM x(balls), y(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
    FOR i = 1 TO balls 'initialize balls to drop
        x(i) = xmax / 2 + (i MOD 2) * 8 - 4: y(i) = 0 '                                     location
        dx(i) = 0: dy(i) = 3 '                                                        change on axis
        rr(i) = 150 + RND * 100: gg(i) = 150 + RND * 100: bb(i) = 150 + RND * 100 '        rgb color
    NEXT
    WHILE 1
        CLS
        loopCnt = loopCnt + 1 '                   drop ball every 17 loops so previous ball is clear
        IF loopCnt MOD 17 = 0 THEN
            IF maxBall < balls THEN maxBall = maxBall + 1
        END IF
        _PRINTSTRING (100, 10), "Balls:" + STR$(maxBall)
        FOR i = 1 TO maxBall
            'ready for collision
            dy(i) = dy(i) + gravity '                               gravity increase update on y axis
            a(i) = _ATAN2(dy(i), dx(i)) '                                       angle ball is heading
            imoved = 0
            FOR j = i + 1 TO maxBall
                '      The following is STxAxTIC's adjustment of ball positions if overlapping before
                ' calculation of new positions from collision. Displacement vector and its magnitude:
                nx = x(j) - x(i): ny = y(j) - y(i)
                nm = SQR(nx ^ 2 + ny ^ 2)
                IF nm < 1 + 2 * br THEN
                    nx = nx / nm: ny = ny / nm
                    ' Regardless of momentum exchange, separate balls along the line connecting them.
                    DO WHILE nm < 1 + 2 * br
                        flub = .001
                        x(j) = x(j) + flub * nx: y(j) = y(j) + flub * ny
                        x(i) = x(i) - flub * nx: y(i) = y(i) - flub * ny
                        nx = x(j) - x(i): ny = y(j) - y(i)
                        nm = SQR(nx ^ 2 + ny ^ 2)
                        nx = nx / nm: ny = ny / nm
                    LOOP
                    imoved = 1
                    a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                    a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
                    power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5 '       update new dx, dy for i and j balls
                    power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
                    power = elastic * (power1 + power2) / 2
                    dx(i) = power * COS(a(i)): dy(i) = power * SIN(a(i))
                    dx(j) = power * COS(a(j)): dy(j) = power * SIN(a(j))
                    x(i) = x(i) + dx(i): y(i) = y(i) + dy(i)
                    x(j) = x(j) + dx(j): y(j) = y(j) + dy(j)
                END IF '                                                              Thanks STxAxTIC
            NEXT
            IF imoved = 0 THEN x(i) = x(i) + dx(i): y(i) = y(i) + dy(i)
            IF x(i) - br < 0 OR x(i) + br > xmax THEN '       keep balls inside sides and bottom edge
                dx(i) = -dx(i)
                IF x(i) - br < 0 THEN x(i) = br
                IF x(i) + br > xmax THEN x(i) = xmax - br
            END IF
            IF y(i) + br > ymax THEN y(i) = ymax - br: dy(i) = -dy(i) * elastic
            FOR rad = br TO 1 STEP -1 '                                         finally draw the ball
                fcirc x(i), y(i), rad, _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            NEXT
        NEXT
        _DISPLAY
        _LIMIT 20
    WEND
     
    SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG) '       SMcNeill's fill circle
        DIM subRadius AS LONG, RadiusError AS LONG, X AS LONG, Y AS LONG
        subRadius = ABS(R): RadiusError = -subRadius: X = subRadius: Y = 0
        IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
        LINE (CX - X, CY)-(CX + X, CY), C, BF
        WHILE X > Y
            RadiusError = RadiusError + Y * 2 + 1
            IF RadiusError >= 0 THEN
                IF X <> Y + 1 THEN
                    LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                    LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
                END IF
                X = X - 1
                RadiusError = RadiusError - X * 2
            END IF
            Y = Y + 1
            LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
            LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
        WEND
    END SUB
 

QB64 Discussion / Samples Gallery

« on: February 25, 2020, 05:48:33 am »

In our 500Up! thread, bplus made the suggestion that we might nominate (and vote for) members and their programs for inclusion in the Samples Gallery (which at present is a little bare – Ursa Minor! *). That method would perhaps be a little cumbersome and folks don't want to spend time doing that.

Here's my suggestion - STxAxTIC has suggested having Junior Librarians to help him:

A Junior Librarian (who has been given the necessary permission) would contact the Top 20 Starters by e-mail - these folk must be the most deserving - and request that they select one Program which they would like to submit to the Samples Gallery. The Junior Librarian, when he has satisfied himself/herself that the Program meets STxAxTIC's selection criteria will then add this to the Gallery. This method would be in addition to the existing method of self-application to the Head Librarian.

As we currently have 16 samples, this would bring us up to about 35 and should give a broader range of applications.

I assume that the Junior Librarian would be able to access a more complete set of Site Statistics so that he/she can determine who the Top 20 Starters are (only 10 are visible in the normal stats).

This is a sufficiently non-technical task that I'd volunteer for this job.

Separately there could be a similar Junior Librarian Post for Toolbox which would be sufficiently technical that I would not qualify.

Worthy of pursuing, or another duff Qwerkey suggestion?

* Sorry, I couldn't resist the temptation of an astronomical pun.

QB64 Discussion / CINT Oddity (and Slightly Incorrect _ROUND Wiki?)

« on: February 15, 2020, 07:48:10 am »

The definition of _ROUND in the Wiki gives:

The _ROUND function rounds to the closest even INTEGER, LONG or _INTEGER64 numerical value.

Thinking to myself "Why would anybody want to round to the nearest even integer (that is to say one that is divisible by 2)?", I think that this sentence is wrong and should not contain the word "even". _ROUND rounds to the nearest integer:

Code: QB64: [Select]

PRINT _ROUND(5.501)
PRINT _ROUND(5.5)
PRINT _ROUND(5.499)

gives 6, 6, 5 as expected (not 6, 6, 6!).

Meanwhile I thought that I'd demonstrate to myself that CINT always behaves properly, but:

Code: QB64: [Select]

PRINT CINT(-6.5)
PRINT CINT(-5.5)
PRINT CINT(-4.5)
PRINT CINT(-3.5)
PRINT CINT(-2.5)
PRINT CINT(-1.5)
PRINT CINT(-0.5)
PRINT CINT(0.5)
PRINT CINT(1.5)
PRINT CINT(2.5)
PRINT CINT(3.5)
PRINT CINT(4.5)
PRINT CINT(5.5)
PRINT CINT(6.5)

gives: -6, -6, -4, -4, -2, -2, 0, 0, 2, 2, 4, 4, 6, 6
I'd have expected: -7, -6, -5, -4, -3, -2, -1, 1, 2, 3, 4, 5, 6, 7

Actually, I'm not quite sure what I'd have expected for the negative numbers (!), so I'll stick with the positive numbers.

We normally round 6.5 to 7. This is because the numbers 0 to 9 split in half as:

0,1,2,3,4
5,6,7,8,9

so any decimal number 6.0..., 6.1..., 6.2..., 6.3..., 6.4... rounds down to 6

and any decimal number 6.5..., 6.6..., 6.7..., 6.8..., 6.9... rounds up to 7

6.5 exactly may be a moot point as it is, of course, exactly half way between 6 and 7, but by convention (I thought) 6.5 rounds up to 7.

I would not expect 5.5 (rounds UP) to behave differently to 6.5 (rounds DOWN).

I suppose that this oddity is because of the conversions to binary. By the way my few brain cells can never actually envisage a decimal in binary but that's just one of my problems.

Any comments on CINT(n.5) always rounding to an even integer?? I suspect that any oddity is in the person writing this!

Programs / 3D Stereo Discs Graphics Program

« on: February 10, 2020, 10:36:28 am »

Back in the days of [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there] (ah, this seems an eternity ago!) I wrote a program which displayed balls in stereoscopic 3D. In the stereo imaging used, the viewer could actually "see" near objects coming right out of the screen and far object set back from the screen. The method used was to alternate red and blue images offset in x- by a stereo angle amount. The program was able to give the stereoscopic behaviour when using Red/Blue 3D glasses.

The method of alternating red and blue images made the viewed image jittery. I tried to synchronise the alternation with screen refresh rate, but nothing I tried would allow the removal of the jitteriness. The project was abandoned incomplete.

What I really wanted to do was to display both the red and the blue images together without the second image overwriting the first. A method to do this is _MEM processing (thanks again to Steve McNeill for his tutorials) where you can simultaneously alter the _RED, _GREEN, _BLUE and _ALHPA parameters of each image picture element.

The program here implements the _MEM method accordingly. There are 10 images of a disc, each of which moves in the x-, y- and z- directions. The displacement of the red and blue (green is not used) images is linearly dependent upon the z- position, and this gives the stereoscopic behaviour. _MAPTRIANGLE(3D) is used to map each image and this handles all the perspective effects (I say, once again, what a marvellous, marvellous QB64 function this is).

If you run this program with Red/Blue 3D glasses (Blue over the right eye), you will see all the normal behaviour of _MAPTRIANGLE(3D), but in addition the discs will appear to move in and out of the screen. Without the glasses you will see red and blue images overlapping (and giving magenta) with red/blue poking out sideways dependent upon z- position.

I realise that this program will have very limited interest: the number of QB64 members is not large, members who have red/blue glasses and who have an interest in such graphics will be a very select group. For this reason I leave the program as a curiosity here in this state (there could be improvements which I will not attempt). The 10 images are formed as separate software objects which are then individually _MEM processed, those images are copied to hardware and then those images displayed and then image-freed. There will be a method to directly address the screen pixels, but this is a skill level beyond my limited ability. It works anyway!

Code: QB64: [Select]

'3D Stereo Discs Graphics Program v1 by Qwerkey 10/02/20
'
 
CONST False = 0, True = NOT False, XScreen% = 1100, YScreen% = 800, PiConst! = 4 * ATN(1), ZOffset% = -620
CONST Xst%% = 5, Stereo! = (5 * 2) / YScreen%, Rad%% = 50, Zf! = 1
'All perspective behaviour handled by _maptriangle(3D), stereo effect x-separation linear with z-
'Software Images (for _MEM processing).  Hardware images for display
 
DIM CMem(9) AS _MEM, COff AS _OFFSET, Balls!(9, 12), SoftImg&(9), HardImg&(9)
RANDOMIZE (TIMER)
 
FOR K%% = 0 TO 9
    Balls!(K%%, 0) = RND * XScreen% / 2
    Balls!(K%%, 1) = RND * YScreen% / 2
    Balls!(K%%, 2) = RND * YScreen% / 2
    Balls!(K%%, 3) = 2 * PiConst! * (RND - 0.5)
    Balls!(K%%, 4) = 2 * PiConst! * (RND - 0.5)
    Balls!(K%%, 5) = 2 * PiConst! * (RND - 0.5)
    Balls!(K%%, 6) = 0.007 + RND * 0.02
    IF RND > 0.5 THEN Balls!(K%%, 6) = -Balls!(K%%, 6)
    Balls!(K%%, 7) = 0.007 + RND * 0.02
    IF RND > 0.5 THEN Balls!(K%%, 7) = -Balls!(K%%, 7)
    Balls!(K%%, 8) = 0.007 + RND * 0.02
    IF RND > 0.5 THEN Balls!(K%%, 8) = -Balls!(K%%, 8)
    Balls!(K%%, 9) = Stereo! * Balls!(K%%, 2) * SIN(Balls!(K%%, 5))
    SoftImg&(K%%) = _NEWIMAGE(2 * (Rad%% + Xst%%) + 1, 2 * Rad%% + 1, 32)
    CMem(K%%) = _MEMIMAGE(SoftImg&(K%%))
    FOR N% = 0 TO 2 * (Rad%% + Xst%%)
        FOR M% = 0 TO 2 * Rad%%
            COff = 4 * (N% + M% * 2 * (Rad%% + Xst%%) + 1) + CMem(K%%).OFFSET
            _MEMPUT CMem(K%%), COff + 3, 255 AS _UNSIGNED _BYTE
        NEXT M%
    NEXT N%
    HardImg&(K%%) = _COPYIMAGE(SoftImg&(K%%), 33)
NEXT K%%
 
'Screen (Hardware Only)
SCREEN _NEWIMAGE(XScreen%, YScreen%, 32)
_SCREENMOVE 20, 5
_DEST 0
_DISPLAYORDER _HARDWARE
'Checking off in fully working
$CHECKING:OFF
 
WHILE INKEY$ = ""
    _LIMIT 30
 
    FOR K%% = 0 TO 9
        Balls!(K%%, 3) = PiBand!(Balls!(K%%, 3) + Balls!(K%%, 6))
        Balls!(K%%, 4) = PiBand!(Balls!(K%%, 4) + Balls!(K%%, 7))
        Balls!(K%%, 5) = PiBand!(Balls!(K%%, 5) + Balls!(K%%, 8))
        Balls!(K%%, 9) = Stereo! * Balls!(K%%, 2) * SIN(Balls!(K%%, 5))
        FOR N% = 0 TO 2 * (Rad%% + Xst%%)
            FOR M% = 0 TO 2 * Rad%%
                COff = 4 * (N% + M% * (2 * (Rad%% + Xst%%) + 1)) + CMem(K%%).OFFSET
                _MEMPUT CMem(K%%), COff + 3, 0 AS _UNSIGNED _BYTE 'Alpha - first set all pixels to transparent
                Q0% = N% - (Rad%% + Xst%% + Balls!(K%%, 9))
                Q1% = M% - Rad%%
                IF SQR(Q0% * Q0% + Q1% * Q1%) <= Rad%% THEN
                    _MEMPUT CMem(K%%), COff + 2, 255 AS _UNSIGNED _BYTE 'Red
                    _MEMPUT CMem(K%%), COff + 3, 255 AS _UNSIGNED _BYTE
                ELSE
                    _MEMPUT CMem(K%%), COff + 2, 0 AS _UNSIGNED _BYTE 'Red
                END IF
                Q0% = N% - (Rad%% + Xst%% - Balls!(K%%, 9))
 
                IF SQR(Q0% * Q0% + Q1% * Q1%) <= Rad%% THEN
                    _MEMPUT CMem(K%%), COff, 255 AS _UNSIGNED _BYTE 'Blue
                    _MEMPUT CMem(K%%), COff + 3, 255 AS _UNSIGNED _BYTE
                ELSE
                    _MEMPUT CMem(K%%), COff, 0 AS _UNSIGNED _BYTE 'Blue
                END IF
            NEXT M%
        NEXT N%
        HardImg&(K%%) = _COPYIMAGE(SoftImg&(K%%), 33)
        Zpos! = Balls!(K%%, 2) * SIN(Balls!(K%%, 5)) * Zf! + ZOffset%
        X1! = Balls!(K%%, 0) * SIN(Balls!(K%%, 3)) + Rad%% + Xst%%
        X0! = Balls!(K%%, 0) * SIN(Balls!(K%%, 3)) - (Rad%% + Xst%%)
        Y1! = Balls!(K%%, 1) * SIN(Balls!(K%%, 4)) - Rad%%
        Y0! = Balls!(K%%, 1) * SIN(Balls!(K%%, 4)) + Rad%%
        _MAPTRIANGLE (0, 0)-(2 * (Rad%% + Xst%%), 0)-(0, 2 * Rad%%), HardImg&(K%%) TO(X0!, Y0!, Zpos!)-(X1!, Y0!, Zpos!)-(X0!, Y1!, Zpos!)
        _MAPTRIANGLE (2 * (Rad%% + Xst%%), 2 * Rad%%)-(0, 2 * Rad%%)-(2 * (Rad%% + Xst%%), 0), HardImg&(K%%) TO(X1!, Y1!, Zpos!)-(X0!, Y1!, Zpos!)-(X1!, Y0!, Zpos!)
        _FREEIMAGE HardImg&(K%%)
    NEXT K%%
    _DISPLAY
 
WEND
SYSTEM
 
FUNCTION PiBand! (PiAngle!)
    SELECT CASE PiAngle!
        CASE IS < -_PI
            PiBand! = PiAngle! + _PI(2)
        CASE IS > _PI
            PiBand! = PiAngle! - _PI(2)
        CASE ELSE
            PiBand! = PiAngle!
    END SELECT
END FUNCTION
 

Programs / Palindromic Dates

« on: February 05, 2020, 07:48:48 am »

Apparently February 2nd was "International Palindrome Day" because the date was 02/02/2020. Luckily this is palindromic in both British configuration (DD/MM/YYYY) and American configuration (MM/DD/YYYY).

So I thought that I'd find out which dates have been palindromic. The program gives a list of palindromic dates from year 0 to 2100. British date configuration is used, but you can easily adapt it to American configuration. A text file is created as well as print to screen as there are, not surprisingly, quite a few such dates.

Code: QB64: [Select]

'Palindromic Dates (British Date Configuration DDMMYYYY) 05/02/2020 by Qwerkey
'02022020 was palindromic
'Do up to 2100 (assuming gregorian calendar goes back to zero)
 
CONST False = 0, True = NOT False
 
DIM Months%%(12)
FOR N%% = 1 TO 12
    READ Months%%(N%%)
NEXT N%%
 
OPEN "palindate.txt" FOR OUTPUT AS #1
 
Day%% = 1
Month%% = 1
Year% = 0
 
WHILE Year% < 2101
    Palin$ = DayMonth$(Day%%) + DayMonth$(Month%%) + Annus$(Year%)
    IF IsPalindromic%%(Palin$) THEN
        PRINT Palin$
        PRINT #1, Palin$
    END IF
    Day%% = Day%% + 1
    IF Day%% > Months%%(Month%%) THEN
        Day%% = 1
        Month%% = Month%% + 1
        IF Month%% > 12 THEN
            Month%% = 1
            Year% = Year% + 1
            'Modification for leap years:
            IF Year% \ 4 = Year% / 4 THEN
                Months%%(2) = 29
                IF Year% \ 400 = Year% / 400 THEN Months%%(2) = 28
            ELSE
                Months%%(2) = 28
            END IF
        END IF
    END IF
WEND
 
CLOSE #1
 
FUNCTION IsPalindromic%% (P$)
    IsPalindromic%% = True
    M%% = 1
    WHILE M%% <= 4 AND IsPalindromic%%
        IF MID$(P$, M%%, 1) <> MID$(P$, 9 - M%%, 1) THEN IsPalindromic%% = False
        M%% = M%% + 1
    WEND
END FUNCTION
 
FUNCTION DayMonth$ (M%%)
    S$ = LTRIM$(STR$(M%%))
    IF M%% < 10 THEN
        DayMonth$ = "0" + S$
    ELSE
        DayMonth$ = S$
    END IF
END FUNCTION
 
FUNCTION Annus$ (Y%)
    A$ = LTRIM$(STR$(Y%))
    IF Y% < 10 THEN
        Annus$ = "000" + A$
    ELSEIF Y% < 100 THEN
        Annus$ = "00" + A$
    ELSEIF Y% < 1000 THEN
        Annus$ = "0" + A$
    ELSE
        Annus$ = A$
    END IF
END FUNCTION
 
DATA 31,28,31,30,31,30,31,31,30,31,30,31
 

QB64 Discussion / Using _MEM to set screen pixels (Question for Steve McNeill)

« on: January 28, 2020, 09:56:55 am »

Steve, I'm about to start a project where I will put images to the screen using _MEM processing. I'll view again your videos 1&2 to remind myself of the exact methods to change the RGB values of individual pixels. But I'm wondering when the actual screen gets updated with the new values. If I were using _HARDWARE imaging, I'd have a _DISPLAY at every processing loop to update the screen, but I assume that _DISPLAY is not required (and is inappropriate) for _MEM screen methods. Do I just set the _LIMIT value of my program to whatever is required for the correct processing rate and the screen will get updated at the computer/screen refresh rate, ie we leave the graphics setting at the default _AUTODISPLAY? - Qwerkey's dim question of the week no. 20,348!

Pages: 1 2 [3] 4 5 ... 8

News:

Show Posts

Topics - Qwerkey

QB64 Discussion / Call for Samples and Games

SUB _GL / 3D Knots by Ashish

SUB _GL / 3D : Sierpinski Cube by Ashish

SUB _GL / 3D Double Pendulum by Ashish

SUB _GL / OpenGL Lights & Material by Ashish

2D/3D Graphics / Lissajous Curve Table by FellippeHeitor

Games / Battleship with AI by bplus

SUB _GL / Moving into the Matrix Rain by Ashish

Games / Hunter's Revenge by Ashish

General, Math & Geometry / Dropping Balls by bplus

QB64 Discussion / Samples Gallery

QB64 Discussion / CINT Oddity (and Slightly Incorrect _ROUND Wiki?)

Programs / 3D Stereo Discs Graphics Program

Programs / Palindromic Dates

QB64 Discussion / Using _MEM to set screen pixels (Question for Steve McNeill)