home *** CD-ROM | disk | FTP | other *** search
/ The AGA Experience 2 / agavol2.iso / software / utilities / programmers / source / ham8bob / ham8bob.e < prev    next >
Encoding:
Text File  |  1978-06-29  |  3.9 KB  |  163 lines
  1. MODULE    'graphics/gfx','graphics/rastport','graphics/modeid',
  2.     'hardware/blit',
  3.     'intuition/screens','intuition/intuition',
  4.     'tools/ilbm','tools/ilbmdefs'
  5.  
  6. ENUM ERR_NONE,ERR_MEM,ERR_SCREEN,ERR_LIB,ERR_FILE,ERR_PIC
  7.  
  8. CONST NULL=0,TAG_END=0
  9.  
  10. RAISE ERR_MEM  IF AllocMem()=NIL
  11. RAISE ERR_MEM  IF AllocBitMap()=NIL
  12. RAISE ERR_LIB  IF OpenLibrary()=NIL
  13.  
  14. DEF s:PTR TO screen
  15. DEF back:PTR TO bitmap, base:PTR TO bitmap, bob:PTR TO bitmap, maskbmp:PTR TO bitmap, rembmp:PTR TO bitmap
  16. DEF base6:bitmap,pl1:PTR TO LONG,pl2:PTR TO LONG, mask, rem
  17.  
  18. PROC main() HANDLE
  19.         DEF iff=0,i
  20.  
  21.     request('Yo!','Demo will size machine for a while.\nFinish all disk activity.')
  22.  
  23.     IF (s:=OpenScreenTagList(0,[    SA_DEPTH, 8,
  24.                     SA_DISPLAYID, HAM_KEY,
  25.                     SA_TITLE, 'LMB to exit',
  26.                     TAG_END]))=0
  27.         Raise(ERR_SCREEN)
  28.     ENDIF
  29.  
  30.     iff:=newpic('back.h8',ILBMNF_COLOURS32) -> Background to screen
  31.     loadpic(iff,[ILBML_SCREEN, s, TAG_END])
  32.     ilbm_Dispose(iff)
  33.  
  34.     
  35.     -> Silly bug doesn't let you do two loadpic's from one newpic
  36.  
  37.     iff:=newpic('back.h8',ILBMNF_COLOURS32) -> Background 2 mem
  38.     loadpic(iff,[ILBML_GETBITMAP, {back}, TAG_END])
  39.         ilbm_Dispose(iff)
  40.  
  41.     -> Set up a faked 6 plane bitmap to load 64 color background into.
  42.     -> The bitmap really is 8 planes, with the two top planes all zero.
  43.     -> This way, you can blit straight into the ham8 pic (color 32
  44.     -> becomes 'set base color 32').
  45.  
  46.     base:=AllocBitMap(320,256,8,BMF_CLEAR,0)
  47.     base6.bytesperrow:=base.bytesperrow
  48.     base6.rows:=base.rows
  49.     base6.flags:=base.flags
  50.     base6.depth:=6
  51.     pl1:=base6.planes
  52.     pl2:=base.planes
  53.     FOR i:=0 TO 5
  54.         pl1[i]:=pl2[i]
  55.     ENDFOR
  56.     
  57.     
  58.     iff:=newpic('back.64',ILBMNF_COLOURS32) -> 64 color version, same colors
  59.     loadpic(iff,[ILBML_BITMAP, base6, TAG_END])
  60.         ilbm_Dispose(iff)
  61.         
  62.     iff:=newpic('bob.h8',ILBMNF_COLOURS32) -> the bob
  63.     loadpic(iff,[ILBML_GETBITMAP, {bob}, TAG_END])
  64.     ilbm_Dispose(iff)
  65.  
  66.     iff:=newpic('bob.mask',ILBMNF_COLOURS4) -> its mask
  67.     loadpic(iff,[ILBML_GETBITMAP, {maskbmp}, TAG_END])
  68.     ilbm_Dispose(iff)
  69.  
  70.     mask:=maskbmp.planes
  71.     mask:=^mask
  72.  
  73.     iff:=newpic('bob.rem',ILBMNF_COLOURS32) -> right edge mask
  74.     loadpic(iff,[ILBML_GETBITMAP, {rembmp}, TAG_END])
  75.     ilbm_Dispose(iff)
  76.     iff:=0
  77.     
  78.     rem:=rembmp.planes
  79.     rem:=^rem
  80.  
  81.         bounceBob()
  82.  
  83.         Raise(ERR_NONE)
  84.  
  85. EXCEPT
  86.         SELECT exception
  87.         CASE ERR_NONE
  88.     CASE ERR_FILE
  89.         request('Bug','Can''t find file')
  90.         CASE ERR_MEM
  91.                 request('Bug','Out of memory')
  92.         CASE ERR_SCREEN
  93.                 request('Bug','Screen allocation failed')
  94.         CASE ERR_LIB
  95.                 request('Bug','OpenLibrary() failed')
  96.     CASE ERR_PIC
  97.         request('Bug','Couldn''t load one of the pictures')
  98.         DEFAULT
  99.                 request('Bug','Unknown error (!?)')
  100.         ENDSELECT
  101.  
  102.         IF s THEN CloseScreen(s)
  103.         IF iff THEN ilbm_Dispose(iff)
  104.     IF back THEN ilbm_FreeBitMap(back)
  105.     IF base THEN ilbm_FreeBitMap(base)
  106.     IF bob  THEN ilbm_FreeBitMap(bob)
  107.     IF mask THEN ilbm_FreeBitMap(mask)
  108.     IF rem  THEN ilbm_FreeBitMap(rem)
  109.  
  110.         CleanUp(exception)
  111. ENDPROC
  112.  
  113.  
  114. PROC request(title,messy) IS EasyRequestArgs(0,[20,0,title,messy,'OK'],0,0)
  115.  
  116. PROC newpic(a,b)
  117.     DEF retval
  118.  
  119.     IF (retval:=ilbm_New(a,b))=NIL THEN Raise(ERR_FILE)
  120. ENDPROC retval
  121.  
  122. PROC loadpic(a,b)
  123.     DEF retval
  124.  
  125.     IF (retval:=ilbm_LoadPicture(a,b))<>0 THEN Raise(ERR_PIC)
  126. ENDPROC retval
  127.  
  128. PROC bounceBob()
  129.     DEF x=100,y=100,vx=3,vy=2
  130.     
  131.     Disable()
  132.     REPEAT
  133.         killbob(x,y)
  134.         x:=x+vx
  135.         y:=y+vy
  136.         IF x<10  THEN vx:=-vx
  137.         IF x>285 THEN vx:=-vx
  138.         IF y<90  THEN vy:=-vy
  139.         IF y>220 THEN vy:=-vy
  140.         drawbob(x,y)
  141.         REPEAT
  142.         UNTIL Mouse()<>1
  143.         WaitBOVP(s.viewport) -> I know this is horrible, but I'm busywaiting anyways...
  144.     UNTIL Mouse()=2
  145.     Enable()
  146. ENDPROC
  147.  
  148. PROC drawbob(x,y)
  149.     DEF mt
  150.     
  151.     mt:=ABC+ABNC+ANBC
  152.  
  153.     -> Blit bob through mask
  154.     BltMaskBitMapRastPort(bob ,0,0,s.rastport,x,y,32,32,mt,mask)
  155.  
  156.     -> Blit 64-color background through right edge mask
  157.     BltMaskBitMapRastPort(base,0,0,s.rastport,x,y,32,32,mt,rem)
  158. ENDPROC
  159.  
  160. PROC killbob(x,y)
  161.     BltBitMapRastPort(back,x,y,s.rastport,x,y,32,32,ABC+ABNC)
  162. ENDPROC
  163.