\ file_elmnts
\
\ class elmnts that can be saved/loaded as a binary file. Allows
\ multi-dimensional data to be stored and retrieved.
\
\
\ description:
\
\	NEW:		( #elm #dim --  , create space in memory without saving )
\	OPEN:		(  -- flag , open file and read contents )
\	CLOSE:		(  --  , close file if open )
\	SAVE:		(  -- flag , save to disk )
\	SAVE.AS:	(  -- flag , create new file and save to disk )
\	REVERT:		(  -- flag , revert to saved version )
\
\ the above messages above roughly correspond to standard file menu commands.
\
\ You can also specify a directory by using:
\
\	OPEN.FROM:	( $dir | 0 -- flag , open at specified or default directory )
\	SAVE.TO:	( $dir | 0 -- flag , save to specified or default directory )
\
\ note that passing 0 in stead of a directory will result in saving/opening
\ the file in the default directory. In both methods above, unless a file
\ name has been set first ob.file.elmnts will create, or attempt to open, an
\ "untitled" document.
\
\ file names can be set or retrieved using the following:
\
\	PUT.FILE.NAME:	( $fname | 0 --  , assign file name for before saving )
\	GET.FILE.NAME:	(  -- $fname , retrieve file name )
\
\ some methods return a flag which is set to true if sucessful. Should an
\ error occur, a false value will be returned and the error will be handled
\ via the ERROR: method.
\
\	ERROR:	(  --  , handle/report error ) 
\
\ since ob.file.elmnts is a subclass of ob.elmnts, any NEW: should be balanced out
\ with FREE: (which additionally closes the file if open).
\
\	FREE:	(  --  , free memory and close file if open )
\
\ the actual verification, reading and writing of the file is carried out by
\ the following methods:
\
\	READ:	(  -- flag , verify and copy contents of file to memory )
\	WRITE:	(  -- flag , copy contents of memory to file )
\
\	VERIFY:	( file -- flag , true if correct file format )
\
\ these are called late bound, so subclasses may override their behavior.
\ Reading of the file will not proceed if VERIFY: returns false.
\
\ subclasses can also define a default state when NEW:ed:
\
\	DEFAULT:	(  --  , stub for subclasses )
\
\ the save/open state can be ascertained by:
\
\	?OPEN:	(  -- flag , true if file is open )
\	?SAVED:	(  -- flag , true if file has been saved )
\
\
\ code: Han-earl Park
\ copyright 2004 buster & friends' C-ALTO Labs
\ (Southampton, April 2004 -
\
\ MOD: HeP 04-15-04	Code originally develeoped for io.
\					Split off from io and generalize class for other use.
\ MOD: HeP 04-16-04	Tested save/write, open/read and close.
\ MOD: HeP 04-17-04	Rather than making this host independent from the start,
\					I am coding this Mac specific for the moment.
\ MOD: HeP 04-18-04	Clearup stack behavior of methods.
\					Add GET/PUT.FILE.NAME: and implement SAVE.TO: and ERROR:
\					methods.
\ MOD: HeP 04-19-04	Mac specific: set file type and creator.
\					Implement Mac error reporting.
\ MOD: HeP 04-25-04	Add OPEN.FROM: method.
\					Fix stack behavior of ERROR:
\ MOD: HeP 04-29-04	Remove the mac specific support (move mac specific code to
\					file_elmnts_mac). Rewrite some of the methods so that
\					they are _independent_ of host OS.
\					Add documentation.
\ MOD: HeP 05-14-04	File names are stored in object so are no longer
\					overwritten by an external process.
\ MOD: HeP 05-15-04	Since file name is stored internally, the null file name
\					("untitled") is assigned copy copying to menory.
\					Access to file name is exclusively via late bound calls to
\					GET/PUT.FILE.NAME: (makes subclass overriding easier).
\ MOD: HeP 06-21-04	VERIFY: actually checks file format rather than leaving
\					this to subclasses.
\ MOD: HeP 06-27-04	Add variable ferror-format and report file format errors
\					as part of ERROR: method.
\					Consistently clear error flags at the start of all methods
\					that check for errors.
\					Report file errors in REVERT:
\ MOD: HeP 07-14-04	Add FILE.TRUNCATE which circumvents the redefining of
\					FTRUNCATE in hsys:floatingpoint.


anew task-file_elmnts


false  value  felm_dialog_error?	\ report errors in dialog box?


host=mac .IF
	
	31  constant  fname_count	\ max file name length on mac
	
.ELSE
	
	127  constant  fname_count	\ max file name length
	
.THEN


\ hsys:floatingpoint redefines ftruncate
\
\ the logical thing to do would be to rename ftruncate in hsys:floatingpoint,
\ but since I've save-forth'ed floatingpoint, for the moment I use the
\ following kludge

exists? task-floatingpoint
exists? fptruncate NOT		\ maybe renamed floating point word
AND
.IF
	
	: FIND.FTRUNCATE  (  -- cfa )
		0 >r
	\
		" FTRUNCATE"	\  -- $
		latest			\  -- $ nfa
	\
		BEGIN
			prevname	\  -- $ nfa
		\
			dup 0<>
			r@ 2 <  AND
		WHILE
			2dup $=
			IF
				r@ 0=
				IF
				\
				\ newer "ftruncate" from hsys:floatingpoint
				\
					rdrop  1 >r
				ELSE
				\
				\ older "ftruncate"...
				\
					tuck	\  -- nfa $ nfa
					rdrop  2 >r
				THEN
			THEN
		REPEAT
		2drop				\  -- nfa
	\
		rdrop
	\
		name>				\  -- cfa
	;
	
	: FILE.TRUNCATE	( fileId -- bytes )
		[ find.ftruncate use->rel ] literal  rel->use ?execute
	;
	
.ELSE
	
	: FILE.TRUNCATE	( fileId --  )
		ftruncate
	;
	
.THEN


variable  ferror-format		\ true if invalid file format


method  NEW:
method  OPEN:
method  CLOSE:

method  SAVE:
method  SAVE.AS:
method  REVERT:

method  OPEN.FROM:
method  SAVE.TO:

method  READ:
method  WRITE:

method  ?OPEN:
method  ?SAVED:

method  PUT.FILE.NAME:
method  GET.FILE.NAME:

method  ERROR:
method  VERIFY:


:class  OB.FILE.ELMNTS  <super  OB.ELMNTS
		
	fname_count 1+ iv.bytes  iv-felm-file-name
	
	iv.long  iv-felm-file-ptr
	
	iv.byte  iv-felm-open?
	iv.byte  iv-felm-saved?
	
	
	
: FELM.SET.UNTITLED	(  --  , set name to untitled )
	" untitled" iv&> iv-felm-file-name  $MOVE
;


:m INIT:	(  --  )
	init: super
\
	felm.set.untitled
\
	0     iv=> iv-felm-file-ptr
	false iv=> iv-felm-open?
	false iv=> iv-felm-saved?
;m


:m PUT.FILE.NAME:	( $fname | 0 --  )
	dup
	IF
		dup c@  fname_count <=
		IF
			iv&> iv-felm-file-name  $MOVE
		ELSE
		\
		\ name is too long, so copy only as much as possible and set count
		\ to max legal length
		\
			1+  iv&> iv-felm-file-name 1+  fname_count  MOVE
			fname_count  iv&> iv-felm-file-name  c!
		\
			" put.file.name:"  " file name is too long"
			er_warning  ob.report.error
		THEN
	ELSE
		drop
		felm.set.untitled
	THEN
;m

:m GET.FILE.NAME:	(  -- $fname )
	iv&> iv-felm-file-name
;m


\ create, open and close files

:m DEFAULT:	(  --  , stub for subclasses )
;m


:m VERIFY:	( file -- flag , verify file format )
	dup  0  offset_beginning  FSEEK  drop
\
	{ | #elm #dim -- } NO@
\
	dup  #elm  4  FREAD  4 =
	over #dim  4  FREAD  4 =  AND
\
	#elm @  max.elements: self <=  AND
	#dim @  dimension: self =      AND
\
	swap  #elm @ #dim @ * cells  offset_beginning  FSEEK  0>=  AND
;m


:m NEW:	( #elm #dim --  , create new file without saving )
	new: super
\
	felm.set.untitled
\
	0     iv=> iv-felm-file-ptr
	false iv=> iv-felm-open?
	false iv=> iv-felm-saved?
\
	self  default: []
;m


: FELM.ERROR	( flag --  , handle/report error )
	0=
	IF	self ERROR: []		\ crash if we don't check the flag?
	THEN
;

: FELM.CLEAR.ERRORS	(  --  , clear error flags )
	0  ferror !
	0  ferror-format !
;


: FELM.READ.FILE	(  -- flag )
	iv-felm-file-ptr  0  offset_beginning  FSEEK  drop
\
	{ | #elm #dim -- } NO@
\
	iv-felm-file-ptr  #elm  4  FREAD  4 =
	iv-felm-file-ptr  #dim  4  FREAD  4 =  AND
	dup
	IF	drop
		#elm @  max.elements: self <=
		#dim @  dimension: self =  AND
		dup
		IF	drop
		\
			iv-felm-file-ptr			\  -- file
			data.addr: self				\  -- addr
			#elm @ #dim @ * cells		\  -- count
			FREAD						\ file addr count -- bytes_read
			#elm @ #dim @ * cells =
			dup
			IF	#elm @  set.many: self
			THEN
		THEN
	THEN
;

:m READ:	(  -- flag , verify and copy contents of file to memory )
	iv-felm-file-ptr
	iv-felm-open?  AND
	dup
	IF	drop
	\
		iv-felm-file-ptr  self VERIFY: []
		dup
		IF
			drop
		\
			0  set.many: self
			felm.read.file		\  -- flag
		ELSE
			true  ferror-format !
		THEN
	THEN
;m


:m OPEN:	(  -- flag , open file and read contents )
	felm.clear.errors
\
	" Open:"
	dialog.get.file		\ $prompt -- $fname file_Id true | false
	dup
	IF	drop
	\
		iv=> iv-felm-file-ptr
	\
		self  put.file.name: []
	\
		true iv=> iv-felm-open?
		true iv=> iv-felm-saved?
	\
		self READ: []		\  -- flag
	THEN
\
	dup  felm.error
;m

:m CLOSE:	(  --  , close file if open )
	iv-felm-file-ptr
	iv-felm-open?  AND
	IF	iv-felm-file-ptr fclose
		false iv=> iv-felm-open?	\ but keep the file ptr just in case
	THEN
;m


\ save and write files

: FELM.WRITE.FILE	(  -- flag )
	iv-felm-file-ptr  0  offset_beginning  FSEEK  drop
\
	iv-felm-file-ptr  iv&> iv-many       4  FWRITE  4 =
	iv-felm-file-ptr  iv&> iv-dimension  4  FWRITE  4 =  AND
	dup
	IF	drop
	\
		iv-felm-file-ptr				\  -- file
		data.addr: self					\  -- addr
		iv-many iv-dimension * cells	\  -- count
		FWRITE							\ file addr count -- bytes_written
		iv-many iv-dimension * cells =
	THEN
\
	iv-felm-file-ptr  file.truncate  drop
;

:m WRITE:	(  -- flag , copy contents of memory to file )
	iv-felm-file-ptr
	iv-felm-open?  AND
	dup
	IF	drop
	\
		felm.write.file
	THEN
;m


:m SAVE.AS:	(  -- flag , save to a new file )
	felm.clear.errors
\
	self  get.file.name: []
\
	" Save this document as:"
	dialog.put.file	\ $original $promt -- $fname refnum true | false
	dup
	IF	drop
	\
		iv=> iv-felm-file-ptr
	\
		self  put.file.name: []
	\
		true iv=> iv-felm-open?
		true iv=> iv-felm-saved?
	\
		self WRITE: []		\  -- flag
	THEN
\
	dup  felm.error
;m

:m SAVE:	(  -- flag , save changes if exists )
	iv-felm-file-ptr
	iv-felm-open?  AND
	IF
		true iv=> iv-felm-open?
		true iv=> iv-felm-saved?
	\
		self WRITE: []		\  -- flag
	ELSE
		save.as: self		\  -- flag
	THEN
;m


\ open from and save to specified directory

host=mac .IF
	
	ascii :  constant  file_separator
	
.ELSE
	
	ascii /  constant  file_separator
	
.THEN


create $felm_dir_pad 256 allot


:m OPEN.FROM:	( $dir | 0 -- flag , open at specified or default directory )
	felm.clear.errors
\
	?dup
	IF
		0 $felm_dir_pad c!
	\
		count  $felm_dir_pad $append
		$felm_dir_pad count + 1-  c@	\ get last characted
		file_separator
		<>
		IF	$felm_dir_pad  file_separator  $append.char
		THEN
		self  get.file.name: []  count  $felm_dir_pad $append
	\
		$felm_dir_pad
	ELSE
		self  get.file.name: []
	THEN
	$FOPEN
	dup
	IF	iv=> iv-felm-file-ptr
	\
		true iv=> iv-felm-open?
		true iv=> iv-felm-saved?
	\
		self READ: []		\  -- flag
	THEN
\
	dup  felm.error
;m

:m SAVE.TO:	( $dir | 0 -- flag , save to specified or default directory )
	felm.clear.errors
\
	?dup
	IF
		0 $felm_dir_pad c!
	\
		count  $felm_dir_pad $append
		$felm_dir_pad count + 1-  c@	\ get last characted
		file_separator
		<>
		IF	$felm_dir_pad  file_separator  $append.char
		THEN
		self  get.file.name: []  count  $felm_dir_pad $append
	\
		$felm_dir_pad
	ELSE
		self  get.file.name: []
	THEN
	new  $FOPEN
	dup
	IF	iv=> iv-felm-file-ptr
	\
		true iv=> iv-felm-open?
		true iv=> iv-felm-saved?
	\
		self WRITE: []		\  -- flag
	THEN
\
	dup  felm.error
;m

:m REVERT:	(  -- flag )
	felm.clear.errors
\
	iv-felm-file-ptr
	iv-felm-open?  AND
	IF
		true iv=> iv-felm-saved?
	\
		self READ: []		\  -- flag
	ELSE
		false
	THEN
\
	dup  felm.error
;m


\ open & save state

:m ?OPEN:	(  -- flag )
	iv-felm-open?
;m

:m ?SAVED:	(  -- flag )
	iv-felm-saved?
;m


\ clearup

:m FREE:	(  --  , free memory and close file if open )
	self close: []
	free: super
;m


\ error handling

: FELM.REPORT.ERROR	( $message --  , report error message )
	felm_dialog_error?
	IF
		dialog.a
	ELSE
		>newline $.
	THEN
;

host=mac .IF
	
	: ($MAC.FILE.ERROR)   ( error# -- $message )
		CASE
			-33	OF	" File directory full."
				ENDOF
			-34	OF	" Disk is full."
				ENDOF
			-35	OF	" Specified volume does not exist."
				ENDOF
			-36	OF	" I/O error."
				ENDOF
			-37	OF	" Bad name. 0 length?"
				ENDOF
			-38	OF	" File not open."
				ENDOF
			-39	OF	" End of file reached."
				ENDOF
			-40	OF	" Attempt to position before start."
				ENDOF
			-41	OF	" Memory full."
				ENDOF
			-42	OF	" Too many files open."
				ENDOF
			-43	OF	" File not found."
				ENDOF
			-44	OF	" Volume locked, release tab."
				ENDOF
			-45	OF	" File is locked."
				ENDOF
			-46	OF	" Volume locked by software."
				ENDOF
			-47	OF	" File is busy."
				ENDOF
			-48	OF	" File already exists."
				ENDOF
			-49	OF	" File already open for write."
				ENDOF
			-50	OF	" Error in Parameter List."
				ENDOF
			-51	OF	" Bad path reference number."
				ENDOF
			-52	OF	" Error in GetFpos."
				ENDOF
			-53	OF	" Volume not on-line."
				ENDOF
			-54	OF	" Read Permission only."
				ENDOF
			-55	OF	" Specified Volume already mounted."
				ENDOF
			-56	OF	" No such drive."
				ENDOF
			-57	OF	" Not a Macintosh disk."
				ENDOF
			-58	OF	" External file system."
				ENDOF
			-59	OF	" Problem during rename."
				ENDOF
			-60	OF	" Bad master directory block, must reinitialize volume."
				ENDOF
			-61	OF	" Write permission denied."
				ENDOF
		\
			" Unrecognized error."  swap 
	    ENDCASE
	;
	
	: $MAC.FILE.ERROR	( error# | 0 -- $message | 0 )
		dup
		IF	" Error of type " pad  $move
			dup  n>text       pad  $append
			" . "  count      pad  $append
			pad  EOL  $append.char
		\
			($mac.file.error) count  pad  $append
		\
			pad
		THEN
	;
	
	:m ERROR:	(  --  , handle/report error )
		ferror-format @
		IF
			" Unknown file format."  felm.report.error
		ELSE
			ferror @  $mac.file.error 
			?dup
			IF	felm.report.error
			THEN
		THEN
	;m

.ELSE
	
	:m ERROR:	(  --  , handle/report error )
		ferror-format @
		IF
			" Unknown file format."  felm.report.error
		THEN
	;m
	
.THEN


\ print

:m PRINT:	(  --  )
	print: super
\
	." File Name    = "  self  get.file.name: []  $.    cr
	."      Pointer = "  iv-felm-file-ptr         4 .r  cr
	."      Open?   = "  iv-felm-open?            4 .r  cr
	."      Saved?  = "  iv-felm-saved?           4 .r  cr
;m

;class



\ test

false .IF
	
	ob.file.elmnts  fet-1
	
	: FET.SCRAMBLE	(  --  )
		0  set.many: fet-1
	\
		max.elements: fet-1 choose  0
		DO	10 choose
			dup  10 *
			swap 100 *
			add: fet-1
		LOOP
	;
	
	
	: (FE.TEST)	(  --  )
		BEGIN
			print: fet-1
			>newline
			." qwerty:"  cr
			." S  =      save: fet-1"  cr
			." A  =   save.as: fet-1"  cr
			." T  =   save.to: fet-1"  cr
			." O  =      open: fet-1"  cr
			." F  = open.from: fet-1"  cr
			." C  =     close: fet-1"  cr
			." R  =    revert: fet-1"  cr
			." P  =     print: fet-1"  cr
			." BL =   randomize data"  cr
			." Q  =             quit"  cr
			key  toupper
			CASE
				ascii S  OF  save: fet-1        .  false  ENDOF
				ascii A  OF  save.as: fet-1     .  false  ENDOF
				ascii T  OF  0 save.to: fet-1   .  false  ENDOF
				ascii O  OF  open: fet-1        .  false  ENDOF
				ascii F  OF  0 open.from: fet-1 .  false  ENDOF
				ascii C  OF  close: fet-1          false  ENDOF
				ascii R  OF  revert: fet-1      .  false  ENDOF
				ascii P  OF  print: fet-1          false  ENDOF
				BL       OF  fet.scramble          false  ENDOF
				ascii Q  OF	 true                         ENDOF
			\
				false swap
			ENDCASE
		UNTIL
	;
	
	
	: FET.INIT	(  --  )
		8 2  new: fet-1
	\
		max.elements: fet-1 0
		DO	i 10 *
			i 100 *
			add: fet-1
		LOOP
	;
	
	: FET.TERM	(  --  )
		free: fet-1
	;
	
	if.forgotten  fet.term
	
	
	: FE.TEST	(  --  )
		fet.init  (fe.test)  fet.term
	;
	
	
	cr ." Enter FE.TEST to test the file.elmnts class..." cr cr
	
.THEN