PureBasic

Code : Tout sélectionner

InitSprite()
InitMouse()
InitKeyboard()
Global win=OpenWindow(#PB_Any,0,0,800,600,"") ; CPC screen
OpenWindowedScreen(WindowID(win),0,16,640,400)
Declare getmem(ID)
Declare putmem(ID,mem)
Declare.i decode(cpc,mode) ; decode(adresse memoire de l'image brute , mode graphique de l'image)
;
file$="KRAUSCH.ECR" ; nom du fichier
size=FileSize(file$)
*mem=AllocateMemory(size)
rf=ReadFile(#PB_Any,file$)
If rf<>0
  ReadData(rf,*mem,size)
  CloseFile(rf)
EndIf;

pic=decode(*mem,0) 
StartDrawing(ScreenOutput())
  DrawImage(ImageID(pic),0,0,640,400)
  StopDrawing()
 
  FlipBuffers()
  Repeat
    ev=WaitWindowEvent()
  Until ev=#PB_Event_CloseWindow 
;
Procedure.i decode(cpc,mode) ; cpc = adresse memoire du fichier SCR brut, mode d'affichage
Select mode
Case 0
  rezpix=2 ; pixels par octets
  surface=CreateImage(#PB_Any,160,200,32)
Case 1
  rezpix=4
  surface=CreateImage(#PB_Any,320,200,32)
Case 2
  rezpix=8
  surface=CreateImage(#PB_Any,640,200,32)
EndSelect
Dim pen(16)                ; crayons
Dim palette(26)            ; palette de l'amstrad
;---------------------------------------detecte le format de pixels RGB ou BRG------------------------
StartDrawing(ImageOutput(surface))
rgbrg=DrawingBufferPixelFormat() % 32768
If DrawingBufferPixelFormat() > 32768
  reverse = 1
Else
  reverse = 0
EndIf
StopDrawing() 
;---------------------------------------------palette en format rgb----------------------------------------------
  RGB$="0000000000800000ff8000005000508000ffff0000ff0080ff00ff0080000080800080ff8080008080805050ffFF8000FF8080FF80FF00FF0000FF8000FFFF80FF0080FF8080FFFFFFFF00FFFF80FFFFFF" ; palette Amstrad
;---------------------------------------------lis la palette dans le tableau palette------------------------
For c=0 To 26 ; pour chaque couleur possible
  Select rgbrg ; on selectionne le bon format
  Case #PB_PixelFormat_32Bits_RGB ; RGB
    palette(c)=RGB(Val("$"+Mid(RGB$,c*6+1,2)),Val("$"+Mid(RGB$,c*6+3,2)),Val("$"+Mid(RGB$,c*6+5,2))) ;RGB           
  Case #PB_PixelFormat_32Bits_BGR  ;BGR       
    palette(c)=RGB(Val("$"+Mid(RGB$,c*6+5,2)),Val("$"+Mid(RGB$,c*6+3,2)),Val("$"+Mid(RGB$,c*6+1,2)));BRG
  EndSelect
Next 
;-----------------------------------------------------------------------------------------------------------
pen$="01242006260002081012141618220305"
For pen =0 To 15
   pen(pen)=palette(Val(Mid(pen$,pen*2+1,2)))
Next
*surf_mem=getmem(surface)
iw=ImageWidth(surface)
ih=ImageHeight(surface) 
y=0
For blocs=0 To 24 ; blocs de lignes
  pos=128+blocs*$50 ; header amsdos = 128 bits
  For yy=0 To 7     ; pour les 8 lignes du bloc courant
    For x=0 To 79   ; on lis les 80 octets
      o=PeekB(cpc+pos)&$ff ; non signés
      For pix=0 To rezpix-1 ;  decoupe l'octet suivant le nombre de pixels a lire
        Select mode         ; suivant le mode grraphique de l'image
          Case 0            ; mode 0 160x200 16 couleurs : 2 pixels par octets ( 4 bit par pixel )                       
                            ;c1=Val("%"+Mid(b$,7+pix,1)+Mid(b$,5+pix,1)+Mid(b$,3+pix,1)+Mid(b$,1+pix,1)) ; pixels courant ( interleaved)
            Select pix
                Case 0
                  c1=((o & %10000000 )>>7)+((o & %00100000 )>>4)+((o & %00001000 )>>1)+((o & %00000010 ))<<2
                Case 1                  
                  c1=((o & %01000000)>>6)+((o & %00010000)>>3)+((o & %00000100))+((o & %00000001)<<3)
            EndSelect           
          Case 1            ; mode 1 320x200 4 couleurs : 4 pixels par octets (2 bits par pixel)
            Select pix
                Case 0
                  c1=((o & %10000000)>>7+(o & %00001000)>>2)
                Case 1
                  c1=((o & %01000000)>>6+(o & %00000100)>>1)
                Case 2
                  c1=((o & %00100000)>>5+(o & %00000010))
                Case 3
                  c1=(o & %00000001)<<1+(o & %00010000)>>4
            EndSelect
          Case 2            ; mode 2 640,200 2 couleurs : 8 pixels par octets (1 bit par pixel)           
            c1=(o & (128 >> pix))>>(7-pix)
        EndSelect
        If reverse=1 ; si le flag reverse est a un ( l'image tete en bas en memoire)
          PokeL(*surf_mem+(((x*rezpix+pix)*4))+((ih-1-y)*iw*4),pen(c1)) ; pixel courant est ecrit suivant la couleur
        Else
          PokeL(*surf_mem+(((x*rezpix+pix)*4))+((y)*iw*4),pen(c1))      ; pixel courant est ecrit suivant la couleur   
        EndIf
      Next 
      pos+1   
    Next
    pos+$800-$50 ; on se positionne au debut de la ligne suivante en memoire
    y+1
  Next
Next
putmem(surface,*surf_mem)
ProcedureReturn surface
EndProcedure
Procedure getmem(ID) ; copie une image dans la memoire pour y effectuer des operations avec peek et poke :)
   ImageID=  ImageID(id)
   Hdc = CreateCompatibleDC_ ( GetDC_ ( ImageID ))
   If HDC
      bmi.BITMAPINFO
      bm.BITMAP
      GetObject_ ( ImageID , SizeOf(BITMAP), @bm.BITMAP)
      bmi\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
      bmi\bmiheader\biWidth = bm\bmWidth
      bmi\bmiheader\biHeight = bm\bmHeight
      bmi\bmiheader\biPlanes = 1
      bmi\bmiheader\biBitCount = 32
      bmi\bmiheader\biCompression = #BI_RGB
      HList = AllocateMemory (bm\bmWidth*bm\bmHeight*4)
      GetDIBits_ (hDC, ImageID ,0,bm\bmHeight,HList,bmi, #DIB_RGB_COLORS )    
      ProcedureReturn HList
   EndIf   
EndProcedure
Procedure putmem(id,mem) ;copie une zone memoire dans une image existante
   ImageID=  ImageID(id)
   Hdc = CreateCompatibleDC_ ( GetDC_ ( ImageID ))
   If HDC
      bmi.BITMAPINFO
      bm.BITMAP
      GetObject_ ( ImageID , SizeOf(BITMAP), @bm.BITMAP)
      bmi\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
      bmi\bmiheader\biWidth = bm\bmWidth
      bmi\bmiheader\biHeight = bm\bmHeight
      bmi\bmiheader\biPlanes = 1
      bmi\bmiheader\biBitCount = 32
      bmi\bmiheader\biCompression = #BI_RGB
      SetDIBits_ (hDC, ImageID ,0,bm\bmHeight,mem,bmi, #DIB_RGB_COLORS )          
   EndIf
EndProcedure