[comp.graphics] Scroll list class

mh@wlbr.EATON.COM (Mike Hoegeman) (05/12/88)

howdy..
This is part of a larger NeWS forms package that I'm currently building.

I wasn't going to post this till I polished it up some more ( put scroll bars 
in , etc...) but I have to put in a bunch of stuff for interfacing with the
oracle rdbms so it looks like I might not get back to it for awhile so
I'll go ahead and post it now. If anyone actually uses this and has 
suggestions or improvements they've made to it please drop me a note.
to try it out just snip at the marker below and run it through psh.

Sorry about the lack of documentation 

Also , you'll see some cps stuff in here which goes along with
some C-code for use in scrolling BIG chunks of data.  the C-code
uses some code that is not all mine so  I'm not going to post
that unless there's a demand for it.

%=========== SNIP HERE SNIP HERE SNIP HERE SNIP HERE SNIP HERE ========


%+
% Module: scrfld.ps
% Author: Mike Hoegeman
% Function: scroll field class
% Notes:
% Modification History:
% Date		Author		Reason
% -------------------------------------------------------------
% 01May88	MCH		Initial Release.
% -------------------------------------------------------------
%-

/ScrFld Object 
%% ================= Instance Variables =============================
dictbegin
    /SFEvtMgr nulldict def
    /SFMenu nulldict def
    /SFLabel null def
    /SFMaxSelects 15 def %% max selects allowed for this field
    /SFSelList [] def
    /SFCanvas nulldict def %% canvas for this field
    /SFParent nulldict def %% parent can for this field
    /SFX 0 def
    /SFY 0 def
    /SFW 0 def
    /SFH 0 def
    /SFFillColor 0 0 1 hsbcolor def
    /SFEColor .778 .900 1.0 hsbcolor def
    /SFOColor 0 0 0 hsbcolor def
    /SFSelColor 1 1 1 hsbcolor def
    /SFTextColor SFOColor def
    /SFFontSize 12 def
    /SFFont /Courier findfont SFFontSize scalefont def
    /SFLMargin 2 def %% left margin for data
    /SFData nulldict def %% handle to where the data lives
    /SFDataBuf null def
    /HideMark (#) def %% stuff is hidden before this character
    /User nulldict def %% cubbyhole for user stuff...

    %% these are use for paging data between client and us 
    /SFCPS nulldict def %% cps glue dict, installed by client (if there is one)
    /DataOnClient? false def
    /Home (_?UnknownHome?_) def %% proc that pushes on stack
				  %% the dict that we live in

    %% scrolling gadget stuff - don't have scroll bars yet
    /GdgtW 16 def
    /PgControl nulldict def
dictend

classbegin

%% ================= Class Variables ================================

%% ================= Methods ========================================

%+
% classname:	- => /class_name
% Function:	return the name of the class
%-
/classname {
    /ScrFld
} def

%+
% new:		x y w h parentcanvas => instance
%-
/new {
    /new super send begin
	/SFParent exch store
	/SFH exch store /SFW exch store 
	/SFY exch store /SFX exch store

	%% if there is a client we are interacting with, he's defined the 
	%% cps glue dict in userdict, pull it in to the instance were we 
	%% can see it
	userdict /SFCPS known { /SFCPS userdict /SFCPS get def } if
    currentdict end
} def

%+
% destroy:	- => -
%-
/destroy {
    /unmap self send

    %% null out any possible objects that are memory intensive.
    /SFCanvas null store
    /PgCanvas null store

    SFEvtMgr  killprocess store
    /SFEvtMgr null store

    /SFData nulldict store
    /SFUser nulldict store
} def

%+
% set:		[(string1).... (stringN)] => -
%	or..    (datatag) (type) (desc)
% Function: 	define the data to be scrolled.
%-
/set {
    dup

    type /arraytype eq {
	%% all scroll buf data  is local
	%% => -

	/SFData 5 dict store
	SFData begin
	    /Data exch def
	    /TElem 0 def
	    /TLine 0 def
	    /BElem 0 def
	    /BLine 0 def
	end

	/DataOnClient? false store
	/SFDataBuf SFData /Data get store
    } {
	%% scroll buf data is on client
	%% => (datatag) (type) (desc)

	SFCPS nulldict eq {
	    (/user/bin/msg scrfld.ps: where's my SFCPS dict?\n) forkunix
	    pause quit
	} if

	/SFData 5 dict store
	SFData begin 
	    /Data 3 index def 
	    /TElem 0 def
	    /TLine 0 def
	    /BElem 0 def
	    /BLine 0 def
	end
	/DataOnClient? true store

	%% tell client to load up a scroll field lineset with what
	%% we want and then ship us the first scroll region's worth
	%% of data.

	/SFDataBuf null store
	SFCPS begin 
	    %% => (datatag) (type) (desc)
	    SFgetdata
	end %% SFCPS

	%% tell client to give us the first scroll region's worth
	(waiting...) [] dbgprintf
	{
	    0 1 60 { pop pause pause pause } for
	    SFDataBuf null ne { exit } if
	    (.) [] dbgprintf
	} loop

    } ifelse

} def

%+
% MakeSelInterests:	canvas => - 
% Function:		create the EIS selection interests and tweaks them
%			so they're palatable to the "forkeventmgr" utility.
%-
/MakeSelInterests { 
    addselectioninterests %% consume canvas arg here

    aload pop

    %% tell the evt mgr to ignore EIS's private events
    begin
	/ClientData 10 dict dup begin
	    /CallBack nullproc def
	end def
    end

    %% Insert the evtmgr callback proc for this interest
    %% (forkevtmgr needs this so that the evt mgr it creates knows what
    %% to do with the event once it get's it).

    %% => interest
    begin
	/ClientData 10 dict dup begin
	    /CallBack {DoSelect} def
	end def
    end
} def

%+
% DoSelect:		event => -
% Function:		forkeventmgr style CallBack proc. 
%			Handles all incoming selection events
% Notes:		Currently scrollfields use the EIS buffer model
%			for selection handling
% -- NOT FULLY COMPLETED --
%-
/DoSelect {
%% => selection event
1 dict begin
	/evt exch def
	evt /Name get [

	    /Ignore {}

	    %% not sure what the hell to do with this so just print it out
	    %% when we get one and we'll find out soon enough!!
	    /InsertValue {
		(scrfld: got a /InsertValue: \n\t/Action = %) 
		[ evt /Action get] dbgprintf
	    }

	    %% user has made a selection in this canvas
	    /SetSelectionAt {
		evt /Action get /Preview get not {
		%% make sure we are in the right canvas
		    /SFSelList 
			[ 
			    gsave SFCanvas setcanvas 
			    evt begin XLocation YLocation Point2Elem end
			    grestore 
			]
		    store
		} if

		%% now register the selection w/ the EIS
		%% ... TO BE DONE
		%%
		%% selection-dict 10 dict dup begin
		%%	/ContentsAscii XXXXX def
		%%	/Rank evt /Action get /Rank get def
		%%	/Canvas SFCanvas def
		%%	/SelectionResponder null def
		%%	/SelectionObjsize ContentsAscii length def
		%%	/SelectionStartIndex 0 def
		%%	/SelectionLastIndex SelectionObjsize 1 sub def
		%%
		%% end setselection 
		%% 

		paintdata
	    }

	    %% user has extended the current selection
	    /ExtendSelectionTo {
		evt /Action get /Preview get not {
		%% make sure we are in the right canvas
		    gsave SFCanvas setcanvas 
		    evt begin XLocation YLocation end Point2Elem
		    grestore 
		    AddToSelList
		} if

		%% now re-register the extended selection w/ the EIS
		%% ... TO BE DONE
		%%
		%% selection-dict 10 dict dup begin
		%%	/ContentsAscii XXXXX def
		%%	/Rank evt /Action get /Rank get def
		%%	/Canvas SFCanvas def
		%%	/SelectionResponder null def
		%%	/SelectionObjsize ContentsAscii length def
		%%	/SelectionStartIndex 0 def
		%%	/SelectionLastIndex SelectionObjsize 1 sub def
		%%
		%% end setselection 
		%% 

		paintdata
	    }

	    /DeSelect {
		%% At the moment we don't really care about being
		%% deselected..
	    }

	    /Default {}

	] case
end
} def

%+
% AddToSelList:		int => -
% Function:		Add a element index to the selection list. If it is
%			already present in the list it is not added.
%-
/AddToSelList {
1 dict begin
    /addition exch def

    SFSelList {
	%% null out " addition "  if it already exists in the array
	addition eq { /addition null def exit } if
    } forall

    addition null ne { 
	/SFSelList SFSelList [ addition ] append store 
    } if
end %%localscope
} def

%+
% Point2Elem:		xpos ypos => int
% Function:		Returns the element index that is currently displayed 
%			at point x,y in the scroll field canvas. the Element
%			index is from the start of the data as a whole not 
%			from the start of the display buffer.
%-
/Point2Elem {
gsave SFCanvas setcanvas
    3 dict begin
	exch pop %% the "x"
	/ypos exch def
	/elem SFData /TElem get def
	/firstone? true def
	0 SFH SFLabel null ne { SFFontSize sub } if moveto

	SFDataBuf {

	    firstone? {
		/firstone? false def
		SFData /TLine get  nthline_on not {
		    (/user/bin/msg scrfld: Point2Elem_BooBoo tell_mike) 
		    forkunix pause ()
		} if
	    } if

	    %% is the point clicked above the curr point yet ??
	    currentpoint exch pop ypos lt { 
		pop exit 
	    } if

	    countlines SFFontSize mul neg 0 exch rmoveto
	    /elem elem 1 add def
	} forall

	elem 1 sub 0 max
    end
grestore
} def


%+
% MakeSFInterests:	- => -
% Function:		Create interests for this fld and start a 
%			event manager for them.
%-
/MakeSFInterests {
    SFEvtMgr nulldict eq { 
	/SFEvtMgr [

	    %% pager control stuff 
	    PointButton
	    { pop scrollup }
	    DownTransition
	    PgControl
	    eventmgrinterest

	    AdjustButton
	    { pop scrolldown }
	    DownTransition
	    PgControl
	    eventmgrinterest

	    %% selection stuff
	    { SFCanvas MakeSelInterests }

	    %%% menu stuff
	    MenuButton 
	    { SFMenu nulldict ne { /show SFMenu send } if }
	    DownTransition
	    SFCanvas
	    eventmgrinterest

	] forkeventmgr store
    } if
} def

%+
% reshape:	x y w h => -
% Function:	Reshape the scroll field and all it's controls
%-
/reshape {
    ChkCans
    Reshape
    ReshapeControls
} def

/Reshape {
    /SFH exch def /SFW exch def 
    /SFY exch def /SFX exch def
    gsave 
	SFParent setcanvas SFX SFY translate
	%% reshape the scroll field...
	0 0 SFW SFH rectpath SFCanvas reshapecanvas
    grestore
} def

%+
%
%-
/map { 
    ChkCans 
    SFCanvas /Mapped true put 
    PgControl /Mapped true put
} def

/unmap { 
    SFCanvas nulldict ne { 
	SFCanvas /Mapped false put 
	PgControl /Mapped false put
    } if 
} def

%+
% paint:	- => -
% Function	paint the scroll field in it's entirety
%-
/paint {
    ChkCans
    gsave SFCanvas setcanvas SFTextColor setcolor SFFont setfont
    {
	SFFillColor fillcanvas SFTextColor strokecanvas
	PaintData PaintCtrls PaintLabel
    } CallPaintProc
    grestore
} def

/paintdata { /PaintData CallPaintProc } def
/unpaintdata { /UnpaintData CallPaintProc } def

/CallPaintProc {
    gsave SFCanvas setcanvas SFTextColor setcolor SFFont setfont
	cvx exec
    grestore
} def

%+
% ReshapeControls:	- => -
% Function:	 	reshapes all controls associated w/ the window
%
%-
/ReshapeControls {
gsave 
    %% make him a small square guy on the lower
    %% left of the field
    SFCanvas setcanvas
    0 0 GdgtW dup rectpath PgControl reshapecanvas
grestore
} def

%+
% ChkCans:	- => -
% Function:  	deferred init of canvases and the interests associated w/ them.
%-
/ChkCans {
    SFCanvas nulldict eq {
	/SFCanvas SFParent newcanvas store
	SFCanvas /Transparent false put
	SFCanvas /Retained false put
	SFCanvas /EventConsumed /MatchedEvents put
	SFX SFY SFW SFH Reshape

	/PgControl SFCanvas newcanvas store
	%%%PgControl /Transparent false put
	%%%PgControl /Retained false put
	PgControl /EventConsumed /MatchedEvents put
	ReshapeControls

	MakeSFInterests
    } if

} def

%+
% PaintLabel:	- => -
% Function:	paints the label for the scroll field (if one exists).
%-
/PaintLabel {
    SFLabel type /stringtype eq {
	GdgtW SFLMargin add SFH SFFontSize sub 1 sub moveto
	SFLabel show
	0 SFH SFFontSize sub 1 sub moveto SFW 0 rlineto stroke
    } if
} def

%+
% PaintData:	- => -
% Function:	paints the scrolled data visible within the window
%-
/PaintData {
    SFData nulldict ne SFDataBuf null ne and {
	SFDataBuf datashow pop
    } if
} def

/UnpaintData {
    SFData nulldict ne SFDataBuf null ne and {
	SFDataBuf SFFillColor datashow pop
    } if
} def

/scrolldelta { 
    SFH 2 idiv dup SFFontSize mod sub SFFontSize idiv 
} def

/linesshowing {
} def

/scrolldown {
    %% Don't bother if there is nothing there
    SFData nulldict ne {

	3 dict begin
	%% calc the no. of lines we need 

	DataOnClient? {

	    SFData /Data get
	    Home
	    scrolldelta dup 2 mul
	    SFCPS begin SFgetbuf end

	}{

	    scrolldelta  SFData /TElem get SFData /TLine get  seekforward
	    dup null eq {
		pop pop %% we've hit bottom, do nothing
	    } {
		%% Make a subset of the scroll data, which is
		%% the stuff we are currently displaying. this lives
		%% in SFDataBuf

		%% unpaint what is there
		{ SFDataBuf SFFillColor datashow } CallPaintProc pop

		SFData begin

		    /TLine exch def 
		    /TElem exch def

		    /SFDataBuf 
			Data TElem   Data length 1 sub   getinterval
			%%[ Data TElem get TLine nthline_on pop ] 
			%%TElem Data length 1 sub ge { 
			%%    []
			%%} {
			%%    Data TElem 1 add Data length 1 sub getinterval
			%%} ifelse
			%%append
		    store
		end

		%% paint the new stuff
		{ SFDataBuf datashow } CallPaintProc pop

		%% /paint self send
	    } ifelse
	} ifelse
	end
    } if %% SFData null ne
} def


/scrollup {
    %% if empty , don't bother
    SFData nulldict ne {

	3 dict begin
	%% calc the no. of lines we need 

	DataOnClient? {

	    %%
	    SFData /Data get
	    Home
	    scrolldelta dup neg exch 2 mul
	    SFCPS begin SFgetbuf end

	}{

	    { SFDataBuf SFFillColor datashow } CallPaintProc pop

	    %
	    scrolldelta   SFData /TElem get SFData /TLine get   seekbackward
	    dup null eq {
		%% seek went past the start of the Data...
		pop pop 
		SFData begin
		    %% set start of displayable stuff to be start of 
		    %% of all the scroll data...
		    /TElem 0 def 
		    /TLine 0 def
		end
	    } {
		%% Make a subset of the scroll data, which is
		%% the stuff we are currently displaying. this lives
		%% in SFDataBuf
		SFData begin

		    /TLine exch def 
		    /TElem exch def
		end
	    } ifelse

	    SFData begin
	    /SFDataBuf 
		Data TElem   Data length 1 sub   getinterval
		%%[ Data TElem get TLine nthline_on pop ] 
		%%TElem Data length 1 sub ge { 
		%%    []
		%%} {
		%%    Data TElem 1 add Data length 1 sub getinterval
		%%} ifelse
		%%append
	    store
	    end % SFData

	    { SFDataBuf datashow } CallPaintProc pop
	    %%% /paint self send

	} ifelse
    end  %% local scope
    } if %% SFData nulldict ne
} def

%+
% datashow:	[ (text\ntext\n....) (..) ... ]  color =>  bool
% Function:	with the current point's y-coord as the left margin, display 
%		the argument string, wrapping at newlines. showing is stopped
%		when the curren point's x-coord is less than zero. false
%		is returned if the currentpoint's x-coord is less than zero
%		after the showing has taken place. the color parame is optional.
%		it is include for things like unpainting.
%-
/datashow {
6 dict begin
gsave
    dup type /arraytype eq { /usecolor null def } { /usecolor exch def } ifelse
    /rval true def
    /elem SFData /TElem get def
    /firstone? true def

    %% so we do not mess up our border strokes
    1.5 clippath pathbbox points2rect insetrect rectpath clip

    %% move down a little further if we have a label 
    GdgtW SFH SFFontSize SFLabel null eq {1} {2} ifelse mul sub moveto

    usecolor null ne { usecolor setcolor } if 

    /xpos currentpoint pop def


    %% consume [(...) (...) ... ]
    {
	firstone? {
	    %% get just the showable part of the first element
	    /firstone? false def

	    SFData /TLine get 
	    nthline_on not {

		/datashow_error  dbgbreak

		%%(/user/bin/msg scrfld: datashow_BooBoo inform_mike) forkunix 
		pause ()
	    } if

	    %% don't show the stuff before the hide mark
	    SFData /TLine get 0 eq { 
		HideMark search { pop pop } if 
	    } if
	} {

	    %% don't show the stuff before the hide mark
	    HideMark search { pop pop } if

	} ifelse

	rval not { pop exit } if
	usecolor null eq {
	    elem InSelList {
		SFSelColor setcolor
	    } {
		%% set color depending on if the element index is odd or even
		elem elem 1 or eq { SFOColor } { SFEColor } ifelse setcolor
	    } ifelse
	} if

	{ %%start loop
	    currentpoint SFFontSize add exch pop 0 lt {
		pop /rval false def exit 
	    } if
	    (\n) search {
		%% show the line and do a "cr/nl"
		currentpoint SFFontSize sub  
		    3 -1 roll 
		    show
		moveto 
		pop %% the newline, leave what's left on stack
	    } {
		%% last line in blk , show and bail
		show 
		exit
	    } ifelse
	    %%% pause
	} loop

	/elem elem 1 add def
	xpos currentpoint exch pop SFFontSize sub moveto
    } forall

    rval

grestore
end %% localscope
} def

%+
% InSelList:		N => bool
% Function:		Is element "N" of the scroll data in the select list ? 
%-
/InSelList {
1 dict begin
    /n exch def
    SFSelList { n eq { /n true def exit } if } forall
    n true eq %% leave verdict on stack
end %% localscope
} def

%+
% PaintCtrls:	- => -
% Function:	paints any controls associated with the scroll field. 
%-
/PaintCtrls {
    gsave PgControl setcanvas 
	0 0 moveto /cycle showicon
    grestore
} def


%+
% seekbackward:	linesforward startelem startline => seekedelem seekedline
% Function: 
%-
/seekbackward {
11 dict begin

    /startline exch def %% grab args off stack...
    /startelem exch def
    /linesback exch def

    /seekedelem null def %% local var. init stuff...
    /seekedline null def
    /totallines 0 def
    /Data SFData /Data get def

    %% seek backward  elem by elem ...
    startelem -1 0 {
	/i exch def

	i dup startelem eq {
	    Data exch get startline till_nthline not { () } if
	} {
	    Data exch get
	} ifelse
	/curelem exch def

	/linecount curelem countlines def

	/totallines totallines linecount add def

	%% Have we hit the elem w/ the linesback-th line yet?
	totallines linesback ge {
	    %% Yes, note the elem it was in and the line no.
	    /seekedelem i def
	    /seekedline 
		totallines linesback sub %%  overshoot amount == line #
	    def
	    exit
	} if

    } for

    seekedelem  %% leave return vals on stack
    seekedline

end %localscope
} def

%+
%
%
% Note: 	If N > than the max # of lines int the arg string false 
%		is returned,  otherwise true is returned along with a string 
%		identical to the argument string.
%-
/till_nthline {
3 dict begin
    /n exch def
    /sofar 0 def
    /rval null def

    %% => (stuff...\n...\n....)
    {
	sofar n ge { pop exit } if

	rval null eq { /rval () def } if

	(\n) search { 
	    rval exch 
	    append /rval exch def

	    /sofar sofar 1 add def

	    pop %% the (\n)
	    sofar n ge { pop exit } { /rval rval (\n) append def } ifelse
	} { 
	    rval exch 
	    append /rval exch def

	    exit 
	} ifelse

    } loop
    rval null ne { rval true } { false } ifelse

end %localscope
} def

%+
% seekforward:	linesforward startelem startline => seekedelem seekedline
% Function:
%-
/seekforward {
11 dict begin
    
    /startline exch def %% grab args off stack...
    /startelem exch def
    /linesforward exch def

    /seekedelem null def %% local var. init stuff...
    /seekedline null def
    /totallines 0 def
    /Data SFData /Data get def

    %% seek forward elem by elem...
    startelem 1 Data length 1 sub {

	/i exch def

	i dup startelem eq {
	    Data exch get startline nthline_on not { () } if
	} {
	    Data exch get
	} ifelse
	/curelem exch def

	/linecount curelem countlines def

	/totallines totallines linecount add def

	%% Have we hit the elem w/ the linesforward-th line yet?
	totallines linesforward ge {
	    %% Yes, note the elem it was in and the line no.
	    /seekedelem i def
	    /seekedline 
		Data seekedelem get countlines %% total lines in this elem
		totallines linesforward sub  sub %%  less overshoot amount
		1 sub
	    def
	    exit
	} if

    } for

    seekedelem  %% leave return vals on stack

    seekedline

end %localscope
} def

%+
% nthline_on:	(string1\n...stringN\n...) N => false 
%               (string1\n...stringN\n...) N => true (stringN\n...)
%
% Function: 	Return Nth line on from  argument string.
% 		If nthline is greater than total number of lines , 
%		() is returned.
%
% Note: 	First line in string is referenced as "0" not "1"
%-
/nthline_on {
3 dict begin
    /n exch def
    /sofar 0 def
    /rval null def

    {
	sofar n eq { /rval exch def exit } if

	(\n) search { pop pop } { pop exit } ifelse
	/sofar sofar 1 add def
    } loop
    rval null ne { rval true } { false } ifelse end
} def

/countlines {
1 dict begin
    /i 0 def
    {
	/i i 1 add def
	(\n) search { pop pop }{ pop exit } ifelse
    } loop
    i %% leave ret val on stack
end %localscope
} def


classend def

%% ================= End Of ScrFld Class ===========================

%% ========== test fragment for the scroll field class =============

/paintit {
    1 1 1 hsbcolor fillcanvas
    /paint ScrollFld send
} def

/scrwin framebuffer /new DefaultWindow send def
/reshapefromuser scrwin send

{

    /PaintClient { paintit } def

    /ScrollFld  
	4 4 300 100 ClientCanvas /new ScrFld send 
    def

    /FrameLabel (Scroll Field Demo) def
    /IconLabel FrameLabel def

} scrwin send 

/sfld  scrwin /ScrollFld get def
{ /SFLabel (Scroll Field Demo) def } sfld send

[
(here is some scrollfield data)
(notice that you can have multi-line\nelements as data!)
(here's a real long one\nA\nB\nC\nD\nE\nF\nG\nH\nI\nJ\nK\nL\nM\nN\nO)
(Now some quotes that are in the PostScript Blue Book)
(To Read means to obtain meaning from words, and\n\
legibility is THAT QUALITY WHICH enables words\n\
to be read easily, quickly, and accurately.\n\
\n\
JOHN C. TARR)
(If my film makes one more person feel miserable\n\
I'll feel I've done my job.\n\
\n\
WOODY ALLEN)
(Printing is the source of practically all human evolution\n\
Without it the tremendous progress in the fields of science and\n\
technology would not have been possible\n\
\n\
VALTER FALK)
(now some single line elements)
(1)
(2)
(3)
(4)
(5)
(6)
(7)
(8)
(9)
(0)
(a)
(b)
(c)
(d)
] 
/set sfld send

/map sfld send
/map scrwin send