home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d5xx
/
d597
/
icontools.lha
/
IconTools
/
source
/
SwapColors.f
< prev
Wrap
Text File
|
1992-02-01
|
4KB
|
182 lines
\ $VER: SwapColors.f 1.01 (19 Jan 1992 23:28)
\ Program to swap the colors 2 and 3 of a number icons simultaneously,
\ using the Workbench and Intuition.
\ Written in JForth Professional 2.0
\
\ (c) Copyright 1992 by Richard Mazzarisi
\ All rights reserved.
\
\ address:
\ 891 Post St. #207
\ San Francisco, CA
\ 94109
\
\ email:
\ rich@californium.cchem.berkeley.edu
\ rmazz@hydrogen.cchem.berkeley.edu
\ nmr@garnet.berkeley.edu
\
\
\ v. 1.00 1/11/92
\ 1/13/92 moved the resource management routines to IconTools.f
\ v. 1.01 1/19/92 recompiled with new IconTools.f (cf)
\
\ Instructions:
\ 1 - Click on the icon for this program.
\ 2 - Shift click on all icons to be changed.
\
\ (NOTE: The author assumes no responsibility for any damages
\ resulting from the use of this program.)
INCLUDE? TASK-ICONTOOLS ICONTOOLS.F
ANEW task-swapcolors
DECIMAL
\ *** main window stuff ***
: open.sc-window ( -- window/null )
getWBscreendata
it-newwindow NEWWINDOW.SETUP
20 16 set.vert-params
it-newwindow ..! nw_Height
it-newwindow ..! nw_TopEdge
20 52 set.horiz-params
it-newwindow ..! nw_Width
it-newwindow ..! nw_LeftEdge
0" SwapColors 1.01" >ABS it-newwindow ..! nw_Title
CLOSEWINDOW it-newwindow ..! nw_IDCMPFlags
WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING | ACTIVATE |
it-newwindow ..! nw_Flags
it-newwindow GR.OPENCURW
;
\ *** support ***
: sc.greeting ( -- )
" Swap colors 1 and 2 in the Image of Icons." con.write.itl con.cr
" © Copyright by Richard Mazzarisi 1992" con.write.c3 con.cr
" All rights reserved." con.write.c3 con.cr
" Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
;
: prt.sc-instr ( -- )
" Instructions:" con.write con.cr
" 1 - Click on the icon for this program." con.write con.cr
" 2 - Shift click on all icons to be changed." con.write con.cr con.cr
" (NOTE: The author assumes no responsibility for any"
con.write con.cr
" damages resulting from the use of this program.)" con.write con.cr
;
: swap.1-2 { gadimage | nwords plane0 plane1 -- }
gadimage ..@ ig_Width 15 + 16 / \ # 16 bit words across
gadimage ..@ ig_Height * -> nwords
gadimage ..@ ig_ImageData >REL DUP -> plane0
nwords 2* ( offset in bytes ) + -> plane1
nwords 0 DO
\ swapping the planes will swap colors 1 & 2
\ ie. {0101,0011} -> {0011,0101} or 0->0 1->2 2->1 3->3
plane0 W@ plane1 W@
plane0 W! plane1 W!
no@ 2 plane0 +! 2 plane1 +! yes@
LOOP
;
: swap.it { | icongad -- }
PAD $it.get-icon
theICON @ .. do_Gadget DUP -> icongad
..@ gg_GadgetRender >REL
\ check for a 4 colors and whether it is an image (not border)
DUP ..@ ig_Depth 2 =
icongad ..@ gg_Flags GADGIMAGE AND 0> AND IF
swap.1-2
\ check for highlight image
icongad ..@ gg_Flags GADGHIGHBITS AND GADGHIMAGE = IF
icongad ..@ gg_SelectRender >REL swap.1-2
THEN
[ clone-it @ ] .IF
PAD $it.save-icon
.ELSE
\ don't really do it if we are testing things in the interpreter
it.abort-icon
.THEN
ELSE
" Not a 4 color image! Not changed." con.write con.cr
DROP
it.abort-icon
THEN
;
: swap.one { wb-arg -- }
\ get file's path name
wb-arg get.full-path IF
" " con.write
PAD con.write con.cr
swap.it
ELSE
" ERROR: Could not get path for icon:" con.write.itl con.cr
" " con.write
wreq @ wb-arg ..@ wa_Name >REL ConPutStr() con.cr
THEN
;
: do.swaps { #args -- }
\ go thru icons to be changed
" Click closebox to abort." con.write con.cr con.cr
" Swapping the colors for:" con.write con.cr
\ get pointer to args
WBMESSAGE @ >REL ..@ sm_ArgList >REL
\ 2nd and on are the icons to work on
#args 1+ 1 DO
DUP SizeOf() WBArg I * +
swap.one
\ check for stop action
?CLOSEBOX IF LEAVE THEN
LOOP
DROP
con.cr " Done. " con.write.itl
;
\ *** main ***
: swapcolors ( -- )
' prt.sc-instr IS prt.it-instr
' open.sc-window IS open.it-window
open.it-things
cursor.off
sc.greeting
check.WB
2 check.num.args IF
do.swaps
THEN
close.it-things
;
: sc
swapcolors
;
clone-it @ .IF
initclone
clone swapcolors
save-image swapcolors SwapColors -icon
.THEN
CR CR ." Type 'sc to run." CR CR