AMOS PD CD/amospdcd.iso/sourcecode/utilities/palet.amos/palet.amosSourceCode

AMOS Source Code | 1992-02-10 | 14KB | 416 lines

'================================================================
'                 P A L E T T E   S E T T E R
'
'             John Collett, Hamilton, New Zealand
'
'                        February 1992
'
'      Copy any pieces from this which you may find useful,
'      but please leave this program intact, as it stands.
'
'================================================================
Screen Open 1,640,260,16,Hires
Curs Off : Flash Off : Palette $0,$79A,$FFF,$FB5
'====== Demo : Introduction, organisation, explanations =========
HEADER
LUPE[3,640,Hires]
EX4
LUPE[4,320,Lowres]
Edit
'==============  Procedures used by Demo   ======================
Procedure HEADER
   SH[100,30,"PALETTE SETTER DEMONSTRATION     AMOS 1.2",3]
   SH[50,50,"This demo will show a Palette Setter in each of seven",2]
   SH[50,60,"different settings and in three different modes.",2]
   SH[50,70,"Each time you are ready to go on to the next stage of",2]
   SH[50,80,"the demo, click on the OK button in the Palette Setter.",2]
   SH[60,100,"The seven settings will be :",2]
   SH[80,120,"Hires : 4, 8, and 16 colours",3]
   SH[80,130,"Lores : 4, 8, 16, and 32 colours",3]
   SH[50,150,"The demo contains brief explanations.",2]
   SH[50,160,"Those on the first screen are largely unnecessary,",2]
   SH[50,170,"but the later ones will be more informative.",2]
   SH[180,190,"Press any key to start",3]
   Wait Key
End Proc
Procedure LUPE[N,W,RES]
   For S=1 To N
      NC=2^(S+1)
      Screen Open 1,W,260,NC,RES : Colour 1,$79A
      Curs Off : Flash Off
      If W=640
         On S Proc EX1,EX2,EX3
      End If
      'Set the mode
      F$="0"
      If W=320
         If S=3 : F$="1" : End If
         If S=4
            If Exist(":Amospic.IFF")
               F$=":Amospic.IFF"
            Else
               Locate 7,15 : Print ":Amospic.IFF not found"
            End If
         End If
      End If
      PALET[F$]
      Screen Close 1
   Next
End Proc
Procedure EX1
   Ink 2
   Polyline 116,102 To 116,106 To 210,106 To 210,102 : Draw 162,106 To 162,114
   SH[130,124,"Click on",2] : SH[130,132,"these to",2]
   SH[130,140,"select a",2] : SH[130,148,"colour.",2]
   Polyline 306,22 To 314,22 To 314,52 To 306,52 : Draw 314,37 To 322,37
   SH[330,36,"Click or slide on these",2] : SH[330,44,"to adjust RGB settings.",2]
   SH[44,52,"$RGB -->",2] : SH[4,26,"Current",2] : SH[4,36,"selection -->",2]
   SH[250,150,"Click on 'OK' when ready.",3]
End Proc
Procedure EX2
   SH[320,20,"Copy, Swap, and Range",3]
   SH[330,30,"Click on the 'From' colour,",2]
   SH[330,38,"then on 'Copy', 'Swap' or 'Range',",2]
   SH[330,46,"and then on the 'To/With' colour.",2]
   SH[320,58,"OK",3]
   SH[330,68,"Closes the Palette Setter.",2]
   SH[320,80,"Save",3]
   SH[330,90,"Stores current RGB settings in",2]
   SH[330,98,"'RAM:palset.ASC', for future use.",2]
   SH[320,110,"Fix",3]
   SH[330,120,"Makes current settings the",2]
   SH[330,128,"base for future resets.",2]
   SH[320,140,"Rset",3]
   SH[330,150,"Resets all colours.  Resets to the",2]
   SH[330,158,"'Fixed' set if Fix has been used.",2]
   SH[60,168,"MOVING THE SETTER",3]
   SH[80,178,"To move the Palette Setter, press the Left Mouse",2]
   SH[80,186,"Button in the Sample Colour box (top left).",2]
   SH[80,194,"Drag a flickering rectangle the size of the Palette",2]
   SH[80,202,"Setter to its new position.  Click it into place.",2]
   SH[80,210,"It will remain within screen boundaries.",2]
