Author Topic: Modern Sun Dial  (Read 989 times)

B+

  • Guest
Modern Sun Dial
« on: September 01, 2017, 09:04:06 PM »
I may have learned how to draw the landscape at BP.org, maybe a mod Aurel's code? It's been awhile!

Code: [Select]
'Sunburst 3.bas for QB64 fork (B+=MGA) 2017-09-01
'spiral rays anyone?  throw in the kitchen clock too...

RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600
COMMON SHARED cN, pR, pG
SCREEN _NEWIMAGE(xmax, ymax, 32)
_TITLE "Modern Sun Dial by bplus, press spacebar for new view"

'set working variables
midx = xmax / 2
cN = 1
horizon = ymax / 2
maxd = ((xmax - midx) ^ 2 + (ymax - horizon) ^ 2) ^ .5
switch = -1
WHILE 1
    land& = _NEWIMAGE(xmax, ymax, 32)
    _DEST land&
    drawLandscape
    _DEST 0
    switch = NOT switch
    WHILE 1
        CLS
        IF _KEYHIT = 32 THEN EXIT WHILE
        resetPlasma
        _PUTIMAGE , land&, 0
        IF switch THEN
            FOR a = 0 TO _PI(2) STEP _PI(1 / 36)
                IF a = 0 THEN
                    lastx = midx + maxd * COS(a)
                    lasty = horizon + maxd * SIN(a)
                ELSE
                    x1 = midx + maxd * COS(a)
                    y1 = horizon + maxd * SIN(a)
                    changePlasma
                    filltri midx, horizon, lastx, lasty, x1, y1
                    lastx = x1: lasty = y1
                END IF
            NEXT
        END IF
        radius = 0: angle = sangle
        WHILE radius < 400
            x = COS(angle) * radius
            y = SIN(angle) * radius
            r2 = (x ^ 2 + y ^ 2) ^ .5
            size = 4 * r2 ^ .25
            angle = angle - .4
            radius = radius + 2
            COLOR _RGBA(200 + RND * 55, 255, 0, 30)
            sx = midx + 5 * COS(angle + _PI(1 / 2))
            sy = horizon + 5 * SIN(angle + _PI(1 / 2))
            sx1 = midx + 5 * COS(angle - _PI(1 / 2))
            sy1 = horizon + 5 * SIN(angle - _PI(1 / 2))
            filltri sx, sy, sx1, sy1, midx + x, horizon + y
        WEND
        sangle = sangle + _PI(1 / 18)
        IF switch THEN
            FOR r = 25 TO 0 STEP -1
                COLOR _RGBA(255, 255, 205, (25 - r) ^ 2 / 2.45)
                fillcirc midx, horizon, r
            NEXT
        END IF

        now$ = TIME$
        min = VAL(MID$(now$, 4, 2)) / 60
        h = VAL(MID$(now$, 1, 2)) + min
        IF h > 12 THEN h = h - 12
        hourA = h * _PI(1 / 6) - _PI(1 / 2)
        minA = min * _PI(2) - _PI(1 / 2)

        COLOR _RGBA(255, 255, 255, 48)
        sx = midx + 5 * COS(hourA + _PI(1 / 2))
        sy = horizon + 5 * SIN(hourA + _PI(1 / 2))
        sx1 = midx + 5 * COS(hourA - _PI(1 / 2))
        sy1 = horizon + 5 * SIN(hourA - _PI(1 / 2))
        filltri sx, sy, sx1, sy1, midx + 150 * COS(hourA), horizon + 150 * SIN(hourA)


        sx = midx + 5 * COS(minA + _PI(1 / 2))
        sy = horizon + 5 * SIN(minA + _PI(1 / 2))
        sx1 = midx + 5 * COS(minA - _PI(1 / 2))
        sy1 = horizon + 5 * SIN(minA - _PI(1 / 2))
        filltri sx, sy, sx1, sy1, midx + 250 * COS(minA), horizon + 250 * SIN(minA)

        _DISPLAY
        _LIMIT 1
    WEND
WEND

SUB changePlasma ()
    cN = cN + 1
    COLOR _RGBA(200 + 56 * SIN(pR * cN), 200 + 56 * SIN(pG * cN), 128, RND * 32)
END SUB

SUB resetPlasma ()
    pR = RND ^ 2: pG = RND ^ 2
END SUB

SUB midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    COLOR _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
END SUB

FUNCTION rand% (lo%, hi%)
    rand% = (RND * (hi% - lo% + 1)) \ 1 + lo%
END FUNCTION

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fillcirc (CX AS LONG, CY AS LONG, R AS LONG)
    DIM subRadius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG

    subRadius = ABS(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    LINE (CX - X, CY)-(CX + X, CY), , 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), , BF
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            END IF
            X = X - 1
            RadiusError = RadiusError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    WEND
END SUB

'Andy Amaya's triangle fill modified for QB64
SUB filltri (xx1, yy1, xx2, yy2, xx3, yy3)
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3

    'triangle coordinates must be ordered: where x1 < x2 < x3
    IF x2 < x1 THEN SWAP x1, x2: SWAP y1, y2
    IF x3 < x1 THEN SWAP x1, x3: SWAP y1, y3
    IF x3 < x2 THEN SWAP x2, x3: SWAP y2, y3
    IF x1 <> x3 THEN slope1 = (y3 - y1) / (x3 - x1)

    'draw the first half of the triangle
    length = x2 - x1
    IF length <> 0 THEN
        slope2 = (y2 - y1) / length
        FOR x = 0 TO length
            LINE (INT(x + x1), INT(x * slope1 + y1))-(INT(x + x1), INT(x * slope2 + y1))
            lastx% = INT(x + x1)
        NEXT
    END IF

    'draw the second half of the triangle
    y = length * slope1 + y1: length = x3 - x2
    IF length <> 0 THEN
        slope3 = (y3 - y2) / length
        FOR x = 0 TO length
            IF INT(x + x2) <> lastx% THEN
                LINE (INT(x + x2), INT(x * slope1 + y))-(INT(x + x2), INT(x * slope3 + y2))
            END IF
        NEXT
    END IF
END SUB

SUB drawLandscape
    'the sky
    FOR i = 0 TO ymax
        midInk 50, 25, 128, 100, 200, 255, i / ymax
        LINE (0, i)-(xmax, i)
    NEXT
    'the land
    startH = ymax - 200
    rr = 70: gg = 70: bb = 90
    FOR mountain = 1 TO 6
        Xright = 0
        y = startH
        WHILE Xright < xmax
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            upDown = (RND * .8 - .35) * (mountain * .5)
            range = Xright + rand%(15, 25) * 2.5 / mountain
            lastx = Xright - 1
            FOR X = Xright TO range
                y = y + upDown
                COLOR _RGB(rr, gg, bb)
                LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
                lastx = X
            NEXT
            Xright = range
        WEND
        rr = rand%(rr - 15, rr): gg = rand%(gg - 15, gg): bb = rand%(bb - 25, bb)
        IF rr < 0 THEN rr = 0
        IF gg < 0 THEN gg = 0
        IF bb < 0 THEN bb = 0
        startH = startH + rand%(5, 20)
    NEXT
END SUB

« Last Edit: September 01, 2017, 09:08:17 PM by B+ »