home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 058.lha / COLLAGE < prev    next >
Encoding:
Text File  |  1986-11-20  |  8.3 KB  |  437 lines
  1. 'COLLAGE (VERSION 1.0)
  2. 'BY HERMES (PEOPLE LINK)
  3. 'All Rights Reserved
  4. 'Public Domain but not for Sale
  5.  
  6. 'LoadACBM by Carolyn Scheppner
  7.  
  8. 'Various improvements by the author are forthcoming
  9.  
  10. main0:
  11. CLEAR ,25000
  12. CLEAR ,60000&
  13. DIM bPlane&(5), cTabWork%(32), cTabSave%(32), array%(17000)
  14.  
  15. CLS
  16. PALETTE 2,.64,.64,.64
  17. FOR n = 1 TO 69
  18.  FOR m = 1 TO 50
  19.  NEXT m
  20.  LINE (180+n,60+n) - (460-n,120-n),2,b
  21. NEXT n
  22. LINE (184,63) - (456,117),3,b
  23. COLOR 1,2
  24. LOCATE 10,26
  25. PRINT "   HERMES' COLLAGE (V. 1.0)
  26. LOCATE 12,31
  27. PRINT      "All Rights Reserved"
  28. LOCATE 14,27
  29. PRINT "       (October 1986)"
  30. COLOR 1,0
  31. FOR n = 1 TO 8000
  32. NEXT n
  33. CLS
  34. PALETTE 2,0,0,0
  35. II=0
  36. REM - Functions from dos.library                   
  37. DECLARE FUNCTION xOpen&  LIBRARY
  38. DECLARE FUNCTION xRead&  LIBRARY
  39. DECLARE FUNCTION xWrite& LIBRARY
  40. DECLARE FUNCTION IoErr&  LIBRARY
  41. DECLARE FUNCTION AllocMem&() LIBRARY
  42.  
  43. PRINT:PRINT "Looking for bmaps ... ";
  44. LIBRARY "dos.library"
  45. LIBRARY "exec.library"
  46. LIBRARY "graphics.library"
  47. PRINT "found them."
  48.  
  49. Prime:
  50. PRINT             
  51. GetNames:
  52. INPUT "   ACBM FILENAME  ";ACBMname$
  53. IF (ACBMname$ = "") THEN GOTO Prime   
  54.  
  55. First:
  56. REM - Load the ACBM pic
  57. loadError$ = ""
  58. GOSUB LoadACBM
  59. IF loadError$ <> "" THEN GOSUB Mcleanup2
  60.  
  61. Collage:
  62. mx = 0:my = 0
  63. MENU 1,0,1,"PROJECT   "
  64. MENU 1,1,1,"FRAME ON  "
  65. MENU 1,2,0,"FRAME OFF "
  66. MENU 1,3,0,"PASTE     "
  67. MENU 1,4,1,"QUIT      "
  68. MENU 2,0,0,""
  69. MENU 3,0,0,""
  70. MENU 4,0,0,""
  71. MENU ON
  72.  
  73. Here:
  74. ON MENU GOSUB MenuChief
  75. GOTO Here
  76.  
  77. FrameOn: 
  78. ex = mx:ey = my
  79. IF MOUSE(0) = 1 OR MOUSE(0) = 0 GOTO Hello
  80. WHILE MOUSE(0) <> 0
  81.  Undo
  82.  LINE (mx,my) - (ex,ey),,b
  83.  cx = MOUSE(1):cy = MOUSE(2)
  84.  LINE (mx,my) - (cx,cy),,b
  85.  ex = cx:ey=cy 
  86. WEND
  87.  LINE (mx,my) - (ex,ey),,b
  88.  Do
  89.  Hurt = 6 + (ey - my + 1)*2*INT((ex - mx + 16)/16)*iDepth%
  90. IF Hurt > 17000 THEN
  91.  WINDOW 3,"  SYSTEM REQUEST",(50,50) - (194,75),0,2
  92.  PRINT
  93.  PRINT "   SIZE TOO BIG"
  94.  CALL Food
  95.  FOR n = 1 TO 6000
  96.  NEXT n
  97.  WINDOW CLOSE 3
  98.  RETURN
  99. END IF
  100. IF ex > 311 THEN ex = 311
  101. IF ey >= 185 THEN ey = 184 
  102. IF ex < mx OR ey < my THEN
  103.  CALL Food
  104.  RETURN
  105. END IF
  106. IF ex - mx < 5 AND ey - my < 5 THEN
  107.  CALL Food
  108.  RETURN
  109. END IF   
  110. zx = ex - mx:zy = ey - my
  111. ON ERROR GOTO Message    
  112. GET (mx,my) - (ex,ey),array%
  113. WINDOW 3,"HERMES",(mx,my) - (ex,ey),18,2
  114. PUT (0,0),array%,PSET
  115. mx = 0:my = 0
  116. MENU 1,1,0
  117. MENU 1,2,1
  118. MENU 1,3,1
  119. RETURN
  120.  
  121. Message:
  122. WINDOW 3,"  SYSTEM REQUEST",(50,50) - (194,85),0,2
  123. PRINT
  124. PRINT "  NO HEAP SPACE!  "
  125. PRINT
  126. FOR n = 1 TO 6000
  127. NEXT n
  128. WINDOW CLOSE 3
  129. CALL Food
  130. GOSUB FrameOn
  131.  
  132. SUB Food STATIC
  133. MENU 1,1,1
  134. MENU 1,2,0
  135. MENU 1,3,0
  136. END SUB
  137.  
  138. SUB Undo STATIC
  139.  CALL SetDrMd&(WINDOW(8),3)
  140. END SUB
  141.  
  142. SUB Do STATIC
  143.  CALL SetDrMd&(WINDOW(8),1)
  144. END SUB
  145.      
  146. Hello:
  147. WHILE MOUSE(0) = 0
  148. IF MENU(1) = 4 THEN GOSUB Wrapup
  149. WEND
  150. mx = MOUSE(1):my = MOUSE(2)
  151. GOTO FrameOn
  152. RETURN
  153.  
  154. Paster:
  155. IF Wp > 0 GOTO There
  156. IF MOUSE(0) = 1 GOTO HiThere
  157. IF MOUSE(0) <> 0 THEN
  158.  WINDOW CLOSE 3
  159.  Wp = Wp + 1
  160.  mx = 0:my = 0
  161. END IF
  162.  
  163. There:
  164. WINDOW OUTPUT 2
  165. IF mx > 0 OR my > 0 THEN   
  166.  PUT (mx,my),array%,PSET
  167.  Wp = 0
  168.  IF my - 9 < 0 THEN my - 9 = 0
  169.  IF my + zy - 9 >= 185 THEN my + zy - 9 = 184
  170.  IF mx + zx > 311 THEN mx + zx = 311
  171.  WINDOW 3,"HERMES",(mx,my-9) - (mx+zx,my+zy-9),18,2
  172.  PUT (0,0),array%,PSET
  173.  mx = 0:my = 0 
  174.  RETURN
  175. END IF
  176.  
  177. HiThere:  
  178. WHILE MOUSE(0) = 0:WEND
  179. mx = MOUSE(1):my = MOUSE(2)
  180. GOTO Paster
  181. RETURN
  182.  
  183. Shut:
  184. WINDOW CLOSE 2
  185. WINDOW CLOSE 3
  186. SCREEN CLOSE 2
  187.  
  188. MenuChief:
  189. menuID = MENU(0)
  190. itemID = MENU(1)
  191. ON menuID GOSUB Projects
  192. RETURN
  193.  
  194. Projects:
  195. ON itemID GOSUB FrameOn,FrameOff,Paster,Wrapup
  196. RETURN
  197.  
  198. FrameOff:
  199. CALL Food
  200. WINDOW CLOSE 3
  201. RETURN
  202.  
  203. Wrapup:
  204. WINDOW CLOSE 3
  205. WINDOW CLOSE 2
  206. SCREEN CLOSE 2
  207. MENU RESET
  208. CLEAR ,25000
  209. END
  210. RETURN
  211.  
  212. LoadACBM:
  213. REM - Requires the following variables
  214. REM - to have been initialized:
  215. REM -    ACBMname$ (ACBM filespec)
  216.  
  217. REM - init variables
  218. f$ = ACBMname$
  219. fHandle& = 0
  220. mybuf& = 0
  221. foundBMHD = 0
  222. foundCMAP = 0
  223. foundCAMG = 0
  224. foundCCRT = 0
  225. foundABIT = 0
  226.  
  227.  
  228. filename$ = f$ + CHR$(0)
  229. fHandle& = xOpen&(SADD(filename$),1005)
  230. IF fHandle& = 0 THEN
  231.    PRINT
  232.    loadError$ = "   CAN'T OPEN/FIND PICTURE FILE"
  233.    GOTO Lcleanup
  234. END IF
  235.  
  236.  
  237. REM - Alloc ram for work buffers
  238. ClearPublic& = 65537&
  239. mybufsize& = 360
  240. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  241. IF mybuf& = 0 THEN
  242.    PRINT
  243.    loadError$ = "   CAN'T ALLOC BUFFER"
  244.    GOTO Lcleanup
  245. END IF
  246.  
  247. inbuf& = mybuf&
  248. cbuf& = mybuf& + 120
  249. ctab& = mybuf& + 240
  250.  
  251.  
  252. REM - Should read  FORMnnnnACBM
  253. rLen& = xRead&(fHandle&,inbuf&,12)
  254. tt$ = ""
  255. FOR kk = 8 TO 11
  256.    tt% = PEEK(inbuf&+kk)
  257.    tt$ = tt$ + CHR$(tt%)
  258. NEXT
  259.  
  260. IF tt$ <> "ACBM" THEN
  261.    PRINT 
  262.    loadError$ = "   NOT AN ACBM PICTURE FILE"
  263.    GOTO Lcleanup
  264. END IF
  265.  
  266. REM - Read ACBM chunks
  267.  
  268. ChunkLoop:
  269. REM - Get Chunk name/length
  270.  rLen& = xRead&(fHandle&,inbuf&,8)
  271.  icLen& = PEEKL(inbuf& + 4)
  272.  tt$ = ""
  273.  FOR kk = 0 TO 3
  274.     tt% = PEEK(inbuf& + kk)
  275.     tt$ = tt$ + CHR$(tt%)
  276.  NEXT   
  277.     
  278. IF tt$ = "BMHD" THEN  'BitMap header 
  279.    foundBMHD = 1
  280.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  281.    iWidth%  = PEEKW(inbuf&)
  282.    iHeight% = PEEKW(inbuf& + 2)
  283.    iDepth%  = PEEK(inbuf& + 8)  
  284.    iCompr%  = PEEK(inbuf& + 10)
  285.    scrWidth%  = PEEKW(inbuf& + 16)
  286.    scrHeight% = PEEKW(inbuf& + 18)
  287.  
  288.    iRowBytes% = iWidth% /8
  289.    scrRowBytes% = scrWidth% / 8
  290.    nColors%  = 2^(iDepth%)
  291.  
  292.    REM - Enough free ram to display ?
  293.    AvailRam& = FRE(-1)
  294.    'PRINT AvailRam&
  295.    NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
  296.    'PRINT NeededRam&
  297.    IF AvailRam& < NeededRam& THEN
  298.       loadError$ = " Not enough free ram. "
  299.       GOTO Lcleanup
  300.    END IF
  301.  
  302.    kk = 1
  303.    IF scrWidth% > 320 THEN kk = kk + 1
  304.    IF scrHeight% > 200  THEN kk = kk + 2
  305.    IF iDepth% = 4 AND scrWidth% = 400 THEN
  306.    Q$ = "H"
  307.    GOTO Winds
  308.    END IF
  309.    IF iDepth% = 4 THEN
  310.    Q$ = "M"
  311.    GOTO Winds
  312.    END IF
  313.    IF iDepth% = 5 THEN
  314.    Q$ = "L"
  315.    END IF
  316.    
  317.    Winds:
  318.    SCREEN 2,scrWidth%,scrHeight%,iDepth%,kk
  319.    IF scrWidth% = 320 AND scrHeight% = 200 THEN 
  320.    wwid% = 311
  321.    GOTO Winds1
  322.    END IF
  323.    IF scrWidth% = 320 THEN wwid% = 311
  324.    IF scrWidth% = 640 THEN wwid% = 631
  325.    Winds1:
  326.    WINDOW 2,"",(0,0) - (wwid%,scrHeight%-15),16,2
  327.    REM - Get addresses of structures
  328.    GOSUB GetScrAddrs
  329.  
  330.    blackout:
  331.    REM - Black out screen
  332.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  333.   
  334. ELSEIF tt$ = "CMAP" THEN  'ColorMap
  335.    foundCMAP = 1
  336.    rLen& = xRead&(fHandle&,cbuf&,icLen&)
  337.  
  338.    REM - Build Color Table
  339.    ColorLoop:
  340.  
  341.    FOR kk = 0 TO nColors% - 1
  342.       
  343.       red% = PEEK(cbuf&+(kk*3))
  344.       gre% = PEEK(cbuf&+(kk*3)+1)
  345.       blu% = PEEK(cbuf&+(kk*3)+2)
  346.      
  347.    Major:
  348.       regTemp% = (red%*16)+gre%+(blu%/16)
  349.       POKEW(ctab&+(2*kk)),regTemp%
  350.    NEXT
  351.    
  352.  
  353. ELSEIF tt$ = "CAMG" THEN 'Amiga ViewPort Modes
  354.    foundCAMG = 1
  355.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  356.    camgModes& = PEEKL(inbuf&)
  357.  
  358. ELSEIF tt$ = "ABIT" THEN  'Contiguous BitMap 
  359.    foundABIT = 1
  360.  
  361.    REM - This only handles full size BitMaps, not brushes
  362.    REM - Very fast - reads in entire BitPlanes
  363.    plSize& = (scrWidth%/8) * scrHeight%
  364.    FOR pp = 0 TO iDepth% -1
  365.       rLen& = xRead&(fHandle&,bPlane&(pp),plSize&)   
  366.    NEXT
  367.  
  368. ELSE 
  369.    REM - Reading unknown chunk  
  370.    FOR kk = 1 TO icLen&
  371.       rLen& = xRead&(fHandle&,inbuf&,1)
  372.    NEXT
  373.    REM - If odd length, read 1 more byte
  374.    IF (icLen& OR 1) = icLen& THEN 
  375.       rLen& = xRead&(fHandle&,inbuf&,1)
  376.    END IF      
  377. END IF
  378.  
  379. REM - Done if got all chunks 
  380. IF foundBMHD AND foundCMAP AND foundABIT THEN
  381.    GOTO GoodLoad
  382. END IF
  383.  
  384. REM - Good read, get next chunk
  385. IF rLen& > 0 THEN GOTO ChunkLoop
  386.  
  387. IF rLen& < 0 THEN  'Read error
  388.    loadError$ = "   Read error"
  389.    GOTO Lcleanup
  390. END IF   
  391.  
  392. REM - rLen& = 0 means EOF
  393. IF (foundBMHD=0) OR (foundABIT=0) OR (foundCMAP=0) THEN
  394.    loadError$ = " Needed ILBM chunks not found "
  395.    GOTO Lcleanup
  396. END IF
  397.  
  398. GoodLoad:
  399. loadError$ =""
  400.  
  401. REM  Load proper Colors
  402. IF foundCMAP THEN 
  403.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  404. END IF
  405.                                    
  406. Lcleanup:
  407. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  408. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  409. RETURN
  410.  
  411. Mcleanup2:
  412. IF loadError$ <> "" THEN PRINT loadError$
  413. GOTO Prime
  414.  
  415. GetScrAddrs:
  416. REM - Get addresses of screen structures
  417.    sWindow&   = WINDOW(7)
  418.    sScreen&   = PEEKL(sWindow& + 46)
  419.    sViewPort& = sScreen& + 44
  420.    sRastPort& = sScreen& + 84
  421.    sColorMap& = PEEKL(sViewPort& + 4)
  422.    colorTab&  = PEEKL(sColorMap& + 4)
  423.    sBitMap&   = PEEKL(sRastPort& + 4)
  424.  
  425.    REM - Get screen parameters
  426.    scrWidth%  = PEEKW(sScreen& + 12)
  427.    scrHeight% = PEEKW(sScreen& + 14)
  428.    scrDepth%  = PEEK(sBitMap& + 5)
  429.    nColors%   = 2^scrDepth%
  430.  
  431.    REM - Get addresses of Bit Planes 
  432.    FOR kk = 0 TO scrDepth% - 1
  433.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  434.    NEXT
  435. RETURN   
  436.  
  437.