Merry Xelfmas !!! - Printable Version

Code: (Select All)
'XELFMAS

'By James D. Jarvis December 2022

'This program uses BASIMAGE coded by Dav for QB64GL 1.4, MAY/2020

'

'A jumble of christmas elves and a terribe little festive song

'pres <esc> to quit

'

Randomize Timer

Dim Shared ms&

ms& = _NewImage(800, 600, 32)

Screen ms&

_Title "X E L F M A S"

Dim Shared part&

Dim Shared kk1 As _Unsigned Long

Dim Shared kk2 As _Unsigned Long

Dim Shared kk3 As _Unsigned Long

Dim Shared kk4 As _Unsigned Long

Dim Shared kk5 As _Unsigned Long

Dim Shared kk6 As _Unsigned Long



Dim Shared clr~&

part& = BASIMAGE1&



Type elfbits_type

    legs As Integer

    boots As Integer

    top As Integer

    gloves As Integer

    face As Integer

    hat As Integer

End Type

Type balls

    bx As Integer

    by As Integer

    klr As _Unsigned Long

    d As Integer

End Type

Type anelf

    i As Long

    ex As Single

    ey As Single

    rot As Single

    ss As Single

End Type

Dim Shared elf_limit

elf_limit = 80

Dim Shared ball(30) As balls

Dim Shared elook(elf_limit) As elfbits_type

Dim Shared elf(elf_limit) As anelf

_Source part&

'read the colors from the color reference bar whichever color is in the top left corner will be transparent

clr~& = Point(0, 0) 'find background color of image

_Dest part&

Line (0, 0)-(0, 8), clr~& 'erase the color reference bar from the bit map

_ClearColor clr~&, ms& 'set background color as transparent                  not using it in this program

_ClearColor clr~&, part&

_Source ms&

_Dest ms&

_FullScreen _SquarePixels

Color , _RGB32(250, 250, 250)

Cls

For b = 1 To 30

    ball(b).bx = Int(Rnd * _Width)

    ball(b).by = Int(Rnd * _Height)

    Select Case Int(Rnd * 6)

        Case 0

            ball(b).klr = _RGB32(50 + Rnd * 150, 50 + Rnd * 150, 50 + Rnd * 150)

        Case 1

            ball(b).klr = _RGB32(50 + Rnd * 50, 0, 0)

        Case 2

            ball(b).klr = _RGB32(0, 50 + Rnd * 50, 0)

        Case 3

            ball(b).klr = _RGB32(0, 0, 50 + Rnd * 50)

        Case 4

            ball(b).klr = _RGB32(50 + Rnd * 50, 0, 50 + Rnd * 50)

        Case 5

            ball(b).klr = _RGB32(50 + Rnd * 50, 50 + Rnd * 50, 0)

    End Select

    ball(b).d = Int(20 + Rnd * 40)

Next b



For e = 1 To 80

    elf(e).i = _NewImage(32, 32, 32)

Next e

mmx = 0: mmy = 0

For m = 1 To elf_limit

    'create a new set of weapon sprites

    elook(m).legs = Int(1 + Rnd * 6)

    elook(m).boots = Int(1 + Rnd * 6)

    elook(m).top = Int(1 + Rnd * 6)

    elook(m).gloves = Int(1 + Rnd * 6)

    elook(m).face = Int(1 + Rnd * 6)

    elook(m).hat = Int(1 + Rnd * 6)

    make_elf mmx, mmy, m, elf(m).i

    elf(m).ex = Int(Rnd * _Width)

    elf(m).ey = Int(Rnd * _Height)

    elf(m).rot = 0

    elf(m).ss = 1

    ' RotoZoom2 elf(m).ex, elf(m).ey, elf(m).i, elf(m).ss, elf(m).ss, elf(m).rot

Next m

s1$ = "MB O3 L4  GEDCG GGGEDCA AFED B, GGFDE GEDCG GEDC A A AFED , GGGG A G F D C  E E E    E E E E G C D "

s2$ = " O4 L4  GEDCG GGGEDCA AFED B, GGFDE GEDCG GEDC A A AFED , GGGG A G F D C  E E E    E E E E G C D "

s3$ = " O3 L4 MS GEDCG GGGEDCA AFED B, GGFDE GEDCG GEDC A A AFED , GGGG A G F D C  E E E    E E E E G C D "

s4$ = " O2 L4 MS GEDCG GGGEDCA AFED B, GGFDE GEDCG GEDC A A AFED , GGGG A G F D C  E E E    E E E E G C D "

Play s1$ + s2$ + s3$ + s4$

'Hmmm.... I've gotten pretty bad at reading music, sorry

