\ FloatIcon.f	 1.03
\ Program to release several icons simultaneously so that WorkBench will
\ handle their placement in a drawer window.
\ Written in JForth Professional 2.0
\
\ (c) Copyright 1989, 1990 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
\
\
\ 5/20/90
\
\ v. 1.00 10/9/89
\ v. 1.01 2/3/90   fixed the path name for drawers, WB gives you the name
\			with a '/' at the end which must be removed whereas
\			Jazzbench does not
\ v. 1.02 3/22/90  fixed bug in 'remove.final.slash' was 2DROP changed to DROP
\	  3/23/90  fixed problem similar to '/' with ':' on device icons
\ v. 1.03 5/20/90  fixed the ability to find the font size and use this info
\			in opening the window

\ Instructions:
\ 1 - Click on the icon for this program.
\ 2 - Shift click on all icons to be floated.
\
\ (NOTE: The author assumes no responsibility for any damages
\ resulting from the use of this program.)


INCLUDE? CLONE CL:TOPFILE
INCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J
INCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J
INCLUDE? EXEC_MEMORY_H JI:EXEC/MEMORY.J
INCLUDE? TASK-AMIGA_GRAPH JU:AMIGA_GRAPH
INCLUDE? TASK-AMIGA_EVENTS JU:AMIGA_EVENTS
INCLUDE? TASK-CONSOLESUPPORT JU:CONSOLESUPPORT
INCLUDE? TASK-ANSISUPPORT JU:ANSISUPPORT
INCLUDE? TASK-DOS-SUPPORT JU:DOS-SUPPORT
INCLUDE? TASK-SET-ICON JU:SET-ICON
INCLUDE? TASK-LOCALS JU:LOCALS


.NEED clone-it

\ *** clone controller ***

VARIABLE clone-it
clone-it OFF

.THEN


ANEW task-floaticon

DECIMAL


\ *** console stuff ***

\ variables to hold the request and reply ports
VARIABLE wreq
VARIABLE rreq
VARIABLE wreply
VARIABLE rreply


: con.cr	( -- )
	wreq @ $ 0A ConPutChar()
;


: con.write	( straddr -- )
	wreq @	SWAP COUNT ConWrite()
;


: con.write.c3 ( straddr -- )
\ write string in color 3
	1 33 2 CRender3  wreq @  >ANSIDEVICE
	con.write
	0 1 CRender3  wreq @  >ANSIDEVICE
;


: con.write.itl ( straddr -- )
\ write string in bold italics
	3 1 2 CRender3	wreq @	>ANSIDEVICE
	con.write
	0 1 CRender3  wreq @  >ANSIDEVICE
;


: clear.line	( -- )
\ clear current line
	0 CDeleteLine wreq @ >ANSIDEVICE
;


: cursor.off	( -- )
\ get rid of cursor
	0 CCursOff wreq @ >ANSIDEVICE
;


\ *** main window stuff ***

CREATE scr-buff Sizeof() Screen ALLOT
NewWindow ft-window

: getWBscreendata	( -- )
	scr-buff Sizeof() Screen WBENCHSCREEN NULL
	CALL>ABS INTUITION_LIB GetScreenData  NULL = IF
		ABORT" Could not get Workbench screen data."
	THEN
;


