home *** CD-ROM | disk | FTP | other *** search
/ AMOS PD CD / amospdcd.iso / aminet / ph_progs.lha / PH_PROGS.AMOS / Pixel_Tools.AMOS / Pixel_Tools.amosSourceCode
AMOS Source Code  |  1993-06-02  |  7KB  |  239 lines
  1. '****************************************************************************
  2. '**  PIXEL TOOLS  -  By Paul Hickman  -  2/4/93  -  E-Mail ph@doc.ic.ac.uk **  
  3. '****************************************************************************
  4. '
  5. 'If you have any questions / find any special features(bugs) or improvments  
  6. 'please E-Mail me......
  7. '
  8. 'The Demo Code requires any IFF picture of low resolution, and <=32 colours. 
  9. 'It is loaded by the line below, and is currently from the orignal AMOS data 
  10. 'disk, supplied with version 1.1. If you don't have this disk, then change 
  11. 'it to any 320x200 or larger IFF picture.
  12. '
  13. Load Iff "AMOS_DATA:IFF/amospic.iff",1
  14. '
  15. '
  16. Screen Hide 1
  17. Screen Open 0,320,256,32,Lowres
  18. Flash Off : Curs Off : Cls 0 : Get Palette 1
  19. A$="Press Any Key To Continue"
  20. PIXELCOPY[1,40,0,104,119,0,20,20,16]
  21. PIXELWRITER[A$,1,Screen Width/2-Len(A$)*4,100,9,True]
  22. Wait Key 
  23. PIXELCLEAR[A$,1,Screen Width/2-Len(A$)*4,100]
  24. PIXELBLANK[20,0,310,200,15,0]
  25. End 
  26. '
  27. '****************************************************************************  
  28. '***  END OF DEMO CODE - NOW AN EXPLANATION OF HOW TO USE THE PROCEDURES  ***
  29. '****************************************************************************
  30. '
  31. 'Parameters: PIXELWRITER / PIXELCLEAR
  32. '
  33. 'A$ : String to be typed 
  34. 'S2 : Number for a temporary screen (Created Internally) 
  35. 'X  : X-position of text   
  36. 'Y  : Y-position of text (Top of characters, not baseline) 
  37. 'FC : Text Foreground Colour 
  38. 'BC : Text Background Colour (-1 = Transparent)
  39. '
  40. 'NOTE: S2 should be the same for pixelwrite & the corresponding pixel clear, 
  41. 'and pixel write creates screen s2, and pixel clear uses it to replace the 
  42. 'old data under the text, the destroys it. If you use pixelwrite without pixel 
  43. 'clear, the you should close screen s2 afterwards. 
  44. '
  45. '
  46. 'Parameters: PIXELBLANK / PIXELCOPY
  47. '
  48. 'S1 : Source Screen
  49. 'S2 : Destination Screen 
  50. '
  51. 'X1 : Source/Clear Rectangle Left Edge X Co-ordinate   
  52. 'X2 : Source/Clear Rectangle Right Edge X Co-ordinate  
  53. 'Y1 : Source/Clear Rectangle Top Edge Y Co-ordinate
  54. 'Y2 : Source/Clear Rectangle Bottom Edge Y Co-ordinate 
  55. '
  56. 'X3 : Destination Rectangle Left Edge X Co-ordinate
  57. 'Y3 : Destination Rectangle Top Edge Y Co-ordinate 
  58. '
  59. 'SZ : Size of Mosaic Squares in pixels 
  60. 'C  : Colour to fill with. 
  61. '
  62. 'NOTE: As with cls & screen copy, the area x1,y1 to x2-1,y2-1 is actually
  63. 'cleared / copied, not x1,y1 to x2,y2. 
  64. '
  65. '
  66. 'The following restrictions apply to PIXELBLANK & PIXEL COPY :-  
  67. '
  68. ' - The Dimemsions X2-X1 & Y2-Y1 Are Greater Than Or Equal To The Pixel Size 
  69. '
  70. ' - The Larger Dimension of X2-X1 & Y2-Y1 must be at least The Pixel Size
  71. '   sqaured in length. e.g. Using pixel size 4, the rectangle must be 16   
  72. '   pixels in width or height. 
  73. '
  74. '
  75. 'Each of the four procedures will work independantly of the others, except 
  76. 'PIXELCLEAR, which can only be used after a PIXELWRITE.
  77. '
  78. '****************************************************************************
  79. '**  HERE ARE THE PROCEDURES, USE BLOCK STORE TO COPY THEM INTO YOUR CODE  **
  80. '****************************************************************************
  81. '
  82. Procedure PIXELWRITER[A$,S2,X,Y,FC,BC]
  83. '
  84.    L=Len(A$)-1
  85.    Dim O(63),C(L)
  86. '
  87. 'Create a pixel list 
  88. '
  89.    For A=0 To 63 : O(A)=A : Next 
  90. '
  91. 'Shuffle to pixel list 
  92. '
  93.    For A=0 To 30
  94.       A1=Rnd(63) : A2=Rnd(63)
  95.       A3=O(A1) : O(A1)=O(A2) : O(A2)=A3
  96.    Next 
  97. '
  98. 'Assign a random starting position in the list to each character 
  99. '
  100.    For A=1 To L : C(A)=Rnd(64) : Next 
  101. '
  102. 'Plot string on the temporary screen with correct colours
  103. '
  104.    S1=Screen
  105.    Screen Open S2,Len(A$)*8+8,8,Screen Colour,Lowres : Screen Hide S2
  106.    If BC>0
  107.       Ink FC,BC : Cls BC : JAM1=True
  108.    Else 
  109.       Ink FC : JAM1=False : Cls 0
  110.    End If 
  111.    Gr Writing 0 : Text 0,6,A$
  112. '
  113. 'Plot the pixels 
  114. '
  115.    For C=0 To 63
  116.       For B=0 To L
  117.          '
  118.          'Calculate Position Of This Pixel
  119.          '
  120.          Add C(B),1,0 To 63
  121.          XX=B*8+Int(O(C(B))/8) : YY=Int(O(C(B))) and 7
  122.          '
  123.          'Swap pixel on actual and temporary screens if not transparent 
  124.          '(But always copy actual screen pixel to temporary screen) 
  125.          '
  126.          Screen S1 : C1=Point(X+XX,Y+YY)
  127.          Screen S2 : C2=Point(XX,YY)
  128.          Ink C1 : Plot XX,YY
  129.          Screen S1
  130.          If(C2>0) or JAM1
  131.             Ink C2 : Plot X+XX,Y+YY
  132.          End If 
  133.       Next 
  134.    Next 
  135. '
  136. End Proc
  137. Procedure PIXELCLEAR[A$,S2,X,Y]
  138. '
  139. 'Generate Pixel & Character Lists as in PIXELWRITER
  140. '
  141.    L=Len(A$)-1
  142.    Dim O(63),C(L)
  143.    For A=0 To 63 : O(A)=A : Next 
  144.    For A=0 To 30 : A1=Rnd(63) : A2=Rnd(63)
  145.       A3=O(A1) : O(A1)=O(A2) : O(A2)=A3
  146.    Next 
  147.    For A=1 To L : C(A)=Rnd(64) : Next 
  148. '
  149. 'Copy Temporary screen to Actual Screen
  150. '
  151.    S1=Screen
  152.    For C=0 To 63
  153.       For B=0 To L
  154.          Add C(B),1,0 To 63
  155.          XX=B*8+Int(O(C(B))/8) : YY=Int(O(C(B))) and 7
  156.          Screen S2 : P=Point(XX,YY)
  157.          Screen S1 : Ink P : Plot X+XX,Y+YY
  158.       Next 
  159.    Next 
  160.    Screen Close S2
  161.    Screen S1
  162. End Proc
  163. Procedure PIXELBLANK[X1,Y1,X2,Y2,SZ,C]
  164. '
  165. 'This works by considering groups of 8x8 squares as characters, and ploting
  166. 'each character from a random starting place in the pixel list.
  167. '
  168. 'Find Width & Height Of Rectangle In Squares, and Divide By 8, Rounding Up 
  169. '
  170. AX=Min(1,Int(7+Int((X2-X1+SZ-1)/SZ))/8) : AY=Min(1,Int(7+Int((Y2-Y1+SZ-1)/SZ))/8)
  171. '
  172. 'Create an 8x8 pixel map, and assign random starting positions to each 
  173. '"character" 
  174. '
  175.    Dim O(63),C(AX*AY)
  176.    For A=0 To AX*AY : C(A)=A : Next 
  177.    For A=0 To 63 : O(A)=A : Next 
  178.    For A=0 To AX*AY
  179.       A1=Rnd(63) : A2=Rnd(63)
  180.       A3=O(A1) : O(A1)=O(A2) : O(A2)=A3
  181.       A1=Rnd(AX*AY-1) : A2=Rnd(AX*AY-1)
  182.       A3=C(A1) : C(A1)=C(A2) : C(A2)=A3
  183.    Next 
  184. '
  185. 'Plot Squares
  186. '
  187.    For AA=0 To 63
  188.       For BB=0 To AX*AY
  189. '
  190. 'Calculate position in rectangle or this square
  191. '
  192.          Y=Int(C(BB)/AX) : X=(C(BB)-AX*Y)
  193.          A=O((X*Y+X+2*Y+5*X+8*Y+AA) and 63)
  194.          XX=(X*8+Int(A/8))*SZ : YY=(Y*8+(A and 7))*SZ
  195. '
  196. 'If it is within bounds, clear the valid portion of the square   
  197. '
  198.          If(XX+X1<=X2) and(YY+Y1<=Y2)
  199.             Cls C,X1+XX,Y1+YY To Min(X1+XX+SZ,X2),Min(Y1+YY+SZ,Y2)
  200.          End If 
  201.    Next : Next 
  202. End Proc
  203. Procedure PIXELCOPY[S1,X1,Y1,X2,Y2,S2,X3,Y3,SZ]
  204. '
  205. 'Create Pixel List & "Character" as with PIXELBLANK
  206. '
  207.    AX=Max(1,Int(7+Int((X2-X1+SZ-1)/SZ))/8) : AY=Max(1,Int(7+Int((Y2-Y1+SZ-1)/SZ))/8)
  208.    Dim O(63),C(AX*AY)
  209.    For A=0 To AX*AY : C(A)=A : Next 
  210.    For A=0 To 63 : O(A)=A : Next 
  211.    For A=0 To AX*AY
  212.       A1=Rnd(63) : A2=Rnd(63)
  213.       A3=O(A1) : O(A1)=O(A2) : O(A2)=A3
  214.       A1=Rnd(AX*AY-1) : A2=Rnd(AX*AY-1)
  215.       A3=C(A1) : C(A1)=C(A2) : C(A2)=A3
  216.    Next 
  217. '
  218. 'Plot Squares
  219. '
  220.    For AA=0 To 63
  221.       For BB=0 To AX*AY
  222. '
  223. 'Calculate Position
  224. '
  225.          Y=Int(C(BB)/AX) : X=(C(BB)-AX*Y)
  226.          A=O((X*Y+X+2*Y+5*X+8*Y+AA) and 63)
  227.          XX=(X*8+Int(A/8))*SZ : YY=(Y*8+(A and 7))*SZ
  228. '
  229. 'Copy the portion of the square within the rectangle 
  230. '
  231. '         If(XX+X1<=X2) and(YY+Y1<=Y2) 
  232.             Screen Copy S1,X1+XX,Y1+YY,Min(X1+XX+SZ,X2),Min(Y1+YY+SZ,Y2) To S2,X3+XX,Y3+YY
  233. '         End If 
  234.    Next : Next 
  235. End Proc
  236. '
  237. '****************************************************************************  
  238. '*  Support AMOS on the internet - upload source code or compiled programs  *  
  239. '****************************************************************************