Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Is it possible that?
#11
@vince I see your mod and raise you a mod Big Grin
Code: (Select All)
_Title "vince rot xmas tree w star mod b+" ' 2024-02-16
Dim Shared pi, sw, sh, d, z0, p, q
pi = 4 * Atn(1)
d = 700
z0 = 2500

sw = 800
sh = 600

Dim As Double a, b, x, y, z, xx, yy, zz, r2
Screen _NewImage(sw, sh, 32)
Dim As _Unsigned Long clr
'tree
Color , &HFF000000
Cls
For a = 0 To 20 * 2 * pi Step 0.1
    x = 5 * a * Cos(a)
    y = -a * 10
    z = 5 * a * Sin(a)

    yy = (y + 350) * Cos(b) - z * Sin(b)
    zz = (y + 350) * Sin(b) + z * Cos(b)
    y = yy - 350
    z = zz

    xx = x * Cos(b) - z * Sin(b)
    zz = x * Sin(b) + z * Cos(b)
    x = xx
    z = zz

    xx = x * Cos(b) - (y + 350) * Sin(b)
    yy = x * Sin(b) + (y + 350) * Cos(b)
    x = xx
    y = yy - 350

    proj x, y, z
    If a = 0 Then PSet (p, q), _RGB(0, 155, 0) Else Line -(p, q), _RGB(0, 155, 0)
    If Rnd > .9 Then
        clr = _RGB32(100 + Rnd * 155, (Rnd < .35) * -255, (Rnd < .35) * -255)
        For r2 = 0 To 5 Step .25
            Circle (p, q), r2, clr
        Next
    End If
Next

' star stuff
sx = 400: sy = 120
Dim Shared top&
top& = _NewImage(64, 64, 32) ' copy tree top wo star
_PutImage , 0, top&, (sx - 32, sy - 32)-(sx + 32, sy + 32)
Dim TheStar&
TheStar& = _NewImage(64, 64, 32)
_Dest TheStar&
For ir = 9 To 0 Step -1
    star 32, 32, ir, 30, 5, 0, _RGB32(100 + (10 - ir) * 15, 200 + (10 - ir) * 5, (10 - ir) * 20)
Next
_Dest 0
dx = .02: dy = .1: rot = 0
xscale = 1: yscale = 1
While _KeyDown(27) = 0
    _PutImage (sx - 32, sy - 32)-(sx + 32, sy + 32), top&, 0
    xscale = xscale + dx
    If xscale > 1 Then xscale = 1: dx = -dx
    If xscale < .2 Then xscale = .2: dx = -dx
    yscale = yscale + dy
    If yscale > 1 Then yscale = 1: dy = -dy
    If yscale < .2 Then yscale = .2: dy = -dy
    RotoZoom23r sx, sy, TheStar&, xscale, yscale, rot
    rot = rot + pi / 60
    _Limit 30
Wend

Sub proj (x, y, z)
    p = sw / 2 + x * d / (z + z0)
    q = sh / 2 - (100 + y) * d / (z + z0) - 150
End Sub
Sub star (x, y, rInner, rOuter, nPoints, angleOffset, K As _Unsigned Long)
    ' x, y are same as for circle,
    ' rInner is center circle radius
    ' rOuter is the outer most point of star
    ' nPoints is the number of points,
    ' angleOffset = angle offset IN DEGREES, it will be converted to radians in sub
    ' this is to allow us to spin the polygon of n sides
    Dim pAngle, radAngleOffset, x1, y1, x2, y2, x3, y3, i As Long

    pAngle = _D2R(360 / nPoints): radAngleOffset = _D2R(angleOffset)
    x1 = x + rInner * Cos(radAngleOffset)
    y1 = y + rInner * Sin(radAngleOffset)
    For i = 0 To nPoints - 1
        x2 = x + rOuter * Cos(i * pAngle + radAngleOffset + .5 * pAngle)
        y2 = y + rOuter * Sin(i * pAngle + radAngleOffset + .5 * pAngle)
        x3 = x + rInner * Cos((i + 1) * pAngle + radAngleOffset)
        y3 = y + rInner * Sin((i + 1) * pAngle + radAngleOffset)
        FillTriangle x1, y1, x2, y2, x3, y3, K
        'triangles leaked
        Line (x1, y1)-(x2, y2), K
        Line (x2, y2)-(x3, y3), K
        Line (x3, y3)-(x1, y1), K
        x1 = x3: y1 = y3
    Next
    Paint (x, y), K, K