Do

    _Limit 30

    Cls

    For b = 1 To 30

        cball ball(b).bx, ball(b).by, ball(b).d, ball(b).klr

        Select Case Int(Rnd * 100)

            Case 1

                ball(b).bx = ball(b).bx + 2

            Case 2

                ball(b).bx = ball(b).bx - 2

            Case 3

                ball(b).by = ball(b).by + 2

            Case 4

                ball(b).by = ball(b).by - 2

            Case 5

                ball(b).d = ball(b).d - 2

            Case 6

                ball(b).d = ball(b).d + 2

        End Select

    Next b

    mmx = 0: mmy = 0

    For m = 1 To elf_limit

        RotoZoom2 elf(m).ex, elf(m).ey, elf(m).i, elf(m).ss, elf(m).ss, elf(m).rot

        Select Case Int(1 + Rnd * 200)

            Case 1 To 20

                elf(m).ex = elf(m).ex + Int(Rnd * 16)

            Case 21 To 40

                elf(m).ex = elf(m).ex - Int(Rnd * 16)

            Case 41 To 45

                elf(m).rot = elf(m).rot + 2

            Case 46 To 50

                elf(m).rot = elf(m).rot - 2

            Case 51 To 70

                elf(m).ey = elf(m).ey + Int(Rnd * 16)

            Case 71 To 90

                elf(m).ey = elf(m).ey - Int(Rnd * 16)

            Case 91

                elf(m).ss = elf(m).ss + .05

            Case 92

                elf(m).ss = elf(m).ss - .05

            Case Else

                'nothing happens here

        End Select

        If elf(m).ey < -16 Then elf(m).ey = _Height - 8

        If elf(m).ex < -16 Then elf(m).ex = _Width - 8

        If elf(m).ey > _Height + 16 Then elf(m).ey = 0

        If elf(m).ex > _Width + 16 Then elf(m).ex = 0

    Next m

    _Display

    kk$ = InKey$

Loop Until kk$ = Chr$(27)

_FreeImage part&



For e = 1 To 80

    _FreeImage elf(e).i

Next e

System

Sub make_elf (Mx, my, mid, ii As Long)

    tempi& = _NewImage(32, 32, 32)

    _Source part&

    _ClearColor Point(0, 0), tempi&

    _Dest tempi&

    Color , clr~&

    _PutImage (0, 0)-(31, 31), part&, tempi&, ((elook(mid).legs - 1) * 32, 0)-((elook(mid).legs - 1) * 32 + 31, 31)

    _PutImage (0, 0)-(31, 31), part&, tempi&, ((elook(mid).boots - 1) * 32, 32)-((elook(mid).boots - 1) * 32 + 31, 32 + 31)

    _PutImage (0, 0)-(31, 31), part&, tempi&, ((elook(mid).top - 1) * 32, 64)-((elook(mid).top - 1) * 32 + 31, 64 + 31)

    _PutImage (0, 0)-(31, 31), part&, tempi&, ((elook(mid).gloves - 1) * 32, 96)-((elook(mid).gloves - 1) * 32 + 31, 96 + 31)

    _PutImage (0, 0)-(31, 31), part&, tempi&, ((elook(mid).face - 1) * 32, 128)-((elook(mid).face - 1) * 32 + 31, 128 + 31)

    _PutImage (0, 0)-(31, 31), part&, tempi&, ((elook(mid).hat - 1) * 32, 160)-((elook(mid).hat - 1) * 32 + 31, 160 + 31)

    _Source tempi&

    _PutImage (Mx, my)-(Mx + 31, my + 31), tempi&, ii

    _Source ms&

    _Dest ms&

    _FreeImage tempi&

End Sub



Sub RotoZoom2 (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single)

    Dim px(3) As Single: Dim py(3) As Single

    W& = _Width(Image&): H& = _Height(Image&)

    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(-(0.01745329 * Rotation)): cosr! = Cos(-(0.01745329 * Rotation))

    For i& = 0 To 3

        x2& = (px(i&) * cosr! + sinr! * py(i&)) * xScale + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) * yScale + centerY

        px(i&) = x2&: py(i&) = y2&

    Next

    _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



Sub cball (CX As Long, CY As Long, R As Long, C As _Unsigned Long)

    Dim kl As _Unsigned Long

    kl = C

    rr = _Red(kl)

    bb = _Blue(kl)

    gg = _Green(kl)

    For d = R To (R - Int(R / 2)) Step -1

        fcirc CX, CY, d, _RGB32(rr, bb, gg)

        rr = rr + Int(1 + Rnd * 2)

        gg = gg + Int(1 + Rnd * 2)

        bb = bb + Int(1 + Rnd * 2)

    Next d

End Sub

Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)

    Dim Radius As Long, RadiusError As Long

    Dim X As Long, Y As Long

    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0

    If Radius = 0 Then PSet (CX, CY), C: 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

'================================

'PNG file saved using BASIMAGE1&

'================================

