\ graphical classes
\
\ gr_view
\ class of screen and device that just graphically displays data, but
\ doesn't automatically respond to mouse or qwerty events.
\
\ Code: Han-earl Park
\ Copyright	2000 Buster & Friends C-ALTO Labs
\ (Valencia, December 1999 -
\ (Southampton, May 2000 -
\
\ MOD: HeP 12/08/99	Started project.
\ MOD: HeP 05/24/00	The gr.space and gr.particle classes are now subclasses
\					of gr.view and graphic respecively. Copy some of
\					hp_screen code to this file.
\					The INIT: method of gr.view calls DEFAULT:
\ MOD: HeP 09/21/00	Check that window is open in graphic class' DRAW: method.
\ MOD: HeP 10/05/00	Use graphics words defined in graph_plus.
\ MOD: HeP 10/06/00	Add stubs to gr.view class for mouse handling.
\ MOD: HeP 10/13/00	Rename the old PUT.TEXT: and GET.TEXT: as PUT.STRING and
\					GET.STRING: in ob.gr.text. PUT.TEXT: and GET.TEXT: now
\					takes address and count as arguments return values
\					respectively.
\
\ ToDo:	Allow drawing in other windows (i.e. other than hmsl-window).
\		Check the view class' DRAW: method (i.e. change hmsl.set.window).

include?  task-graph_plus  myt:graph_plus
include?  task-device      myt:device


anew task-gr_view


\ graphical device

method PUT.COLOR:			method GET.COLOR:

method RAW.DRAW:			method RAW.UNDRAW:
method MOVE.DC:				method STRETCH.DC:

:class  OB.GRAPHIC  <super  OB.DEVICE
	
	iv.byte  iv-gr-drawn?
	
	iv.byte  iv-gr-color
	
	iv.short iv-gr-x
	iv.short iv-gr-y
	iv.short iv-gr-w
	iv.short iv-gr-h
	
	
:m DEFAULT:	(  --  )
	default: super
\
	false iv=> iv-gr-drawn?
\
	1  iv=> iv-gr-color
\
	100  iv=> iv-gr-x
	100  iv=> iv-gr-y
	100  iv=> iv-gr-w
	100  iv=> iv-gr-h
;m


\ drawing

: GR.DRAW.RECT	(  --  )
	iv-gr-x
	iv-gr-y
	iv-gr-x iv-gr-w +
	iv-gr-y iv-gr-h +  gr.rect
;

: GR.UNDRAW.RECT	(  --  )
	0 gr.color!  gr.draw.rect
;


:m ?DRAWN:	(  -- flag , true if currently drawn )
	iv-gr-drawn?
;m


:m RAW.DRAW:	(  --  , subclass should override this method )
	
;m

:m RAW.UNDRAW:	(  --  )
	gr.undraw.rect
;m


:m DRAW:	(  --  )
	gr-curwindow @
	IF
		iv-gr-drawn?
		IF	gr.undraw.rect
		THEN
	\
		iv-gr-color gr.color!  self  raw.draw: []
	\
		true  iv=> iv-gr-drawn?
	ELSE
		" draw:" " no window set to draw in" er_warning
		ob.report.error
	THEN
;m

:m UNDRAW:	(  --  )
	gr-curwindow @
	IF
		self  raw.undraw: []
	\
		false iv=> iv-gr-drawn?
	ELSE
		" undraw:" " no window set to draw in" er_warning
		ob.report.error
	THEN
;m


\ position and dimensions

:m PUT.XY:	( x y --  )
	scg.wc->dc
	iv=> iv-gr-y  iv=> iv-gr-x
;m

:m GET.XY:	(  -- x y )
	iv-gr-x  iv-gr-y
	scg.dc->wc
;m

:m PUT.WH:	( width height --  )
	scg.delta.wc->dc
	iv=> iv-gr-h  iv=> iv-gr-w
;m

:m GET.WH:	(  -- width height )
	iv-gr-w  iv-gr-h
	scg.delta.dc->wc
;m

:m MOVE:	( dx dy --  , shift position of graphic )
	
;m

:m STRETCH:	( dWidth dHeight --  , change shape )
	
;m


\ in device coords

:m PUT.XY.DC:	( x y --  )
	iv=> iv-gr-y  iv=> iv-gr-x
;m

:m GET.XY.DC:	(  -- x y )
	iv-gr-x  iv-gr-y
;m

:m PUT.WH.DC:	( width height --  )
	iv=> iv-gr-h  iv=> iv-gr-w
;m

:m GET.WH.DC:	(  -- width height )
	iv-gr-w  iv-gr-h
;m

:m MOVE.DC:		( dx dy --  , shift position of graphic )
	
;m

:m STRETCH.DC:	( dWidth dHeight --  , change shape )
	
;m


\ color

:m PUT.COLOR:	( indx --  )
	iv=> iv-gr-color
	draw: self
;m

:m GET.COLOR:	(  -- indx )
	iv-gr-color
;m


\ for compatibility

:m MOUSE.DOWN:	( x y -- false , dummy method to be called from screen )
    2drop  false
;m


\ print

:m PRINT:	(  --  )
	print: super
\
	." Drawn?   = "  true  IF  ." Yes"  ELSE  ." No"  THEN  cr
	." Visible? = "  false IF  ." Yes"  ELSE  ." No"  THEN  cr
	." Color    = "  cr
	." Device Coordinates:"  cr
	space ." x , y  ="  get.xy.dc: self  swap  4 .r ." , " 4 .r  cr
	space ." w , h  ="  get.wh.dc: self  swap  4 .r ." , " 4 .r  cr
	." World Coordinates:"   cr
	space ." x , y  ="  get.xy: self     swap  4 .r ." , " 4 .r  cr
	space ." w , h  ="  get.wh: self     swap  4 .r ." , " 4 .r  cr
;m

;class



\ graphical line

:class  OB.GR.LINE  <super  OB.GRAPHIC
	
;class



\ graphical rectangle

:class  OB.GR.RECT  <super  OB.GRAPHIC
	
	
;class



\ graphical oval

:class  OB.GR.OVAL  <super  OB.GRAPHIC
	
	
;class



\ graphical text class

method PUT.STRING:			method GET.STRING:
method PUT.FONT:			method PUT.SIZE:

:class  OB.GR.TEXT  <super  OB.GRAPHIC
	
	iv.byte  iv-grtxt-count
	iv.long  iv-grtxt-string
	
	iv.byte  iv-grtxt-size
	iv.byte  iv-grtxt-font
	
	
:m INIT:	(  --  )
	init: super
	0  iv=> iv-grtxt-count
	0  iv=> iv-grtxt-string
;m

:m DEFAULT:	(  --  )
	default: super
	12  iv=> iv-grtxt-size
	00  iv=> iv-grtxt-font
;m


:m PUT.FONT:	( font --  )
	iv=> iv-grtxt-font
;m

:m PUT.SIZE:	( size --  )
	iv=> iv-grtxt-size
;m


:m RAW.DRAW:	(  --  )
	iv-grtxt-string
	IF
		gr.font@  gr.height@
	\
		iv-grtxt-font  gr.font!
		iv-grtxt-size  gr.height!
	\
		iv-gr-x iv-gr-y iv-grtxt-size +  gr.move
	\
		iv-grtxt-count
		IF
			iv-grtxt-string  iv-grtxt-count  gr.type
		ELSE
			iv-grtxt-string  gr.text
		THEN
	\
		gr.height!  gr.font!
	THEN
;m


:m PUT.STRING:	( string --  , assign and display text string )
	0  iv=> iv-grtxt-count
	iv=> iv-grtxt-string
	iv-gr-drawn?
	IF  draw: self
	THEN
;m

:m GET.STRING:	(  -- string )
	iv-grtxt-string
;m

:m PUT.TEXT:	( addr count --  , assign text string character count )
	iv=> iv-grtxt-count
	iv=> iv-grtxt-string
	iv-gr-drawn?
	IF  draw: self
	THEN
;m

:m GET.TEXT:	(  -- addr count )
	iv-grtxt-count
	IF
		iv-grtxt-string  iv-grtxt-count
	ELSE
		iv-grtxt-string  count
	THEN
;m


:m PRINT:	(  --  )
	print: super
\
	iv-grtxt-count
	IF
		." Count = "  iv-grtxt-count                  4 .r  cr
		." Text  = "  iv-grtxt-string iv-grtxt-count  type  cr
	ELSE
		." Text  = "  iv-grtxt-string  $.  cr
	THEN
;m

;class



\ view class

method PUT.KEY.FUNCTION:

:class  OB.GR.VIEW  <super  OB.SCREEN
	
	iv.byte  iv-grvw-color
	iv.long  iv-grvw-key-cfa
	
	
:m INIT:	(  --  )
	init: super
\
	self  default: []
;m

:m DEFAULT:	(  --  )
	0  iv=> iv-grvw-color
	0  iv=> iv-grvw-key-cfa
;m


:m NEW:		( n --  , allocate space for n graphical objects )
	1 new: super-dooper
	self add: custom-screens
;m

:m FREEALL:	(  --  , just frees self )
	free: self
;m

inherit.method  DELETE:  ob.list
inherit.method  0STUFF:  ob.list
inherit.method  }STUFF:  ob.list


\ background color

:m PUT.COLOR:	(  --  )
	iv=> iv-grvw-color
;m

:m GET.COLOR:	(  --  )
	iv-grvw-color
;m


\ drawing

: (GRVW.SCREEN.DRAW)	(  --  )
	cg-drawing-screen @ 0= dup
	IF	cg-drawing-screen  on
	THEN
\
	0 scg.selnt		\ set normalization transform for CGs  (HeP: Huh?)
\
	gr.color@
	iv-grvw-color  gr.color!
	0 0 1500 1000  gr.rect
	gr.color!
\
	iv-sc-draw-cfa ?dup
	IF	0 exec.stack?
	THEN
\
	many: self  0
	DO	i get: self  draw: []
	LOOP
\
	IF	cg-drawing-screen  off
		self  cg-current-screen !
	THEN
;

:m DRAW:	(  --  )
	hmsl-window @			\ ???
	IF
		hmsl.set.window
		cg-current-screen @ ?dup
		IF	undraw: []
		THEN
		(grvw.screen.draw)
		true iv=> iv-sc-drawn
	ELSE
		" draw:" " no window to draw: in!"
		er_fatal er.report
		cg-current-screen off
	THEN
;m

:m UNDRAW:	(  --  )
	gr-curwindow @			\ ???
	IF	many: self  0
		DO	i get: self  undraw: []
		LOOP
	\
		iv-sc-undraw-cfa ?dup
		IF	0 exec.stack?
		THEN
		false iv=> iv-sc-drawn	\ ????
	THEN
	0 cg-current-screen !
	0 cg-drawing-screen !
;m


\ stubs for mouse control

:m MOUSE.DOWN:	( x y -- flag )
	2drop  false
;m

:m MOUSE.UP:	( x y --  )
	2drop	
;m

:m MOUSE.MOVE:	( x y --  )
	2drop
;m


\ qwerty keyboard input

:m PUT.KEY.FUNCTION:	( cfa --  )
	iv=> iv-grvw-key-cfa
;m

:m KEY:	( char --  )
	iv-grvw-key-cfa
	IF
		toupper					\ convert character to upper case
		self iv-grvw-key-cfa	\  -- char addr cfa
		-2 exec.stack?			\  --
	ELSE
		drop
	THEN
;m


:m PRINT.ELEMENT:	( elm# --  )
	get: self dup name: []  tab  .class: []
;m

:m PRINT:	(  --  )
	print: super
	." KEY function = "  iv-grvw-key-cfa  cfa.  cr
;m

;class


\ test

false .IF
	
	ob.job  tgr-job
	
	ob.gr.view  tgr-view
	
	ob.gr.rect  tgr-rect
	ob.gr.oval  tgr-oval
	ob.gr.text  tgr-text
	
	
	: RND.TEXT	( job --  )
		
	;
	
	: RND.RECT	( job --  )
		
	;
	
	: RND.OVAL	( job --  )
		
	;
	
	
	: TGR.INIT	(  --  )
		stuff{  tgr-rect     tgr-oval     tgr-text     }stuff: tgr-view
		stuff{  'c rnd.text  'c rnd.rect  'c rnd.oval  }stuff: tgr-job
	;
	
	: TGR.TERM	(  --  )
		freeall: tgr-view
		free: tgr-job
	;
	
	: TEST.GR	(  --  )
		tgr.init  hmsl  tgr.term
	;
	
.THEN