End Proc
Procedure EX3
   SH[320,20,"To include the Palette Setter",2]
   SH[320,30,"in another AMOS program,",2]
   SH[320,40,"copy the procedures used in this",2]
   SH[320,50,"demo, from 'Procedure PALET[mode$]'",2]
   SH[320,60,"to 'Procedure NEWPOS' inclusive.",2]
   SH[320,80,"Invoke them with the call",2]
   SH[320,90,"'PALET[mode$]', activated by a",2]
   SH[320,100,"gadget, key press, or whatever.",2]
   SH[10,110,"MODES",3]
   SH[30,120,"The string argument in PALET[mode$] has three settings.",2]
   SH[40,130,'- PALET["0"] runs the Palette Setter on the current screen.',2]
   SH[40,140,'- PALET["1"] opens a file selector.  A selected IFF file will appear on',2]
   SH[56,148,"a screen of appropriate dimensions, with the Palette Setter on top.",2]
   SH[40,158,'- PALET[pic$] automatically loads the IFF file "pic$"',2]
   SH[56,166,"(if it exists) before the Palette Setter appears.",2]
   SH[10,178,"COLOURS",3]
   SH[30,188,'The ["0"] mode starts off with the colours as set in P$ in the',2]
   SH[30,196,"PALET[mode$] procedure, and the Rset gadget resets everything",2]
   SH[30,204,"to those colours unless Fix has subsequently been used.",2]
   SH[30,212,'The "Save" gadget makes it easy to make a new base set if you wish to.',2]
   SH[30,226,"The other two modes open with the colours of the loaded file, but",2]
   SH[30,234,"unless you use the Fix gadget, the Rset gadget will reset them",2]
   SH[30,242,"to those defined in P$.",2]
End Proc
Procedure EX4
   Screen Open 1,640,260,4,Hires : RESET
   Curs Off : Flash Off
   SH[44,40,"Four demo screens in Lowres (Width = 320).",3]
   SH[60,60,"These will use 4, 8, 16, and 32 colours.",2]
   SH[60,70,"The third of the four is set to display a file selector.",2]
   SH[60,80,"Just click on Quit for now.",2]
   SH[60,110,"For the last example, the file :Amospic.IFF will be",2]
   SH[60,120,"loaded, and the colours of that file will be used.",2]
   SH[60,130,"If you encounter a problem, check its location.",2]
   SH[60,150,"A click on Fix will prevent the colours on the screen from",2]
   SH[60,160,"being Reset to the Palette Setter's own set of colours.",2]
   SH[140,180,"Press any key to continue.",3]
   Wait Key : Screen Close 1
End Proc
Procedure SH[TX,TY,T$,I]
   Colour 3,$FB5
   Gr Writing 0
   Ink 0 : Text TX+1,TY+1,T$
   Ink I : Text TX,TY,T$
End Proc
' =============  Procedures called by PALET[mode$]  =============
Procedure PALET[F$]
   If F$="1"
      F$=Fsel$("*.IFF","","Load an IFF file") :
      If F$<>"" : Load Iff F$,1 : End If
   Else
      If F$<>"0" : Load Iff F$ : End If
   End If
   Shared WX,WY,P$
   SW=Screen Width
   NC=Screen Colour
   P$="$000,$79A,$FFF,$FB5,$FF0,$0F0,$F00,$800,$9DF,$59F,$D00,$ACC,$FC0,$D80,$840,$FCC,$FFF,$DDD,$CCC,$AAA,$999,$777,$666,$444,$FB0,$EA0,$C90,$B80,$A60,$950,$740,$630"
   Reserve Zone NC+10 : Flash Off : Curs Off
   WX=SW/4-50 : WY=20
   Wind Save
   If(F$="0") or(F$="") : RESET : End If
   Repeat
      PALWIN
   Until Param=0
End Proc
Procedure PALWIN
   Shared WX,WY,CHOYCE
   OPEN_WINDOW[1] : Curs Off
   PREPARE_SAMPLER
   CHOYCE=1 : H$=Hex$(Colour(1),3) : DISPLAY_H : SLIDER_VALUES : PZ=0
   MAIN
   AGAIN=(Param=10)
   Wind Close