Function BASIMAGE1& 'xelfs.png

    v& = _NewImage(192, 192, 32)

    Dim m As _MEM: m = _MemImage(v&)

    A$ = ""

    A$ = A$ + "haIkM7VLSZ[460eIAj=YgTlNaE8G\R48<ZUH`7Zj<VPMhCZE3clS9TYkCCC`7Z_nj[Q?6PQIj4<6P1if]73O<0Sbg_<ja0<:g?1S1HD^mhf`73``lmO<ja0<"

    A$ = A$ + "8?LoO00000000000000^XnnWGVe4MnOooGke<b\kaHHdeo=o01Wom=4MniZemZnGZ?[7mOefk7me0S\nod;=S[L\0\E_O?^6XDM^gmokimJI^SnJPCCoO]7_"

    A$ = A$ + "AZ]g?j[16IoobNaJ?N[cemooIWJ?NSU6gF77^BVg]fS3000000000000000000000000000000WBYKKMloUc?gijMb_USYd\FkHA_6Dka_Hnj[_NZfSo?Kn5"

    A$ = A$ + "F?gMn]^_H:ci<gaRBYLjDnUnmKD_nmOg8joGNN[=oF<FbUeNVo=]VTK[Vg[Een]>oINoFf?\e_O_RngoGc[UK]n7ae1YWkJb_ESQLWgJc?TonXTN\=O_6<oC"

    A$ = A$ + "g_dl_dWoXFfG_Em?Z[16Io_lGojk#_^[`iO[lKM_OJFU6SUnn0000000000000P?LYKAL^KEn1<6Olhf;^Deo=TncJb8noJl]oO=OYN=7OGkO]]e5]mo]TfS"

    A$ = A$ + "o^>Bmoi`^5_n^iGIoakNNfZonXmo_ke7EeC?EgWkmjoWfOAK[Ch>of6MooLmmX_NTnoQLo_ko]onXRJn_\6knoG_kooYfoGC=I^fNdiJnnoeNoB3`gllEY8k"

    A$ = A$ + "gcE[W[_7meS\VT^^FCON;k5>3mmkiJPFWGemnKM=#3dcnoBenijmJ_6I=XegWO_jMonIKn_m0<^\7MoocIO=_fQeodOFgkMoOjFGjo[M;dl_W4BjaR;oAgoO"

    A$ = A$ + "6^oolfcWe2If?d\__hil`DQmk`LOc=iO=cOaHh??[CjAfg7Lo?LFT^=ja300000000000000000000`e`d59SoAMO^f4A=J:9S]b_USQ5W_ebog<3<o\WgY:"

    A$ = A$ + "n<=ZnoW\FHniWC4?7MZiLokk5hl?Gn_la2>ooTe98oGf^W\O[b>mLG:oFWM5ITn\\:ZnoBITmIYE0coeVSoYD5#nIkm:UO;73I>MkYo8bN_ROV0Zo[MnkMoo"

    A$ = A$ + "J_ODcoZjmW[EADocUe98oGf^W\O[b>mLG:oFWM5ITfG4monWchmoce[4Aog^kGJMogI<oYT?C;c>]nWVE6AfoglNUAN>100000000000000000n0mm;WQcaW"

    A$ = A$ + "\SDoDk?N]oXeoS^6<jeoc#n;[SKm]Tkki:YViODIm>eoS>VFnUc?g4:macmn]\6<RlcF?o9[UiV;ZFf;DcJODi>jlcEoWFi[KmhHijl_?OBbTOJogE9odePJ"

    A$ = A$ + "ZoAf3<?GGFGTOli_\okUn\YGOfjLEcO?T_l_BiW>F^Mka_7JNo8cKilJ>cUFnN]^6T;oBelN\6lKMonSWjaJn8GoW]lnk?GgoIn?WOD?k6;FoGdk5mjmNc_U"

    A$ = A$ + "SWUOiFiWnI_2eoAWOjc]`Bi7mc`dBm4m\f?ZlCcH]lkehiCZnGjJPIm\g7>3VgMdS3H4VgMdS3H4VgMdS3000000000000000hLkn:nMkM>go\mha]W:miVO"

    A$ = A$ + "oL>Dn[XHNAG_Wn_jjZ_>heoND7b^=hiMTmoYmI[eggSnoUS]imkA=oidISG7ijOdinBmnW]N_6\J?OPckZjikdJ`Wjmo7ejobJ`;gKK:iHGlioIYoO^VoYMo"

    A$ = A$ + "oc`jo_ekOfn4^oobioIXoO4IGcoVCgo?f\[JKTI7iHXVaaE]nO6bOdeoAJ_KSNl200000000000000000000000#Fo?0=48A%%%0"

    btemp$ = ""

    For i& = 1 To Len(A$) Step 4: B$ = Mid$(A$, i&, 4)

        If InStr(1, B$, "%") Then

            For C% = 1 To Len(B$): F$ = Mid$(B$, C%, 1)

                If F$ <> "%" Then C$ = C$ + F$

            Next: B$ = C$: End If: For j = 1 To Len(B$)

            If Mid$(B$, j, 1) = "#" Then

        Mid$(B$, j) = "@": End If: Next

        For t% = Len(B$) To 1 Step -1

            B& = B& * 64 + Asc(Mid$(B$, t%)) - 48

            Next: X$ = "": For t% = 1 To Len(B$) - 1

            X$ = X$ + Chr$(B& And 255): B& = B& \ 256

    Next: btemp$ = btemp$ + X$: Next

    btemp$ = _Inflate$(btemp$)

    _MemPut m, m.OFFSET, btemp$: _MemFree m

    BASIMAGE1& = _CopyImage(v&): _FreeImage v&

End Function