Forums PureBasic - Français
https://www.purebasic.fr/french/
Code : Tout sélectionner
;==============================================================================
;== Amstrad CPC Image Decoder
;== Author: Case
;== Version 0.2, 2015-09-05
;==============================================================================
EnableExplicit
Enumeration CPC_Modes
#CPC_MODE_0 ; Mode 0, 160x200x16, 2 pixels/byte, 4 bit/pixel
#CPC_MODE_1 ; Mode 1, 320x200x04, 4 pixels/byte, 2 bit/pixel
#CPC_MODE_2 ; Mode 2, 640x200x02, 8 pixels/byte, 1 bit/pixel
EndEnumeration
Procedure ReadFileToMemory(fileName.s)
Protected id.i, size.i, *buf
size = FileSize(fileName)
If size > 0
id = ReadFile(#PB_Any, fileName)
If id
*buf = AllocateMemory(size)
If *buf
ReadData(id, *buf, size)
EndIf
CloseFile(id)
EndIf
EndIf
ProcedureReturn *buf
EndProcedure
Procedure CPC_LoadImage(fileName.s, mode.i)
Protected a, b, c, d, x, y, w, h
Protected *buf, img, blocs, pos, res
Protected Dim pen(16), Dim palette(26)
*buf = ReadFileToMemory(fileName)
If *buf
Restore CPC_Palette
For a = 0 To 26
Read.l palette(a)
Next
Restore CPC_Pen
For a = 0 To 15
Read.b b
pen(a) = palette(b)
Next
Select mode
Case 0: res = 2 : w = 160 : h = 200
Case 1: res = 4 : w = 320 : h = 200
Case 2: res = 8 : w = 640 : h = 200
EndSelect
img = CreateImage(#PB_Any, w, h)
If img And StartDrawing(ImageOutput(img))
For blocs = 0 To 24
pos = 128 + blocs * 80
For c = 0 To 7
For x = 0 To 79
b = PeekB(*buf + pos) & $FF
For a = 0 To res - 1
Select mode
Case #CPC_MODE_0
Select a
Case 0: d = ((b & %10000000) >> 7) + ((b & %00100000) >> 4) +
((b & %00001000) >> 1) + ((b & %00000010) << 2)
Case 1: d = ((b & %01000000) >> 6) + ((b & %00010000) >> 3) +
((b & %00000100) ) + ((b & %00000001) << 3)
EndSelect
Case #CPC_MODE_1
Select a
Case 0: d = ((b & %10000000) >> 7) + ((b & %00001000) >> 2)
Case 1: d = ((b & %01000000) >> 6) + ((b & %00000100) >> 1)
Case 2: d = ((b & %00100000) >> 5) + ((b & %00000010) )
Case 3: d = ((b & %00000001) << 1) + ((b & %00010000) >> 4)
EndSelect
Case #CPC_MODE_2
d = ( b & ( 128 >> a ) ) >> ( 7 - a )
EndSelect
Box(x * res, y, res, 1, pen(d))
Next
pos + 1
Next
pos + $800 - 80
y + 1
Next
Next
StopDrawing()
EndIf
FreeMemory(*buf)
EndIf
ProcedureReturn img
EndProcedure
;==============================================================================
; Example d'utilisation
;==============================================================================
Define img = CPC_LoadImage("KRAUSCH.ECR", #CPC_MODE_0)
If img
If OpenWindow(0, 100, 100, ImageWidth(img), ImageHeight(img), "Amstrad CPC")
ImageGadget(0, 0, 0, ImageWidth(img), ImageHeight(img), ImageID(img))
Repeat
Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf
EndIf
End
;==============================================================================
; CPC Pens and Palette
;==============================================================================
DataSection
CPC_Pen:
Data.b 01, 24, 20, 06, 26, 00, 02, 08
Data.b 10, 12, 14, 16, 18, 22, 03, 05
CPC_Palette:
Data.l $000000, $800000, $FF0000
Data.l $000080, $500050, $FF0080
Data.l $0000FF, $8000FF, $FF00FF
Data.l $008000, $808000, $FF8000
Data.l $008080, $808080, $FF5050
Data.l $0080FF, $8080FF, $FF80FF
Data.l $00FF00, $80FF00, $FFFF00
Data.l $00FF80, $80FF80, $FFFF80
Data.l $00FFFF, $80FFFF, $FFFFFF
EndDataSection
;==============================================================================
; End of file
;==============================================================================
Code : Tout sélectionner
;==============================================================================
;== Amstrad CPC Image Decoder
;== Version 0.5, 2015-09-06
;== Author: Case, Flype
;==============================================================================
DeclareModule CPC
Declare LoadSCR(fileName.s, mode.i)
EndDeclareModule
Module CPC
Structure Longs
l.Long[0]
EndStructure
Prototype Decode(*a, x, y, w)
Procedure Decode0(*a, x, y, w)
Protected b = PeekB(*a+((y&7)<<11)+(y>>3)*80+(x>>2))
If (x&2)=0 : b>>1 : EndIf
ProcedureReturn ((b&1)<<3)+((b>>2)&4)+((b>>1)&2)+((b>>6)&1)
EndProcedure
Procedure Decode1(*a, x, y, w)
Protected b = PeekB(*a+((y&7)<<11)+(y>>3)*80+(x>>2))>>(~x&3)
ProcedureReturn ((b>>3)&2)+(b&1)
EndProcedure
Procedure Decode2(*a, x, y, w)
ProcedureReturn (PeekB(*a+((y&7)<<11)+(((y>>3)*w+x)>>3))>>(~x&7))&1
EndProcedure
Procedure Decode(mode.i, *a, *b.Longs, *c.Longs)
Protected x, y, w, h, i, d.Decode
Select mode
Case 0: w = 320 : h = 200 : d = @Decode0()
Case 1: w = 320 : h = 200 : d = @Decode1()
Case 2: w = 640 : h = 200 : d = @Decode2()
EndSelect
i = CreateImage(#PB_Any, w, h)
If i
If StartDrawing(ImageOutput(i))
For y = 0 To h - 1
For x = 0 To w - 1
Plot(x, y, *b\l[*c\l[d(*a, x, y, w)]\l]\l)
Next
Next
StopDrawing()
EndIf
EndIf
ProcedureReturn i
EndProcedure
Procedure LoadSCR(fileName.s, mode.i)
Protected f, l, i, *m
l = FileSize(fileName)
If l > 0
f = ReadFile(#PB_Any, fileName)
If f
*m = AllocateMemory(l)
If *m
If ReadData(f, *m, l)
i = Decode(mode, *m + 128, ?CPC_Palette, ?CPC_Pen)
EndIf
FreeMemory(*m)
EndIf
CloseFile(f)
EndIf
EndIf
ProcedureReturn i
EndProcedure
DataSection ;{
CPC_Pen:
Data.l 1, 24, 20, 6, 26, 0, 2, 8, 10, 12, 14, 16, 18, 22, 3, 5
CPC_Palette:
Data.l $0000,$800000,$FF0000,$0080,$800080,$FF0080,$00FF,$8000FF,$FF00FF
Data.l $8000,$808000,$FF8000,$8080,$808080,$FF5050,$80FF,$8080FF,$FF80FF
Data.l $FF00,$80FF00,$FFFF00,$FF80,$80FF80,$FFFF80,$FFFF,$80FFFF,$FFFFFF
EndDataSection ;}
EndModule
;==============================================================================
Define file$ = "KRAUSCH.ECR"
Define image = CPC::LoadSCR(file$, 0)
If image
Define w = ImageWidth(image) * 1
Define h = ImageHeight(image) * 1
ResizeImage(image, w, h, #PB_Image_Raw)
If OpenWindow(0, 100, 100, w, h, file$)
ImageGadget(0, 0, 0, w, h, ImageID(image))
Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf
EndIf
;==============================================================================
Merci pour cette imahe j'ai joué souvent à ce jeux chez un ami c"était en 1986Frenchy Pilou a écrit :Celui-ci était très potager!
Highway Encounter