End Sub
Sub FillTriangle (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    $Checking:Off
    Static a&, m As _MEM
    If a& = 0 Then a& = _NewImage(1, 1, 32): m = _MemImage(a&)
    _MemPut m, m.OFFSET, K
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    $Checking:On
End Sub
' best  rev 2023-01-20 Jarvis with Steve change for eff  might need _Seamless next to _MapTriangle calls
Sub RotoZoom23r (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, radRotation As Single)
    'uses radians
    Dim As Long W, H, Wp, Hp, i, x2, y2
    Dim sinr!, cosr!
    Dim px(3) As Single: Dim py(3) As Single
    W& = _Width(Image&): H& = _Height(Image&)
    Wp& = W& / 2 * xScale
    Hp& = H& / 2 * yScale
    px(0) = -Wp&: py(0) = -Hp&: px(1) = -Wp&: py(1) = Hp&
    px(2) = Wp&: py(2) = Hp&: px(3) = Wp&: py(3) = -Hp&
    sinr! = Sin(-radRotation): cosr! = Cos(radRotation)
    For i& = 0 To 3
        ' x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY
        x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
        px(i&) = x2&: py(i&) = y2&
    Next ' _Seamless? below
    _MapTriangle (0, 0)-(0, H& - 1)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
    _MapTriangle (0, 0)-(W& - 1, 0)-(W& - 1, H& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub

   
b = b + ...
Reply
#12
Nice mods, vince and bplus! Thanks for sharing them!

vince, I had to add color depth to the Screen statement to get yours working, ie:
Screen _NewImage(sw, sh, 32)
Without the ,32 I'd get "illegal function call" in the first circle line: Circle (p, q), 1, _RGB(0, 155, 0)

(Edit) As mentioned in the next two posts:
You have to add the ,32 if you copy/paste the code into the QB64PE IDE in Windows (haven't tried it on Mac or Linux yet, but probably the same for them).
It works without the ,32 if you run the code here in the forum (QBJS).
Reply
#13
(02-17-2024, 11:21 AM)Abazek Wrote: Nice mods, vince and bplus! Thanks for sharing them!

vince, I had to add color depth to the Screen statement to get yours working, ie:
Screen _NewImage(sw, sh, 32)
Without the ,32 I'd get "illegal function call" in the first circle line: Circle (p, q), 1, _RGB(0, 155, 0)

I had same reaction when I copy pasted vince code to QB64pe IDE, WTH? happened to the screen!!!

Yes, QBJS is not exactly the same as QB64pe but tantalizingly close! Smile
b = b + ...
Reply
#14
Just for clarity, vince’s mod will work with the additional _newimage parameter as well, but it is not required.
Reply
#15
This thread of discussion kind of veered away from the OP a bit, eh?

(02-14-2024, 02:39 PM)gaslouk Wrote:
(02-14-2024, 02:17 PM)gaslouk Wrote: SCREEN 13
COLOR 6 * 2 + 3, 0 - 5 + 8 * 2 - 11
CLS
FOR I = 0 TO 70 STEP 0.1
    PSET (I * COS(I) + 140, 20 - I * (SIN(I) * 0.2 - 2))
NEXT
LINE (136, 20)-(140, 12)
LINE -(144, 20): LINE -(134, 16)
LINE -(146, 16): LINE -(136, 20)
A$ = INPUT$(1)

Is this really possible?

(02-14-2024, 02:36 PM)bplus Wrote: Not this?
Code: (Select All)
Screen 13
Color 2
PSet (140 + Cos(0), 20)
For I = 0 To 70 Step 0.1
    Line -(I * Cos(I) + 140, 20 - I * (Sin(I) * 0.2 - 2))
Next
Color 14
Line (136, 20)-(140, 12)
Line -(144, 20): Line -(134, 16)
Line -(146, 16): Line -(136, 20)
A$ = Input$(1)

Big Grin

I mean this

COLOR 6 * 2 + 3, 0 - 5 + 8 * 2 - 11 

How this is really possible.

The parameters of the COLOR statement, expressions are allowed.  

I don't know what BASIC dialects/implementations allow only literal values and which allow expressions.
Reply
#16
Goto line numbers don't work with expressions in QB64pe but do work in some other usually older BASICs. ZXDunny's SpecBas is one for sure.
b = b + ...
Reply




Users browsing this thread: 1 Guest(s)