\ $VER: IconTools.f 1.00 (19 Jan 1992 23:05)
\ Includes all the stuff common to the IconTools
\ Written in JForth Professional 2.0
\
\ (c) Copyright 1989, 1990, 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
\
\
\ v. 1.00 1/7/92
\	  1/13/92  moved the resource management routines to this file
\ v. 1.01 1/19/92  noticed that the icon routines in ju:icon-support which
\			are called by ju:set-icon open icon.library but
\			never close it - so do both here explicitly
\


\ *** includes ***
INCLUDE? CLONE CL:TOPFILE
INCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J
INCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J
INCLUDE? GRAPHICS_GFXBASE_H JI:GRAPHICS/GFXBASE.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
INCLUDE? TASK-AUTO_REQUEST JU:AUTO_REQUEST


\ *** clone controller ***

.NEED clone-it
VARIABLE clone-it
clone-it OFF
.THEN


ANEW task-icontools


\ *** deferred words to be defined in the actual program files

DEFER open.it-window
DEFER prt.it-instr

\ *** 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
;


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


\ *** main window stuff ***

NewWindow it-newwindow


CREATE scr-buff Sizeof() Screen ALLOT


: 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
	\ get font height
	GRAPHICS_LIB @ >REL ..@ GB_DEFAULTFONT >REL ..@ tf_YSize
	\ 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
	\ get font width
	GRAPHICS_LIB @ >REL ..@ GB_DEFAULTFONT >REL ..@ tf_XSize
	\ 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
;


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


\ *** resource management ***

: close.it-things	( -- )
	con.cr prt.close-msg
	wait.close
	wreq @ 0= NOT IF
		wreply @ wreq @ rreply @ rreq @ ReleaseConsole()
		wreq OFF
	THEN
	-ICON		\ close icon.library
	GR.CLOSECURW
	GR.TERM 	\ close graphics
;


: it.abort		( -- )
	con.cr
	close.it-things
	ABORT
;


: open.it-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 	\ open graphics
	ICON?		\ open icon.library
	wreq OFF
	GR-CURWINDOW OFF
	\ open window
	open.it-window	NULL = IF
		ABORT" Could not open a window!"
	THEN
	\ make it a console
	GR-CURWINDOW @ GetConsole() NULL = IF
		close.it-things
		ABORT" Could not create a console device!"
	ELSE
		rreq ! rreply !  wreq ! wreply !
		cursor.off
	THEN
;


\ *** string stuff ***

: init.name		( dest -- )
	0 SWAP !
;


: build.name		( addr count dest -- )
\ build string in buffer at dest, must init to null with init.name before
\ using this word for the first time in building a new path name
	\ check for a non null in first place
	DUP @ 0= IF
		\ it was just initialized so just copy
		>$
	ELSE
		$APPEND
	THEN
;


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


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


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


: $it.get-icon		( adr-forth-string -- )
\ NOTE: do NOT include the '.info' suffix in the pathname
\ does not work for DRAWER icons under WB (see ju:set-icon)
\ this does however work with JazzBench
	theIcon @ IF
		" ERROR: 'theIcon' currently holds another icon."
		con.write.itl con.cr
		it.abort
	THEN
	COUNT >DOS DOS0   GetDiskObject() -DUP 0= IF
		" ERROR: Can't Get the ICON file!" con.write.itl con.cr
		it.abort
	THEN
	theIcon !  MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF
		" ERROR: No memory for ICON strings!" con.write.itl con.cr
		it.abort
	ELSE
		thestrings !
	THEN
;


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


\ *** modified words from JU:AUTO_REQUEST ***
\ want to change the dimensions and position of the requester

: 0it.auto.request	( 0body 0posi 0nega -- flag )
	AR.INIT
	ACTIVE-WINDOW
	BODYTEXT
	POSITEXT
	NEGATEXT
	0 0 320 60	      ( these are changed )
	CALL>ABS INTUITION_LIB AutoRequest
;


: $it.auto.request	( $body $posi $nega -- flag )
	AR-NEGA-CHARS AR.GET.TEXT
	AR-POSI-CHARS AR.GET.TEXT
	AR-BODY-CHARS AR.GET.TEXT
	AR-BODY-CHARS AR-POSI-CHARS AR-NEGA-CHARS
	0it.auto.request
;


\ *** support ***

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


: check.num.args	( nreq -- n t | f )
\ We need at least 'nreq' args to make any sense.
\ Returns the actual number of arguments to act on and true;
\   or false if not enough.
	WBMESSAGE @ >REL ..@ sm_NumArgs  DUP ROT <  IF
		\ not enough args; tell'em how
		" Too few arguments!" con.write.itl con.cr con.cr
		prt.it-instr
		DROP FALSE
	ELSE
		1-  ( 1st arg is the prog itself )
		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 -- )
	\ deallocate memory for the File Info Block
	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  PAD build.name
				pdirflg IF
					" /" COUNT  PAD build.name
				ELSE
					" :" COUNT  PAD 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
	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  PAD  build.name
			pdirflg IF
				" /" COUNT  PAD  build.name
			ELSE
				" :" COUNT  PAD  build.name
			THEN
			\ get name
			wbarg ..@ wa_Name >REL 0COUNT  PAD  build.name
		ELSE
			FALSE -> ok
		THEN
		fib dealloc.fib
		PAD remove.final.slash
		PAD ?dev_name IF
			\ possibly a disk; try...
			" Disk" COUNT PAD build.name
		THEN
	ELSE
		FALSE -> ok
	THEN
;