: set.vert-params ( topedge #lines -- topedge' height )
\ calc window height, adjust topedge if necessary
	scr-buff ..@ sc_Font			\ get font
	>REL ..@ ta_YSize			\ font height
	\ estimate height from #lines, title bar height and lower border
	*  scr-buff ..@ sc_BarHeight +	12 +
	\ check if too high
	2DUP +	scr-buff ..@ sc_Height > IF
		\ try adjusting topedge
		SWAP DROP   \ lose old topedge
		scr-buff ..@ sc_Height OVER -  DUP 0< IF
			\ not going to work; set to 0 & screen height
			2DROP
			0  scr-buff ..@ sc_Height
		ELSE
			SWAP
		THEN
	THEN
;


: set.horiz-params ( leftedge #chars -- leftedge' width )
\ calc window width, adjust leftedge if necessary
	scr-buff .. sc_RastPort ..@ rp_TxWidth		\ get font width
	\ estimate width from #chars, and borders
	*  24 +
	\ check if too wide
	2DUP +	scr-buff ..@ sc_Width > IF
		\ try adjusting leftedge
		SWAP DROP   \ lose old leftedge
		scr-buff ..@ sc_Width OVER -  DUP 0< IF
			\ not going to work; set to 0 & screen width
			2DROP
			0  scr-buff ..@ sc_Width
		ELSE
			SWAP
		THEN
	THEN
;


: open.ft-window      ( -- window/null )
	getWBscreendata
	ft-window NEWWINDOW.SETUP
	20 15 set.vert-params
	ft-window ..! nw_Height
	ft-window ..! nw_TopEdge
	20 51 set.horiz-params
	ft-window ..! nw_Width
	ft-window ..! nw_LeftEdge
	0" FloatIcon  1.03" >ABS ft-window ..! nw_Title
	CLOSEWINDOW ft-window ..! nw_IDCMPFlags
	WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING |
		ft-window ..! nw_Flags
	ft-window GR.OPENCURW
;


: wait.close	( -- )
	BEGIN
		GR-CURWINDOW @ EV.WAIT
		GR-CURWINDOW @ EV.GETCLASS
		CLOSEWINDOW =
	UNTIL
;


\ *** string stuff ***

: init.name	( -- )
	0 PAD !
;


: build.name	( addr count -- )
\ must init to null with init.name before using this word for the first
\ time in building a new path name
	PAD @ 0= IF
		PAD >$
	ELSE
		PAD $APPEND
	THEN
;


\ *** resource management ***

: close.ft-things	( -- )
	wait.close
	wreq @ 0= NOT IF
		wreply @ wreq @ rreply @ rreq @ ReleaseConsole()
		wreq OFF
	THEN
	GR.CLOSECURW
	GR.TERM
;


: prt.close-msg 	( -- )
	con.cr
	" Click CloseBox to exit." con.write
;


: ft.abort	( -- )
	con.cr prt.close-msg
	close.ft-things
	ABORT
;


: open.ft-things	( -- t/f )
\ The error messages are for debugging under the interpreter; they won't
\ be able to be seen under the workbench.
	GR.INIT
	wreq OFF
	GR-CURWINDOW OFF
	\ open window
	open.ft-window	NULL = IF
		ABORT" Could not open a window!"
	THEN
	\ make it a console
	gr-curwindow @ GetConsole() NULL = IF
		close.ft-things
		ABORT" Could not create a console device!"
	ELSE
		rreq ! rreply !  wreq ! wreply !
		cursor.off
	THEN
;


\ *** modified words from JU:SET-ICON ***
\ these must not call ?ABORT" but must use ft.abort to clean up
\ probably don't need most of the error messages but leave them for debugging

: ft.icon-open?  ( -- , just checks for 0 )
	theIcon @ 0= IF
		" ERROR: No Icon selected ... use GET-ICON" con.write.itl con.cr
		ft.abort
	THEN
;


: ft.abort-icon    ( -- , just clear it out )
	ft.icon-open? theIcon @  FreeDiskObject()
	theIcon OFF  thestrings @ FREEBLOCK
;


: $ft.get-icon	  ( adr-forth-string -- )
	\ NOTE: do NOT include the '.info' suffix in the pathname
	theIcon @ IF
		" ERROR: 'theIcon' currently holds another icon."
		con.write.itl con.cr
		ft.abort
	THEN
	COUNT >DOS DOS0   GetDiskObject() -DUP 0= IF
		" ERROR: Can't Get the ICON file!" con.write.itl con.cr
		ft.abort
	THEN
	theIcon !  MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF
		" ERROR: No memory for ICON strings!" con.write.itl con.cr
		ft.abort
	ELSE
		thestrings !
	THEN
;


: $ft.save-icon ( adr-forth-string -- )
	\ AGAIN...do not append the '.info'
	ft.icon-open?  COUNT >DOS DOS0	theIcon @  PutDiskObject() 0= IF
		" ERROR while saving DiskObject!" con.write.itl con.cr
		ft.abort
	THEN
	theIcon @  FreeDiskObject()  theIcon OFF  thestrings @ FREEBLOCK
;


\ *** support ***

: ft.greeting	( -- )
	" Release icons to be freely placed by Workbench." con.write.itl con.cr
	" (c) Copyright by Richard Mazzarisi 1989, 1990" 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.instr	( -- )
	" Instructions:"  con.write con.cr
	" 1 - Click on the icon for this program."  con.write con.cr
	" 2 - Shift click on all the icons to be floated."  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
;


: check.WB	( -- )
	\ check if running under WorkBench?
	WBMESSAGE @ NOT IF
		" Must be run under the WorkBench!" con.write.itl con.cr con.cr
		prt.instr  ft.abort
	THEN
;


: check.num.args	( -- n t | f )
\ We need at least two args to make any sense.
\ returns number of arguments and true; or false if not enough
	WBMESSAGE @ >REL ..@ sm_NumArgs  DUP 2 <  IF
		\ not enough args; tell'em how
		" You must click on at least one other icon!" con.write.itl con.cr con.cr
		prt.instr  prt.close-msg
		DROP FALSE
	ELSE
		1-  ( 1st is FloatIcon )
		TRUE
	THEN
;


: alloc.fib	( -- fib-addr )
	\ allocate memory for the File Info Block
	MEMF_CLEAR  SizeOf() FileInfoBlock  ALLOCBLOCK
	DUP NULL = IF
		" ERROR: Could not allocate FileInfoBlock!" con.write.itl
	THEN
;


: dealloc.fib	( fib-addr -- )
	DUP IF
		FREEBLOCK
	THEN
;


: get.parentdir 	{ lock | fib pdirflg dirflg ok --> dirflg ok }
\ return in dirflg t if parent is a directory, f if it is disk (root) and t/f
\ obviously dirflg is useless if all is not OK
	TRUE -> ok  TRUE -> dirflg
	alloc.fib  DUP -> fib  IF
		\ go upward recursively
		lock ParentDir()  -DUP IF
			DUP fib Examine()  DROP
			RECURSE  SWAP -> pdirflg  IF
				fib .. fib_FileName  0COUNT  build.name
				pdirflg IF
					" /" COUNT  build.name
				ELSE
					" :" COUNT  build.name
				THEN
			ELSE
				FALSE -> ok
			THEN
		ELSE
			\ stop! reached the root dir, i.e. 'disk:'
			FALSE -> dirflg
		THEN
		fib dealloc.fib
	ELSE
		FALSE -> ok
	THEN
;


: remove.final.slash	      ( stradd -- )
\ get rid of final slash or colon on the name if there
	DUP C@
	OVER + C@  ASCII / =  IF
		DUP C@ 1-  SWAP C!
	ELSE
		DROP
	THEN
;


: ?dev_name	     ( stradd -- )
\ return true if name ends in a colon
	DUP C@
	SWAP + C@  ASCII : =
;


: get.full-path 	{ wbarg | fib pdirflg ok --> ok }
\ full path of file is written into PAD
	init.name
	TRUE -> ok
	alloc.fib  DUP -> fib  IF
		\ get the directory path
		wbarg ..@ wa_Lock  fib	Examine()  DROP
		wbarg ..@ wa_Lock get.parentdir  SWAP -> pdirflg  IF
			\ get directory name
			fib .. fib_FileName  0COUNT  build.name
			pdirflg IF
				" /" COUNT  build.name
			ELSE
				" :" COUNT  build.name
			THEN
			\ get name
			wbarg ..@ wa_Name >REL 0COUNT  build.name
		ELSE
			FALSE -> ok
		THEN
		fib dealloc.fib
		PAD remove.final.slash
		PAD ?dev_name IF
			\ possibly a disk; try...
			" Disk" COUNT build.name
		THEN
	ELSE
		FALSE -> ok
	THEN
;


: float.it	( -- )
	PAD $ft.get-icon
[ clone-it @ ] .IF
	SET-NO-POSITION
	PAD $ft.save-icon
.ELSE
\ don't really do it if we are testing things in the interpreter
	ft.abort-icon
.THEN
;


: float.one	{ wbarg -- }
	\ get file's path name
	wbarg get.full-path IF
		"   " con.write
		PAD con.write con.cr
		float.it
	ELSE
		" ERROR: Could not get path for project:" con.write.itl con.cr
		"   " con.write
		wreq @ wbarg ..@ wa_Name >REL ConPutStr() con.cr
	THEN
;


: do.floats	{ #args -- }
	\ get pointer to args
	WBMESSAGE @ >REL ..@ sm_ArgList >REL
	\ 2rd and on are the icons to be floated
	#args 1+  1  DO
		DUP  SizeOf() WBArg  I *  +
		float.one
		\ check for stop action
		?CLOSEBOX IF LEAVE THEN
	LOOP
	DROP
	con.cr " Done.  " con.write.itl
;


\ *** main ***

: floaticon   ( -- )
	open.ft-things
	cursor.off
	ft.greeting
	check.WB
	check.num.args IF
		do.floats
		" Click CloseBox to exit." con.write
	THEN
	close.ft-things
;


: ft
	floaticon
;


clone-it @ .IF

initclone
clone ft
save-image FloatIcon FloatIcon -icon

.THEN

CR CR ." Type 'ft' to run." CR CR
