/*******************************************************************
 Particle Engine by Paddy Long
 Written Summer 2003 - Revised Winter 2003

 Requirements
 var colrs : flexible array 0 .. 0 of int
 --before using colrs must set size to maximum life
 new colrs, highLife
 --colrs must be turned into gradient array...
 Gradient.make (colrs, colour1, colour2, highLife)

 particleSystem -> make (x, y, howMany, Velocity, lowLife, highLife, lowAngle, highAngle, lowVelocity, highVelocity : int, newColours : array 1 .. * of string) parameters
 x - starting x location of system
 y - starting y location of system
 howMany - how many particles
 Velocity - the speed the system moves
 lowLife - the minimum life of individual particles
 highLife - the maximum life of individual particles
 lowAngle - the angle of individual particles from the system's angle of movement
 highAngle - the angle of individual particles from the system's angle of movement
 lowVelocity - the minimum speed of individual particles
 highVelocity - the maximum speed of individual
 newColours - an array of any size (lower bound of 1) of RGB colour strings in format "RRR,GGG,BBB" (numbers don't have to be 3 digits)
 *******************************************************************/

class particle
    export make, update

    var loc : array 1 .. 2 of int
    var age, lifeSpan, angle, velocity : int
    var colrs : flexible array 0 .. 0 of int

    function random (value1, value2 : int) : int
        if value2 > value1 then
            result Rand.Int (value1, value2)
        else
            result Rand.Int (value2, value1)
        end if
    end random


    procedure stringRGB2realRGB (stringRGB : string, var realRGB : array 1 .. 3 of real)
        var RGBstring : string := ""
        var RGBselect : int := 1
        for q : 1 .. length (stringRGB)
            if stringRGB (q) not= "," then
                RGBstring += stringRGB (q)
            elsif stringRGB (q) = "," then
                realRGB (RGBselect) := strreal (RGBstring) / 255
                RGBselect += 1
                RGBstring := ""
            end if
        end for
        realRGB (RGBselect) := strreal (RGBstring) / 255
    end stringRGB2realRGB

    procedure makeGradient (var colrs : array 0 .. * of int, colours : array 1 .. * of string)
        type real3array : array 1 .. 3 of real

        var colrsPer : int := ceil (upper (colrs) / (upper (colours) - 1))
        var numGrads : int := upper (colours) - 1
        var rColours : array 1 .. upper (colours) of real3array
        var increments : array 1 .. numGrads, 1 .. 3 of real
        var colrArrays : array 1 .. numGrads, 1 .. colrsPer of int
        var currColr : real3array
        var currColrCount : int := 0

        for q : 1 .. upper (colours)
            stringRGB2realRGB (colours (q), rColours (q))
        end for

        for q : 1 .. numGrads
            for w : 1 .. 3
                increments (q, w) := (rColours (q + 1) (w) - rColours (q) (w)) / colrsPer
            end for

            for w : 1 .. colrsPer
                for e : 1 .. 3
                    currColr (e) := rColours (q) (e) + (increments (q, e) * w)
                end for

                colrArrays (q, w) := RGB.AddColor (currColr (1), currColr (2), currColr (3))
            end for
        end for

        for q : 1 .. numGrads
            for w : 1 .. colrsPer
                exit when currColrCount > upper (colrs)
                colrs (currColrCount) := colrArrays (q, w)
                currColrCount += 1
            end for
            exit when currColrCount > upper (colrs)
        end for

        for q : 256 .. upper (colrs) by 256
            colrs (q) := colrs (q - 1)
        end for
        colrs (0) := RGB.AddColor (rColours (1) (1), rColours (1) (2), rColours (1) (3))
        colrs (upper (colrs)) := RGB.AddColor (rColours (upper (rColours)) (1), rColours (upper (rColours)) (2), rColours (upper (rColours)) (3))
    end makeGradient


    procedure make (orig, lifeRange, angleRange, velocityRange : array 1 .. 2 of int, colours : array 1 .. * of string)
        angle := random (angleRange (1), angleRange (2))
        velocity := random (velocityRange (1), velocityRange (2))
        lifeSpan := random (lifeRange (1), lifeRange (2))
        age := 0
        new colrs, lifeSpan

        makeGradient (colrs, colours)

        loc (1) := orig (1)
        loc (2) := orig (2)

        drawdot (loc (1), loc (2), colrs (age))
    end make

    procedure update (orig, lifeRange, angleRange, velocityRange : array 1 .. 2 of int, colours : array 1 .. * of string)
        drawdot (loc (1), loc (2), whatcolourback)
        if age < lifeSpan then
            loc (1) += round (velocity * cosd (angle))
            loc (2) += round (velocity * sind (angle))
            drawdot (loc (1), loc (2), colrs (age))
            age += 1
        else
            make (orig, lifeRange, angleRange, velocityRange, colours)
        end if
    end update
end particle

