12-14-2022, 07:02 PM
A goofy little seasonal graphics demo. Uses some of the techniques I've been using in my sprite mixer programs and puts them to use.
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