End Proc[AGAIN]
Procedure MAIN
   Shared WX,WY,X,Z,CHOYCE,P$
   NC=Screen Colour
   Limit Mouse 128,42 To 446,298
   Repeat
      M=Mouse Key : Z=Mouse Zone
      If Z<4 : SLIDER[Z]
      Else
         If Z>3 and Z<11 and M
            X=X Mouse : X=X Screen(X)
            On Z-3 Proc DUP_COL,RANGE,QUIT,SAIVE,FIKS,RESET,NEWPOS
         Else
            If(Z>10) and(Z<(NC+11)) and M : CHOOSE_COLOUR : M=0 : End If
         End If
      End If
   Until M<>0 and(Z=6 or Z=(10))
End Proc[Z]
Procedure FIKS
   Shared P$
   W_SH[114,75,"Fix",2]
   NC=Screen Colour
   P$=""
   For I=0 To NC-1
      P$=P$+Hex$(Colour(I),3)+","
   Next
   W_SH[114,75,"Fix",3]
End Proc
Procedure RESET
   Shared P$
   NC=Screen Colour
   For I=0 To NC-1
      C$=(Mid$(P$,(I*5)+1,4)) : Colour I,Val(C$)
   Next
End Proc
Procedure QUIT
End Proc
Procedure SAIVE
   Shared WX,WY,P$
   W_SH[150,64,"Save",2]
   Open Out 1,"RAM:palset.ASC"
   Print #1,""
   Print #1,"     The characters between < and > may be assigned to P$"
   Print #1,"     in the 11th line of Procedure PALET[].  For this, there"
   Print #1,"     must be FOUR characters in each element (e.g. $F00"
   Print #1,"     should not be reduced to $F)."
   Print #1,""
   Print #1,"<"
   Print #1,P$
   Print #1,">"
   Print #1,""
   Print #1,"     The data may, of course, be useful in other applications."
   Close 1
   W_SH[150,64,"Save",3]
End Proc
Procedure DUP_COL
   Shared WX,WY,CHOYCE,X
   D1=Val(Hex$(Colour(CHOYCE),3))
   Gr Writing 0
   If X<WX+146
      MBOSS[110,35,145,44] : W_SH[113,42,"To?",2]
   Else
      MBOSS[148,35,184,44] : W_SH[151,42,"With",2]
   End If
   NEWZ=0 : Repeat : M=Mouse Click : NEWZ=Mouse Zone : Until NEWZ>10 and M
   D2=Val(Hex$(Colour(NEWZ-11),3))
   Colour NEWZ-11,D1
   If X<WX+146
      MBOSS[110,35,145,44] : W_SH[113,42,"Copy",3]
   Else
      Colour CHOYCE,D2
      MBOSS[148,35,184,44] : W_SH[151,42,"Swap",3] :
   End If
   Gr Writing 1