class particleSystem
    import particle
    export make, start, stop, getAngleRange, setAngleRange, getVelRange, setVelRange, getLifeRange, setLifeRange, getOrig, setOrig, getVelocity, setVelocity, setColours

    var orig, angleRange, velRange, lifeRange : array 1 .. 2 of int
    var particles : flexible array 1 .. 1 of ^particle
    var partCount, velocity : int
    var colours : flexible array 1 .. 1 of string
    var going : boolean

    function random (value1, value2 : int) : int
        if value2 > value1 then
            result Rand.Int (value1, value2)
        else
            result Rand.Int (value2, value1)
        end if
    end random

    procedure make (x, y, howMany, Velocity, lowLife, highLife, lowAngle, highAngle, lowVelocity, highVelocity : int, newColours : array 1 .. * of string)
        var currAngle, currVel : int
        orig (1) := x
        orig (2) := y
        partCount := howMany
        velocity := Velocity
        angleRange (1) := lowAngle
        angleRange (2) := highAngle
        velRange (1) := lowVelocity
        velRange (2) := highVelocity
        lifeRange (1) := lowLife
        lifeRange (2) := highLife

        new colours, upper (newColours)
        for q : 1 .. upper (newColours)
            colours (q) := newColours (q)
        end for

        new particles, howMany
        for q : 1 .. howMany
            new particles (q)
            particles (q) -> make (orig, lifeRange, angleRange, velRange, colours)
        end for
    end make

    function getAngleRange : array 1 .. 2 of int
        result angleRange
    end getAngleRange
    procedure setAngleRange (newLow, newHigh : int)
        angleRange (1) := newLow
        angleRange (2) := newHigh
    end setAngleRange

    function getVelRange : array 1 .. 2 of int
        result velRange
    end getVelRange
    procedure setVelRange (newLow, newHigh : int)
        velRange (1) := newLow
        velRange (1) := newHigh
    end setVelRange

    function getLifeRange : array 1 .. 2 of int
        result lifeRange
    end getLifeRange
    procedure setLifeRange (newLow, newHigh : int)
        lifeRange (1) := newLow
        lifeRange (2) := newHigh
    end setLifeRange

    function getOrig : array 1 .. 2 of int
        result orig
    end getOrig
    procedure setOrig (newX, newY : int)
        orig (1) := newX
        orig (2) := newY
    end setOrig

    function getVelocity : int
        result velocity
    end getVelocity
    procedure setVelocity (newVel : int)
        velocity := newVel
    end setVelocity

    procedure setColours (newColours : array 1 .. * of string)
        new colours, upper (newColours)
        for q : 1 .. upper (newColours)
            colours (q) := newColours (q)
        end for
    end setColours

    process go
        var currAngle, currVel : int
        loop
            currAngle := (angleRange (1) + angleRange (2)) div 2
            orig (1) -= round (cosd (currAngle)) * velocity
            orig (2) -= round (sind (currAngle)) * velocity

            if orig (1) >= maxx then
                orig (1) := maxx
            elsif orig (1) <= 0 then
                orig (1) := 0
            end if
            if orig (2) >= maxy then
                orig (2) := maxy
            elsif orig (2) <= 0 then
                orig (2) := 0
            end if

            for q : 1 .. partCount
                particles (q) -> update (orig, lifeRange, angleRange, velRange, colours)
            end for
            View.Update
            exit when going = false
            delay (25)
        end loop
    end go

    procedure start
        going := true
        fork go
    end start
    procedure stop
        going := false
    end stop
end particleSystem

var window : int := Window.Open ("graphics:1000;1000,title:Particle Engine by Paddy Long - 2003,offscreenonly")

var debug : boolean := true

color (0)
colorback (7)
cls

var mx, my, button, clickCount : int

var pSys : ^particleSystem

var x, y, howMany, Velocity, lowLife, highLife, lowAngle, highAngle, lowVelocity, highVelocity : int
var colours : flexible array 1 .. 2 of string

x := maxx div 2
y := maxy div 2
howMany := 500
Velocity := 2
lowLife := 10
highLife := 20
lowAngle := 1
highAngle := 45
lowVelocity := 5
highVelocity := 10
colours (1) := "255,255,255"
colours (2) := "0,0,0"

clickCount := 0

procedure goTo (x, y : int)
    var angle : int
    if x > pSys -> getOrig () (1) then
        angle := 180 + round (arctand ((y - pSys -> getOrig () (2)) / (x - pSys -> getOrig () (1))))
    elsif x < pSys -> getOrig () (1) then
        angle := round (arctand ((y - pSys -> getOrig () (2)) / (x - pSys -> getOrig () (1))))
    elsif x = pSys -> getOrig () (1) or y = pSys -> getOrig () (2) then
        angle := 0
    end if
    pSys -> setAngleRange (angle - 10, angle + 10)
end goTo

new pSys
pSys -> make (x, y, howMany, Velocity, lowLife, highLife, lowAngle, highAngle, lowVelocity, highVelocity, colours)
pSys -> start
loop
    Mouse.Where (mx, my, button)
    if debug = true then
        locate (1, 1)
        put intstr (mx) + "/" + intstr (my) + "/" + intstr (button) + "//" + intstr (clickCount)
    end if

    goTo (mx, my)
    if button = 1 then
        clickCount += 1
        if clickCount = 1 then
            new colours, 3
            colours (1) := "255,0,0"
            colours (2) := "255,255,255"
            colours (3) := "0,0,0"
            pSys -> setLifeRange (20, 30)
        elsif clickCount = 2 then
            new colours, 4
            colours (1) := "0,255,0"
            colours (2) := "255,0,0"
            colours (3) := "255,255,255"
            colours (4) := "0,0,0"
            pSys -> setLifeRange (30, 40)
        elsif clickCount = 3 then
            new colours, 5
            colours (1) := "0,0,255"
            colours (2) := "0,255,0"
            colours (3) := "255,0,0"
            colours (4) := "255,255,255"
            colours (5) := "0,0,0"
            pSys -> setLifeRange (40, 50)
        elsif clickCount = 4 then
            new colours, 2
            colours (1) := "255,255,255"
            colours (2) := "0,0,0"
            clickCount := 0
            pSys -> setLifeRange (10, 20)
        end if
        pSys -> setColours (colours)
    end if
    delay (100)
end loop