End Proc
Procedure RANGE
   Shared WX,WY,CHOYCE
   W_SH[158,53,"To?",2]
   Repeat : M=Mouse Click : NEWZ=Mouse Zone : Until NEWZ>10 and M
   Ink 1 : W_BAR[158,47,182,54] : FIRST=CHOYCE : LAST=NEWZ-11
   C1$=Hex$(Colour(FIRST),3)
   R1=Val(Left$(C1$,2)) : G1=Val("$"+Mid$(C1$,3,1)) : B1=Val("$"+Right$(C1$,1))
   C2$=Hex$(Colour(LAST),3)
   R2=Val(Left$(C2$,2)) : G2=Val("$"+Mid$(C2$,3,1)) : B2=Val("$"+Right$(C2$,1))
   CASES#=Abs(LAST-FIRST) : If LAST=FIRST : Pop Proc : End If
   RDIR=(R1>R2)+Abs(R1<R2) : GDIR=(G1>G2)+Abs(G1<G2) : BDIR=(B1>B2)+Abs(B1<B2)
   RDIST#=Abs(R1-R2) : R_PIECE#=(RDIST#/CASES#)
   GDIST#=Abs(G1-G2) : G_PIECE#=(GDIST#/CASES#)
   BDIST#=Abs(B1-B2) : B_PIECE#=(BDIST#/CASES#) : T=0
   For K=FIRST+1 To LAST-1
      Inc T
      NEWR#=R1+RDIR*T*R_PIECE# : NEWG#=G1+GDIR*T*G_PIECE# : NEWB#=B1+BDIR*T*B_PIECE#
      THISCOL=Val(Hex$(Int(NEWR#+0.5),1)+Right$(Hex$(Int(NEWG#+0.5),1),1)+Right$(Hex$(Int(NEWB#+0.5),1),1))
      Colour K,THISCOL
   Next
End Proc
Procedure CHOOSE_COLOUR
   Shared WX,WY,Z,CHOYCE,H$
   CHOYCE=Z-11
   DISPLAY_H
   Colour CHOYCE,Val(H$)
   Ink CHOYCE : W_BAR[7,3,35,20]
   SLIDER_VALUES
End Proc
Procedure DISPLAY_H
   Shared WX,WY,CHOYCE,H$
   H$=Hex$(Colour(CHOYCE),3)
   Gr Writing 1 : Ink 0,1 : Text WX+9,WY+31,Right$(H$,3) : Ink 2,1
End Proc
Procedure PREPARE_SAMPLER
   Shared WX,WY
   MBOSS[6,2,36,21] : MBOSS[6,23,36,33]
   W_ZONE[10,6,2,36,21]
   W_SH[44,9,"R",3] : W_SH[44,19,"G",3]
   W_SH[44,29,"B",3]
   X1=56 : X2=184
   For I=0 To 2
      Y1=2+I*10 : Y2=10+I*10 : MBOSS[X1,Y1,X2,Y2]
      W_ZONE[I+1,X1,Y1,X2,Y2]
      If I<2 : Ink 0 : For J=1 To 15 : W_PLOT[WX,WY,X1+J*8,Y2+1] : Next : End If
   Next
   MBOSS[110,35,145,44] : MBOSS[148,35,184,44] : W_ZONE[4,110,35,184,44]
   MBOSS[110,46,184,55] : W_ZONE[5,110,46,184,55]
   MBOSS[110,57,145,66] : W_ZONE[6,110,57,145,66]
   MBOSS[148,57,184,66] : W_ZONE[7,148,57,184,66]
   MBOSS[110,68,145,77] : W_ZONE[8,110,68,145,77]
   MBOSS[148,68,184,77] : W_ZONE[9,148,68,184,77]
   W_SH[113,42,"Copy",3] : W_SH[151,42,"Swap",3] : W_SH[114,53,"Range",3]
   W_SH[114,64,"OK",3] : W_SH[151,64,"Save",3]
   W_SH[114,75,"Fix",3] : W_SH[151,75,"Rset",3]
   '  Sample rows
   X1=6 : Y1=36 : X2=102 : Y2=76
   NC=Screen Colour
   MBOSS[X1-1,Y1,X2,Y2+1]
   NROWS=2+2*Abs(NC>12) : NCOLS=NC/(2+(2*Abs(NC>8)))
   RSTEP=40/NROWS : CSTEP=96/NCOLS
   R1=Y1 : C1=X1 : C2=X2-CSTEP : I=0
   For R=1 To NROWS
      For C=1 To NCOLS
         Ink I : W_BAR[C1,R1+1,C1+CSTEP-1,R1+RSTEP]
         W_ZONE[I+11,C1+1,R1+1,C1+CSTEP-1,R1+RSTEP]
         Add C1,CSTEP,X1 To C2 : Inc I
      Next
      Add R1,RSTEP
   Next
End Proc
Procedure OPEN_WINDOW[N]
   Shared WX,WY
   WX=(WX+8)/16*16
   Wind Open N,WX,WY,24,10 : Curs Off : Flash Off
   Ink 2 : Set Pattern 31 : W_BAR[1,1,191,79] : Set Pattern 0
   X2=WX+191 : Y2=WY+79
   Ink 2 : Polyline WX,Y2 To X2,Y2 To X2,WY
   Ink 0 : Polyline WX,Y2 To WX,WY To X2,WY
End Proc
Procedure MBOSS[X1,Y1,X2,Y2]
   Shared WX,WY
  ' X1=WX+X1 : Y1=WY+Y1 : X2=WX+X2 : Y2=WY+Y2
   Add X1,WX : Add Y1,WY : Add X2,WX : Add Y2,WY
   Ink 1 : Bar X1,Y1 To X2,Y2
   Ink 0 : Polyline X1,Y2 To X2,Y2 To X2,Y1
   Ink 2 : Polyline X1,Y2 To X1,Y1 To X2,Y1
End Proc
Procedure W_SH[TX,TY,T$,I]
   Shared WX,WY
   Gr Writing 0
   Ink 0 : Text WX+TX+1,WY+TY+1,T$
   Ink I : Text WX+TX,WY+TY,T$
   Gr Writing 1
End Proc
Procedure W_PLOT[WX,WY,X,Y]
   Plot WX+X,WY+Y
End Proc
Procedure W_DRAW[X1,Y1,X2,Y2]
   Shared WX,WY
   Draw WX+X1,WY+Y1 To WX+X2,WY+Y2
End Proc
Procedure W_BAR[X1,Y1,X2,Y2]
   Shared WX,WY
   Bar WX+X1,WY+Y1 To WX+X2,WY+Y2
End Proc
Procedure W_ZONE[N,X1,Y1,X2,Y2]
   Shared WX,WY
   Set Zone N,WX+X1,WY+Y1 To WX+X2,WY+Y2
End Proc
Procedure SLIDER[Z]
   Shared WX,WY,Z,CHOYCE,H$
   PX=0
   While Mouse Key=1
      X=X Screen(X Mouse)
      If Z>0 and X<>PX and X>WX+56
         DISPLAY_H
         RED$="$"+Mid$(H$,2,1) : GREEN$="$"+Mid$(H$,3,1) : BLUE$="$"+Right$(H$,1)
         X1=WX+57 : X2=X : X3=X1+126 : Y1=WY+3+(Z-1)*10 : Y2=Y1+6
         If X1+1<X2 and X2<X3 :
            Ink 2 : Set Pattern 32 : Bar X1+1,Y1+1 To X2,Y2-1 : Set Pattern 0
            If X2+1<X3 : Ink 1 : Bar X2,Y1 To X3,Y2 : End If
            'Set colour as bar moves
            DISTANCE=(X2-X1)/8
            If DISTANCE<10
               DIST$=Str$(DISTANCE)
            Else
               DIST$=Chr$(55+DISTANCE)
            End If
            If Z=1 : RED$=DIST$
            Else
               If Z=2 : GREEN$=DIST$
               Else
                  If Z=3 : BLUE$=DIST$ : End If
               End If
            End If
            H$="$"+Right$(RED$,1)+Right$(GREEN$,1)+Right$(BLUE$,1)
            Colour CHOYCE,Val("$"+Right$(RED$,1)+Right$(GREEN$,1)+Right$(BLUE$,1))
            Ink CHOYCE : Bar WX+7,WY+3 To WX+35,WY+17 : DISPLAY_H
         End If
      End If
      PX=X
   Wend
End Proc
Procedure SLIDER_VALUES
   Shared WX,WY,H$
   RED$="$"+Mid$(H$,2,1) : GREEN$="$"+Mid$(H$,3,1) : BLUE$="$"+Right$(H$,1)
   X1=WX+57 : X3=X1+126
   For Z=1 To 3
      If Z=1 : X2=Val(RED$)
      Else
         If Z=2 : X2=Val(GREEN$)
         Else
            X2=Val(BLUE$)
         End If
      End If
      X2=WX+56+X2*8+8 : Y1=WY+3+(Z-1)*10 : Y2=Y1+6
      Ink 2 : Set Pattern 32 : Bar X1+1,Y1+1 To X2-1,Y2-1 : Set Pattern 0
      If X2+1<X3 : Ink 1 : Bar X2,Y1 To X3,Y2 : End If
   Next
End Proc
Procedure NEWPOS
   Shared WX,WY
   SW=Screen Width
   M=0 : Ink 3 : Gr Writing 2
   While M=0
      X=X Screen(X Mouse) : Y=Y Screen(Y Mouse)
      If X<>OX and Y<>OY : Box X,Y To X+192,Y+80 : Box X,Y To X+192,Y+80 : End If
      M=Mouse Click : OX=X : OY=Y
   Wend
   Ink 1 : Gr Writing 1
   WX=X Screen(X Mouse) : If WX>SW-192 : WX=SW-192 : End If
   WY=Y Screen(Y Mouse) : If WY>180 : WY=176 : End If
   WX=(WX+8)/16*16
End Proc