don@TUMTUM.CS.UMD.EDU (Don Hopkins) (11/24/89)
And here's a repost of splitab, which didn't seem to make it through.
-Don
======== START OF cyber.shar.splitab ========
X % else's frame menu, and if you mess with the frame menu you're
X % asking for trouble anyway.)
X { /clone&forward { % /msg => -
X /flipstyle self send
X ThisWindow dup null eq {
X pop /win where {pop win} { % Foo on spin...
X /window where {pop window} { % Foo on othello...
X /dont-mess-with-the-frame-menu dbgbreak
X } ifelse
X } ifelse
X } if
X /FrameMenu
X 2 index put
X send
X } def
X /insertitem { /insertitem clone&forward } def
X /deleteitem { /deleteitem clone&forward } def
X /changeitem { /changeitem clone&forward } def
X } ClassFrameMenu send
X
Xclassend def
X
Xsystemdict /DontSetDefaultWindow known not {
X /DefaultWindow QuickWindow def
X
X % Hack to make ScrollWindow a subclass of QuickWindow. (gross)
X /ScrollWindow load type /arraytype eq {
X 10 dict begin
X /LiteWindow DefaultWindow def
X ScrollWindow pop
X end
X } if
X} if
X
Xend % systemdict
//go.sysin dd *
if [ `wc -c < quickwin.ps` != 7663 ]; then
made=false
echo error transmitting quickwin.ps --
echo length should be 7663, not `wc -c < quickwin.ps`
else
made=true
fi
if $made; then
chmod 644 quickwin.ps
echo -n ' '; ls -ld quickwin.ps
fi
echo Extracting textcan.ps
sed 's/^X//' <<'//go.sysin dd *' >textcan.ps
X%
X% This file is a product of Sun Microsystems, Inc. and is provided for
X% unrestricted use provided that this legend is included on all tape
X% media and as a part of the software program in whole or part. Users
X% may copy or modify this file without charge, but are not authorized to
X% license or distribute it to anyone else except as part of a product
X% or program developed by the user.
X%
X% THIS FILE IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
X% WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
X% PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
X%
X% This file is provided with no support and without any obligation on the
X% part of Sun Microsystems, Inc. to assist in its use, correction,
X% modification or enhancement.
X%
X% SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
X% INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY THIS FILE
X% OR ANY PART THEREOF.
X%
X% In no event will Sun Microsystems, Inc. be liable for any lost revenue
X% or profits or other special, indirect and consequential damages, even
X% if Sun has been advised of the possibility of such damages.
X%
X% Sun Microsystems, Inc.
X% 2550 Garcia Avenue
X% Mountain View, California 94043
X%
X%
X% textcan.ps 1.10 89/03/07
X%
X%------------------------------ TextCanvas --------------------------------
X%
X% Copyright (c) 1987 by Sun Microsystems, Inc.
X% Steve Isaac 12/18/87
X%
X% TextCanvas User's Guide
X% -----------------------
X% Description:
X% TextCanvas is a NeWS class that provides a generic text storage and
X% display facility NeWS server. It has the following features:
X% . Scrolling
X% . Text caret
X% . Selections (integrated with system selections)
X% . Text may be larger than the display canvas
X% . Display canvas can be positioned anywhere over the stored text
X% . Font and point size may be changed dynamically
X% . Colors may be changed dynamically
X% . No limitations on width of text
X% . Fixed number of lines of text, specified at creation time
X% . Currently limited to fixed-width fonts
X%
X% The TextCanvas allows text-based applications (terminal emulators,
X% text editors, text widgets) to be easily written. It is a start at
X% a common platform for NeWS text-oriented applications.
X%
X% The following things need to be done to TextCanvas in order to fully
X% achieve this goal:
X%
X% . Support for variable width fonts and simultaneous multiple fonts
X% (maybe a subclass if this causes too big a performance hit)
X% . Text attributes (ie. reversed, blinking, bold, etc).
X% . Separation of Text array and TextCanvas (to allow multiple
X% views onto the same text)
X% . Completion of selection service (multiple clicks, etc)
X% . Dynamic changing of the number of lines of text
X% . The caret should be a seperate class
X% . The terminal emulation specifics (coordinate system, scrolling)
X% should be a seperate subclass
X% . Continuing performance improvements
X%
X% Overview:
X% The TextCanvas can be viewed as a NeWS canvas that understands a set
X% of messages relating to text manipulation (eg. inserting a string,
X% deleting some lines, moving the caret). Basic canvas operations
X% (eg. shaping, resizing, moving) are done via standard NeWS primitives.
X% All canvas operations can be freely performed, however, the TextCanvas
X% must be informed if the canvas is resized, damaged, or destroyed.
X%
X% A TextCanvas has an underlying fixed-size text array that contains
X% arbitrarily long strings. The canvas is essentially a viewport into this
X% array; this viewport may be moved around to display different parts of
X% the text aray. It cannot be moved outside the boundries of the
X% text array, however.
X%
X% An instance of TextCanvas is created by specifying an existing canvas
X% and the number of lines that the Text array will store. This canvas
X% could be the client canvas of a window, which is how the TextCanvas
X% typically interfaces to the LiteWindow package.
X%
X% Coordinates:
X% The TextCanvas presents an integer coordinate system that addresses each
X% possible chararcter position in the Text array. It is laid out as follows:
X%
X% 1,-N ------------------ W,-N <------+
X% | | |
X% | | |
X% | | |
X% | | |
X% | | |
X% 1,-1 W,-1 +-- NumLines
X% 1,0 W,0 |
X% 1,1 ------------------- W,1 |
X% 1,2 W,2 |
X% | | |
X% | | |
X% | | |
X% 1,H ------------------- W,H <------+
X%
X% where: W is the largest width of any string in the text array,
X% H is the number of lines that fit in the viewport canvas,
X% NumLines is the number of lines in the text array,
X% N is: NumLines - H - 1.
X%
X% This means that the lines of the Text array under the original viewport
X% postion are addressed starting at 1, with increasing line numbers going
X% down the viewport.
X%
X% Note that W is always changing as new lines of text are written
X% into the Text canvas. The coordinate system will change if the
X% viewport canvas is resized.
X%
X% Scrolling:
X% Text which is written at line number H+1 or greater will cause
X% the entire Text array to scroll up so that the last line written
X% is at line H. Lines 0 through -N are therefore a transcript of
X% what was displayed in the viewport. Upwards scrolling can also be caused
X% by cursor movement (movecursordelta).
X%
X% Downwards scrolling is limited to the original viewport area only. It is
X% caused by cursor movement (movecursordelta).
X%
X% Scrolling can be limited to a portion of the text array (via
X% setscrollinglimits).
X%
X% Moving the viewport:
X% The viewport can be moved to display non-visible portions of the text
X% arrray. Note that the coordinate system does not change if the viewport
X% is moved. It remains relative to the original viewport position. Movement
X% is requested via the moveviewport message.
X%
X% Caret:
X% The TextCanvas contains a built-in text caret that can be turned
X% on or off, be any color, be any shape that can be expressed as a
X% PostScript path, made to blink at a user-defined speed and duty
X% cycle, and moved to any coordinate location. The caret is positioned
X% just to the left and below the location it is on.
X%
X% Writing text:
X% Text is put into the text array via the writelines, and writeatcaret
X% messages. They allow large blocks of text to be written in a single
X% message. There is a big performance win for writing as large
X% a block as possible. Text must consist of printable chararacters (ASCII
X% codes 0x20-0x7E) only. Non-printable characters will cause erroneous
X% selections. There is no special interpretation for control characters.
X%
X% Selections:
X% The TextCanvas provides a MacIntosh-like selection mechanism.
X% Left mouse button down sets the selection start point. Dragging the
X% mouse with the left button down drags out a selection. Left mouse
X% button up completes the selection. The middle mouse button allows
X% the current selection to be extended, either by clicking or by dragging.
X%
X% The selected text is made the PrimarySelection in the system selection
X% dictionary. Any previous primary selection is cleared. The selected text
X% can be accessed via the standard system selection call (getselection).
X% If LiteUI is running then the "Put" function key will put the selection
X% on the shelf.
X%
X% Input Handling and Callback Routines:
X% The TextCanvas expresses interest in keyboard events. An optional
X% user-supplied callback routine (KeyHitCallback) is called whenever a
X% keystroke is detected. Similarly, another callback routine
X% (InsertValueCallback) is called when a selection /InsertValue
X% event is detected.
X%
X% A callback routine for when the number of rows and columns in the
X% viewport changes (ResizeCallback) is provided. Callbacks for mouse button
X% events (LeftMouseDownCallback, LeftMouseUpCallback,
X% MiddleMouseDownCallback, MiddleMouseUpCallback) are also provided. Other
X% callbacks may be added by subclassing the text canvas.
X%
X% These callback routines make it very easy to write short routines
X% do things like echo what the user has typed or move the caret to where
X% the mouse was clicked.
X%
X% The callback routine will be executed within the context of the the
X% TextCanvas instance. You may access all TextCanvas instance or class
X% variables, or invoke methods by simply calling them as procedures.
X%
X% TextCanvas Interface Definition
X% -------------------------------
X% The messages and callback routines that class TextCanvas provides are:
X%
X% /changefont { % fname fheight - => -
X% --- Change the font and point size for all text. Either fname or fheight
X% may be null, in which case they are ignored.
X%
X% /writelines { % arrayofstrings col row => -
X% --- Write an array of strings, starting the first string at col,row
X% with subsequent strings going at 1,row+1 1,row+2 etc.
X%
X% /writeatcaret { % arrayofstrings => -
X% --- Similar to writelines, except start at the current caret location. The
X% caret is moved to the next available character position when the
X% write is done.
X%
X% /deletestring { % length col row => -
X% --- Delete a string starting at col,row for length characters.
X% length must be 0 or a positive integer.
X%
X% /insertline { % numlines row => -
X% --- Insert numlines blank lines, starting at line row.
X% numlines must be 0 or a positive integer
X%
X% /deleteline { % numlines row => -
X% --- Delete numlines lines, starting at line row.
X% numlines must be 0 or a positive integer
X%
X% /setscrollinglimits { % toprow bottomrow => -
X% --- Sets the scrolling limits for the TextCanvas. All up or down scrolling
X% will be limited to this region instead of affecting the entire Text
X% canvas. When scrolling limits are set, those methods which can
X% trigger scrolling (writelines, writeatcaret, movecaretdelta) will
X% only cause scrolling if they affect lines within the scrolling region.
X% Any scrolling that is initiated will only move lines within the
X% scrolling limits.
X%
X% /removescrollinglimits { % - => -
X% --- Removes any scrolling bounds set by setscrollinglimits.
X%
X% /clearviewport { % - => -
X% --- Clear the text and screen area of the viewport
X%
X% /flashviewport { % - => -
X% --- Flash the contents of the viewport (visible bell)
X%
X% /moveviewport { % x y => -
X% --- Move the viewport to another part of the underlying Text array.
X% x and y must be between 0 and 1. This represents a percentage of the
X% current total width or height of the Text array. Either argument
X% can be null, in which case it is ignored.
X%
X% /getviewportsize { % - => col rows xpixels ypixels
X% --- Return the number of columns, rows, pixel height and width of
X% the viewport.
X%
X% /getlinelength { % row => length
X% --- Return the current length of the line at row.
X%
X% /calcarea { % pixwidth pixheight => numcols numrows
X% --- Returns the number of rows and columns that will fit into the pixel
X% area specified by pixwidth and pixheight, given the current Font and
X% point size.
X%
X% /calcpixarea { % numcols numrows => pixwidth pixheight
X% --- Returns the minimum pixel area required to display numrows and numcols,
X% given the current Font and point size.
X%
X% /oncaret { % - => -
X% --- Turn the caret on.
X%
X% /offcaret { % - => -
X% --- Turn the caret off.
X%
X% /movecaret { % col row => -
X% --- Move the caret to an absolute position. col and row are integers. Scrolling is
X% never triggered.
X%
X% /movecaretdelta { % deltax deltay => -
X% --- Move the caret relative to its current position. deltax and deltay must be
X% integers (negatives allowed). Scrolling is triggered if deltay moves the caret
X% outside of the scrolling limits. If no scrolling limits are set, scrolling is
X% triggered if deltay moves the caret outside of the original viewport region.
X%
X% /setcaretblink { % blink-rate duty-cycle => -
X% --- Set the caret blink rate and the blink duty cycle. blink-rate is
X% in seconds and represents a complete on/off cycle. duty-cycle is
X% between 0 and 1, and represents the percentage of on time.
X%
X% /setcaretcolor { % color => -
X% --- Set the current caret color. color is a color object.
X%
X% /setcaretshape { % shapename => successful?
X% --- Set the caret shape. shapename is an entry in the CaretShapeDict.
X% Return a boolean that tells whether shapename was found.
X%
X% /getcaretpos { % - => col row
X% --- Return the current caret position
X%
X% /setbgcolor { % color => -
X% --- Set the current canvas background color
X%
X% /setfgcolor { % color => -
X% --- Set the current text color
X%
X% /fixdamage { % - => -
X% --- Damage handler; goes in the PaintClient window callback routine
X%
X% /new { % numrows can => object
X% --- Create a new instance of the TextCanvas. numrows is the number
X% of lines to be allocated in the Text array; it is fixed for
X% the life of the instance. can is the viewport canvas.
X%
X% /reshape { % - => -
X% --- This method must be called whenever the viewport canvas has changed
X% size. It updates the number of rows and columns in the TextCanvas,
X% repositions the caret to be as close to its old position as possible,
X% resets the scrolling region, and moves the viewport to its original
X% position.
X%
X% /destroy { % - => -
X% --- Destroy the TextCanvas. This must be called if the viewport canvas
X% is ever destroyed.
X%
X% --- Client callback routines.
X% /ResizeCallback nullproc def % { - => -
X% --- ResizeCallback is called whenever the number of rows and columns
X% changes.
X% /KeyHitCallback nullproc def % { keyvalue - => -
X% --- KeyHitCallback is called whenever a keyboard input event happens
X% /InsertValueCallback nullproc def % { insertstring => -
X% --- InsertValueCallback is called whenever an InsertValue event happens
X% /LeftMouseDownCallback nullproc def % { col row => -
X% --- LeftMouseDownCallback is called when the left mouse button goes down.
X% /LeftMouseUpCallback nullproc def % { col row => -
X% --- LeftMouseUpCallback is called when the left mouse button goes up.
X% /MiddleMouseDownCallback nullproc def % { col row => -
X% --- MiddleMouseDownCallback is called when the middle button goes down.
X% /MiddleMouseUpCallback nullproc def % { col row => -
X% --- MiddleMouseUpCallback is called when the middle button goes up.
X%
X% Implementation Details
X% ----------------------
X% Coordinates:
X% The text canvas has an internal coordinate system as follows:
X%
X% 1,1 --------- TextWidth,1
X% | |
X% | |
X% 1,TextHeight TextWidth,TextHeight
X%
X% The Can canvas is essentially a viewport on this coordinate system. The
X% TM tranformation matrix reflects this coordinate system, and is used for
X% computing caret or text movement on Can. The base window lives in the
X% lower left hand corner of the text canvas, the original location of the
X% viewport. It is the same size as the Can canvas. External caret
X% coordinates are relative to the base window; the internal caret
X% coordinates (CaretX, CaretY) are relative to the internal coordinate
X% system. The text array is laid out in a similar fashion to the internal
X% coordinate system; however, indices are 0 based. The Xindex and Yindex
X% functions map coordinate values to array indices. Text scrolling is
X% handled by manipulating this mapping.
X%
X
X%systemdict /TextCanvas known not {
Xsystemdict begin
X/TextCanvas Object
Xdictbegin
X /DEBUG false def % Turn on debugging output
X /Text null def % Main text array
X /TextWidth 0 def % Number of text columns (changes
X % dynamically)
X /TextHeight 0 def % Number of text rows (specified
X % at initialization)
X /Can null def % The main canvas
X /SelectionCan null def % Visible selection feedback canvas
X /SelDragCan null def % Transparent selection drag canvas
X /Caret null def % The caret canvas
X
X /CanPixWidth 0 def % Canvas width (pixels)
X /CanPixHeight 0 def % Canvas height (pixels)
X /CanPixX 0 def % Canvas X origin (pixels)
X /CanPixY 0 def % Canvas Y origin (pixels)
X /CanX 0 def % Canvas X origin (Text coordinates)
X /CanY 0 def % Canvas Y origin (Text coordinates)
X /CanWidth 0 def % Number of columns in canvas
X /CanHeight 0 def % Number of rows in canvas
X
X % --- Caret variables.
X /CaretOn? false def % Is the caret on?
X /CaretInactive? false def % Is the caret inactive (shaded,
X % no blink)?
X /CaretSupressed? false def % Is the caret supressed
X % (temporarily off)?
X /NextMoveTime 0 def % Time at which to do the next
X % caret move
X /DelayedMoveProc null def % Delayed caret move timer process
X /CaretX 1 def % Caret column in canvas
X /CaretY 1 def % Caret row in canvas
X /CaretShape /TrianglePlus def % Current caret shape (from
X % CaretShapeDict)
X /CaretColor null def % Current caret color
X /CaretBlinkEnabled? true def % Are we blinking?
X /CaretBlinkTime 1.0 def % Seconds
X /CaretDutyCycle 0.8 def % Percentage on
X /CaretDelayTime .06 def % Caret move delay time (seconds)
X
X /EventMgr null def % The main event manager
X /Interests null def % Main event manager interests
X /MouseDragEventMgr null def % Event manager for mouse dragging
X /DragInterests null def % Drag event manager interests
X /KeyboardEventMgr null def % Keyboard/Insert_Value event mgr
X
X % --- Selection variables.
X /MouseDownX 0 def % Where MouseDown actually happened
X /MouseDownY 0 def
X /SelectionX 1 def % Current initial selection point
X /SelectionY 1 def
X /SelectionX1 1 def % Current ending selection point
X /SelectionY1 1 def
X /SelExtendTop? false def % Extend the top of the selection
X /SelectionOn? false def % Is the selection visible?
X /SelectionPath null def % Current path of the visible
X % selection
X
X /SelectionDict 10 dict dup begin % Dictionary for i/f to system
X % selections
X /ContentsAscii null def
X /SelectionObjSize 1 def
X /SelectionResponder null def
X end def
X
X /ViewportXdelta 0 def % Viewport offset adjustment
X /ViewportYdelta 0 def % Viewport offset adjustment
X /WriteInProgress? false def % Is there text output happening?
X /BotScrollLimit 0 def % Scrolling limit for bottom of screen
X /TopScrollLimit 0 def % Scrolling limit for top of screen
X /ScrollRegionLength 0 def % Number of lines in scrolling region
X /ScrollLimitOn? false def % Are scrolling limits in effect?
X /BaseY 0 def % Base window Y position in Text
X /PixColWidth 0 def % Row width (pixels)
X /PixRowHeight 0 def % Column height (pixels)
X /TM null def % Position tranform matrix
X /Font null def % Current font
X /FontDescentTM null def % TM plus font descent
X /MapOffset 0 def % Y array index offset
X /InputBuffer null def % Input line buffer.
X /InputBufferLine 0 def % Line that input buffer is on
X /InputBufferLength 0 def % Number of characters in the buffer
X /BgColor 1 1 1 rgbcolor def % Current background color
X /FgColor 0 0 0 rgbcolor def % Current foreground color
X /KeyboardInterest null def % Need to keep this so we can revoke
X % it at destroy time to free memory
X /MoreInterests null def % But wait, there's more!
X % --- Client callback routines.
X % --- ResizeCallback is called whenever the number of rows and columns
X % changes.
X /ResizeCallback nullproc def % { - => -
X % --- KeyHitCallback is called whenever a keyboard input event happens
X /KeyHitCallback nullproc def % { keyvalue - => -
X % --- InsertValueCallback is called whenever an InsertValue event happens
X /InsertValueCallback nullproc def % { insertstring => -
X % --- LeftMouseDownCallback is called when the left mouse button goes down.
X /LeftMouseDownCallback nullproc def % { col row => -
X % --- LeftMouseUpCallback is called when the left mouse button goes up.
X /LeftMouseUpCallback nullproc def % { col row => -
X % --- MiddleMouseDownCallback is called when the middle button goes down.
X /MiddleMouseDownCallback nullproc def % { col row => -
X % --- MiddleMouseUpCallback is called when the middle button goes up.
X /MiddleMouseUpCallback nullproc def % { col row => -
Xdictend
Xclassbegin
X /LF 10 def
X /CR 13 def
X /BLANK 32 def
X
X /FontName /Screen def
X /FontHeight 14 def
X
X /DefaultColorCaret 1 0 0 rgbcolor def
X /DefaultMonoCaret 0 0 0 rgbcolor def
X /DefaultInactiveColor ColorDisplay?
X {.75 .75 .75 rgbcolor}
X {.5 .5 .5 rgbcolor}
X ifelse def
X
X%-------------------------------- Utilities ------------------------------------
X
X /?def {
X currentdict 2 index known {
X pop pop
X }{
X def
X } ifelse
X } def
X
X /LoadCaretShapeDict {
X systemdict /CaretShapeDict known not {
X systemdict begin /CaretShapeDict dictbegin dictend def end
X } if
X CaretShapeDict begin % --- Caret Shape dictionary
X /HLine { % xscale yscale => {path}
X matrix currentmatrix 3 1 roll
X dup scale
X pop
X 0 0 moveto
X 0 .8 transform round exch round exch itransform rlineto
X -0.3 0 transform round exch round exch itransform rlineto
X 0 -1 transform round exch round exch itransform rlineto
X setmatrix
X } ?def
X
X /Diamond { % xscale yscale => {path}
X matrix currentmatrix 3 1 roll
X dup scale
X pop
X 0 0 moveto 0.25 0 rmoveto 0.25 0.25 rlineto
X -0.25 0.25 rlineto -0.25 -0.25 rlineto closepath
X setmatrix
X } ?def
X
X /TrianglePlus { % xscale yscale => {path}
X matrix currentmatrix 3 1 roll
X dup scale
X pop
X 0 0 moveto
X 0 .8 transform round exch round exch itransform rlineto
X -0.1 0 transform round exch round exch itransform rlineto
X 0 -.8 transform round exch round exch itransform rlineto
X -0.35 -0.4 transform round exch round exch itransform rlineto
X .35 0 transform round exch round exch itransform rlineto
X .1 0 transform round exch round exch itransform rlineto
X .35 0 transform round exch round exch itransform rlineto
X closepath
X setmatrix
X } ?def
X
X /Triangle { % xscale yscale => {path}
X matrix currentmatrix 3 1 roll
X dup scale
X pop
X 0 0 moveto
X -0.3 -0.6 transform round exch round exch itransform rlineto
X .6 0 transform round exch round exch itransform rlineto
X -0.3 0.6 transform round exch round exch itransform rlineto
X setmatrix
X } ?def
X
X /Box { % xscale yscale => {path}
X matrix currentmatrix 3 1 roll
X scale
X 0 0 moveto
X 0 1 rlineto
X 1 0 rlineto
X 0 -1 rlineto
X -1 0 rlineto
X -.1 -.1 rmoveto
X 0 1.2 rlineto
X 1.2 0 rlineto
X 0 -1.2 rlineto
X closepath
X setmatrix
X } ?def
X end
X } def
X
X /Xindex { % col => x-index
X % --- Convert a column coordinate into a Text array index
X 1 sub
X } def
X
X /Yindex { % row => y-index
X % --- Convert a row coordinate into a Text array index
X % Text array
X 1 sub MapOffset add TextHeight mod
X } def
X
X /CreateInterests { % - => -
X % --- Main event handler interests
X /Interests dictbegin
X
X /CaretDamageEvent
X /Damaged
X {pop gsave
X Caret setcanvas
X CaretInactive? {
X DefaultInactiveColor fillcanvas
X }{
X CaretColor fillcanvas
X } ifelse
X grestore }
X null Caret eventmgrinterest
X def
X
X /CaretTimerEvent
X % --- Caret blink events. Send this event out again with the time
X % of the next blink
X /CaretTimer
X {/e exch def
X e begin
X Caret /Mapped get {
X CaretBlinkEnabled? CaretOn? CaretInactive? not CaretSupressed? not
X and and and {
X UnMapCaret
X /TimeStamp
X % --- When to turn caret back on
X CaretBlinkTime 60 div 1 CaretDutyCycle
X sub mul currenttime add
X def
X }{
X % --- If the caret is disabled, keep the timer event
X % circulating at a 2 second rate
X /TimeStamp currenttime 1 30 div add def
X } ifelse
X }{
X CaretBlinkEnabled? CaretOn? CaretInactive? not CaretSupressed? not
X and and and {
X MapCaret
X /TimeStamp
X % --- When to turn caret back off
X CaretBlinkTime 60 div CaretDutyCycle mul
X currenttime add
X def
X }{
X % --- If the caret is disabled, keep the timer event
X % circulating at a 2 second rate
X /TimeStamp currenttime 1 30 div add def
X } ifelse
X } ifelse
X e sendevent
X end}
X null Caret eventmgrinterest
X def
X
X /LeftMouseDownEvent
X /LeftMouseButton
X {begin
X InactivateCaret
X % --- Clear anyone else's primary selection
X SendClearSelection
X % --- Synchronously clear my primary selection
X ClearMySelection
X Can setcanvas
X TM setmatrix
X /MouseDownX XLocation 1 max round store
X /SelectionX MouseDownX store
X /SelectionX1 SelectionX store
X /MouseDownY YLocation TextHeight min CanY max round store
X /SelectionY MouseDownY store
X /SelectionY1 SelectionY store
X /len Text SelectionY Yindex get length store
X SelectionX len 2 add gt {
X /SelectionX len 2 add store
X } if
X /SelExtendTop? false def
X /MouseDragEventMgr
X DragInterests forkeventmgr
X store
X MouseDownX MouseDownY BaseY sub LeftMouseDownCallback
X end }
X /DownTransition Can eventmgrinterest
X def
X
X /MiddleMouseDownEvent
X /MiddleMouseButton
X {begin
X InactivateCaret
X % --- Clear anyone else's primary selection
X SendClearSelection
X % --- Remove any visual feedback for my selection, but leave
X % the selection path intact so we can extend it.
X false DrawSelection
X SelDragCan setcanvas
X TM setmatrix
X YLocation SelectionY sub abs dup mul
X XLocation SelectionX sub abs dup mul add
X YLocation SelectionY1 sub abs dup mul
X XLocation SelectionX1 sub abs dup mul add lt {
X /SelectionX XLocation 1 max round store
X /SelectionY YLocation TextHeight min CanY max round store
X /SelExtendTop? true store
X }{
X /SelectionX1 XLocation 1 max round store
X /SelectionY1 YLocation TextHeight min CanY max round store
X /SelExtendTop? false store
X } ifelse
X ExtendSelection
X /MouseDragEventMgr
X DragInterests forkeventmgr
X store
X XLocation 1 max round YLocation TextHeight min CanY max round BaseY sub
X MiddleMouseDownCallback
X end}
X /DownTransition Can eventmgrinterest
X def
X
X dictend store % Interests
X } def
X
X /CreateDragInterests { % - => -
X % --- Interests for mouse drag event manager
X /DragInterests dictbegin
X /MouseDragEvent
X /MouseDragged
X { begin
X SelDragCan setcanvas
X TM setmatrix
X SelExtendTop? {
X /SelectionX XLocation 1 max round store
X /SelectionY YLocation TextHeight min CanY max round store
X }{
X /SelectionX1 XLocation 1 max round store
X /SelectionY1 YLocation TextHeight min CanY max round store
X } ifelse
X erasepage
X ExtendSelection
X end}
X null Can eventmgrinterest
X def
X
X /LeftMouseUpEvent
X /LeftMouseButton
X {begin
X SelDragCan setcanvas
X erasepage
X Can setcanvas
X TM setmatrix
X % --- If we are at the same location as LeftButton down, then
X % remove any selection on our canvas. Otherwise, make the selected
X % area the primary selection.
X MouseDownX XLocation 1 max round eq
X MouseDownY YLocation TextHeight min CanY max round eq and {
X false DrawSelection
X /SelectionPath null store
X }{
X % --- SelectionX,Y must always be lower than SelectionX1,Y1
X SelectionY1 SelectionY lt SelectionY1 SelectionY eq
X SelectionX1 SelectionX lt and or {
X SelectionX SelectionY
X /SelectionX SelectionX1 store
X /SelectionY SelectionY1 store
X /SelectionY1 exch store
X /SelectionX1 exch store
X } if
X SelectionDict /ContentsAscii GetSelection put
X SelectionDict /Canvas Can put
X SelectionDict /SelectionHolder KeyboardEventMgr put
X SelectionDict /PrimarySelection setselection
X true DrawSelection
X } ifelse
X ReactivateCaret
X XLocation 1 max round YLocation TextHeight min CanY max round BaseY sub
XLeftMouseUpCallback
X MouseDragEventMgr killprocess
X end}
X /UpTransition null eventmgrinterest
X def
X
X /MiddleMouseUpEvent
X /MiddleMouseButton
X {begin
X SelDragCan setcanvas
X TM setmatrix
X erasepage
X % --- SelectionX,Y must always be lower than SelectionX1,Y1
X SelectionY1 SelectionY lt SelectionY1 SelectionY eq
X SelectionX1 SelectionX lt and or {
X SelectionX SelectionY
X /SelectionX SelectionX1 store
X /SelectionY SelectionY1 store
X /SelectionY1 exch store
X /SelectionX1 exch store
X } if
X SelectionDict /ContentsAscii GetSelection put
X SelectionDict /Canvas Can put
X SelectionDict /SelectionHolder KeyboardEventMgr put
X SelectionDict /PrimarySelection setselection
X true DrawSelection
X ReactivateCaret
X XLocation round YLocation TextHeight min CanY max round BaseY sub MiddleMouseUpCallback
X MouseDragEventMgr killprocess
X end}
X /UpTransition null eventmgrinterest
X def
X dictend store
X } def
X
X /KeyboardHandler { % - => -
X % --- Handler for keyboard, InsertValue, and Deselect events
X /KeyboardInterest Can addkbdinterests def
X /MoreInterests [
X Can addselectioninterests aload pop
X revokeinterest % Get rid of mouse interests
X Can addfunctionstringsinterest
X ] def
X { awaitevent begin
X Name type /integertype eq {
X Name /KeyHitCallback self send
X } if
X Name /DeSelect eq {
X false DrawSelection
X /SelectionPath null store
X } if
X Name /LoseFocus eq {
X InactivateCaret
X } if
X Name /RestoreFocus eq {
X ReactivateCaret
X } if
X Name /InsertValue eq {
X Action /InsertValueCallback self send
X } if
X Name /Ignore eq {
X } if
X end
X } loop
X } def
X
X /InitFont { % - => -
X % --- Initialize the current font and font metrics
X 10 dict begin
X /Font FontName findfont FontHeight scalefont store
X gsave
X false setprintermatch
X Font setfont (m) stringwidth pop /PixColWidth exch store
X grestore
X /PixRowHeight Font fontheight store
X end
X } def
X
X /Reshape { % firsttime? => -
X % --- Reshape the TextCanvas. This is where all initialization happens.
X % firsttime is true the first time the TextCanvas is reshaped;
X % false otherwise.
X %
X % --- Note: we are not enclosing this proc in a '10 dict begin end'
X % because the event handlers must be started with the class dict
X % being first on the dictionary stack. This results in firsttime?
X % being put into the instance dictionary.
X /firsttime? exch def
X % --- Take down the caret and clear any selection that is up
X firsttime? {
X LoadCaretShapeDict
X InactivateCaret
X /InputBuffer 1024 string def % Set input line buffer string to a
X % reasonable size. The buffer will
X % be grown dynamically if needed
X }{
X SupressCaret
X } ifelse
X ClearMySelection
X gsave
X Can setcanvas
X% Can /Parent get setcanvas
X% 6 array identmatrix setmatrix % X11/NeWS
X 6 array defaultmatrix setmatrix
X % --- Set up transformation matrix with font descent at the baseline
X 0 TextHeight PixRowHeight mul
X Font fontascent add Font fontdescent sub
X translate
X PixColWidth PixRowHeight neg scale
X /FontDescentTM 6 array currentmatrix store
X % --- Set up transformation matrix for direct mapping of Text coords
X% 6 array identmatrix setmatrix % X11/NeWS
X 6 array defaultmatrix setmatrix
X 0 TextHeight PixRowHeight mul
X Font fontascent add
X translate
X PixColWidth PixRowHeight neg scale
X /TM 6 array currentmatrix store
X grestore
X % --- Initialize the viewport and caret positions. Set the caret to
X % 1,1 the first time around, try to maintain previous caret
X % position subsequently
X firsttime? {
X % --- Determine the number of rows and columns in this canvas
X /CanWidth CanPixWidth PixColWidth idiv 1 sub store
X /CanHeight CanPixHeight PixRowHeight idiv 1 sub store
X % --- Initialize the position of the canvas viewport and the caret
X /CanX 1 store
X /CanY TextHeight CanHeight sub 1 add store
X /BaseY CanY 1 sub store
X /CaretX CanX store
X /CaretY CanY store
X }{
X /CaretX CaretX ViewportXdelta add store
X /CaretY CaretY ViewportYdelta add store
X /ViewportXdelta 0 store
X /ViewportYdelta 0 store
X % --- Remove any scrolling offset from caret position
X /CaretX CanX 1 sub CaretX add store
X /CaretY CanY TextHeight CanHeight sub 1 add sub CaretY add store
X % --- Determine the number of rows and columns in this canvas
X /CanWidth CanPixWidth PixColWidth idiv 1 sub store
X /CanHeight CanPixHeight PixRowHeight idiv 1 sub store
X % --- Initialize the position of the canvas viewport and the caret
X /CanX 1 store
X /CanY TextHeight CanHeight sub 1 add store
X /BaseY CanY 1 sub store
X % --- Check if the caret is out of bounds
X CaretY CanY lt {
X /CaretY CanY store
X } if
X CaretX CanWidth gt {
X /CaretX CanWidth store
X } if
X } ifelse
X % --- Reset scrolling limits
X /BotScrollLimit TextHeight store
X /TopScrollLimit CanY store
X /ScrollRegionLength BotScrollLimit TopScrollLimit sub 1 add def
X /ScrollLimitOn? false store
X % --- Set up the text arrays
X firsttime? {
X /Text TextHeight array store
X % --- Initialize Text array to empty strings
X 0 1 TextHeight 1 sub {
X Text exch () put
X } for
X % --- Initialize the input buffer to blanks
X 0 1 InputBuffer length 1 sub {
X InputBuffer exch BLANK put
X } for
X } if
X % --- Create the caret if needed
X Caret null eq {
X CreateCaret
X % --- Kick off first blink event
X createevent begin
X /Canvas Caret def
X /Name /CaretTimer def
X /Action null def
X /TimeStamp
X CaretBlinkTime 60 div CaretDutyCycle mul currenttime add
X def
X currentdict
X end
X sendevent
X } if
X % --- Create interests and event managers if they aren't running.
X % Note: this must be done with the class instance variable being
X % the first thing on the dictionary stack; otherwise the event
X % managers won't share the class' instance variables!
X EventMgr null eq {
X CreateInterests
X CreateDragInterests
X /EventMgr Interests forkeventmgr def
X /KeyboardEventMgr {KeyboardHandler} fork def
X } if
X %SelectionCan null eq {
X % --- Create the selection feedback canvas
X % XXX - Not using the selection canvas yet; still doing xor
X %/SelectionCan Can newcanvas store
X %SelectionCan begin
X % /Transparent false def
X % /EventsConsumed /NoEvents def
X %end
X %} if
X % --- Shape the viewport canvas
X gsave
X Can setcanvas
X % --- Clear the canvas
X BgColor fillcanvas
X % --- Make the canvas size be an even number of rows and cols
X Can /Parent get setcanvas
X% CanPixX CanPixY
X Can getcanvaslocation
X translate
X 0 0
X CanWidth PixColWidth mul PixColWidth add
X CanHeight PixRowHeight mul PixRowHeight add
X Font fontdescent 2 mul sub
X rectpath
X % --- Set the default matrix for the canvas to the identity matrix
X% 6 array identmatrix setmatrix % X11/NeWS
XCan setcanvas clippath
X 6 array defaultmatrix setmatrix
X Can reshapecanvas
X % --- Create the outline selection drag canvas
X /SelDragCan Can createoverlay store
X grestore
X /SelectionOn? false def
X /SelectionPath null def
X UnSupressCaret
X MoveCaret
X } def
X
X /ClearScreenArea { % x y width height => -
X % --- Fill the designated area with the background color
X gsave
X Can setcanvas
X FontDescentTM setmatrix
X 4 -2 roll % width height x y
X 1 sub % width height x y-1
X 4 2 roll % x y-1 width height
X rectpath
X BgColor setcolor fill
X grestore
X } def
X
X /MoveScreenArea { % numlines x y width height => -
X % --- Move a given area of the screen numlines
X % numlines < 0 - move down
X % " > 0 - move up
X 10 dict begin
X /height exch def
X /width exch def
X /y exch def
X /x exch def
X /numlines exch def
X gsave
X Can setcanvas
X FontDescentTM setmatrix
X x y 1 sub width height rectpath
X 0 numlines neg copyarea
X grestore
X end
X } def
X
X /FlushInputBuffer { % - => -
X % --- Flush the InputBuffer to Text array if it is in use
X InputBufferLine 0 ne {
X % --- Create a standalone string for this line in the Text array
X Text InputBufferLine Yindex
X Text InputBufferLine Yindex get InputBufferLength string copy
X put
X % --- Blank fill the previously used part of InputBuffer
X 0 1 InputBufferLength {
X InputBuffer exch BLANK put
X } for
X /InputBufferLine 0 store
X /InputBufferLength 0 store
X } if
X } def
X
X /ScrollUp { % numlines beginrow endrow => -
X % --- Scroll up numlines from a given line to another line
X 10 dict begin
X /endrow exch def
X /beginrow exch def
X /numlines exch def
X FlushInputBuffer
X ClearMySelection
X /len endrow beginrow sub 1 add def
X /numlines numlines len min def
X /inset beginrow numlines add def
X % --- Move the text
X beginrow Yindex endrow Yindex le {
X % --- We can do a fast move if the scroll region doesn't
X % wrap around the end of the physical array
X Text
X beginrow Yindex Text inset Yindex endrow inset sub 1 add
X getinterval putinterval
X }{
X % XXX This should be done as two getinterval/putintervals
X beginrow numlines add 1 endrow {
X /i exch def
X Text i numlines sub Yindex Text i Yindex get put
X } for
X } ifelse
X endrow numlines sub 1 add 1 endrow {
X Text exch Yindex () put
X } for
X numlines 1 beginrow numlines add TextWidth len numlines sub MoveScreenArea
X 1 endrow numlines sub 1 add TextWidth numlines ClearScreenArea
X end
X } def
X
X /ScrollDown { % numlines beginrow endrow => -
X % --- Scroll down numlines from a given line to another line
X 10 dict begin
X /endrow exch def
X /beginrow exch def
X /numlines exch def
X FlushInputBuffer
X ClearMySelection
X /len endrow beginrow sub 1 add def
X /numlines numlines len min def
X /inset endrow numlines sub def
X beginrow Yindex endrow Yindex le {
X % --- We can do a fast move if the scroll region doesn't
X % wrap around the end of the physical array
X Text
X beginrow numlines add Yindex Text beginrow Yindex
X inset beginrow sub 1 add getinterval putinterval
X }{
X % XXX This should be done as two getinterval/putintervals
X endrow -1 beginrow numlines add {
X /i exch def
X Text i Yindex Text i numlines sub Yindex get put
X } for
X } ifelse
X beginrow 1 beginrow numlines add 1 sub {
X Text exch Yindex () put
X } for
X numlines neg 1 beginrow TextWidth len numlines sub MoveScreenArea
X 1 beginrow TextWidth numlines ClearScreenArea
X end
X } def
X
X /RollAllTextUp { % numlines => -
X % --- Scroll the entire Text Array up numlines, adding blank lines at the
X % bottom
X 10 dict begin
X /numlines exch def
X FlushInputBuffer
X ClearMySelection
X 1 1 numlines { pop
X /MapOffset MapOffset 1 add TextHeight mod store
X Text MapOffset () put
X } for
X end
X } def
X
X /DrawText { % x y w h => -
X % --- Draw the text within the specified rectangle
X 10 dict begin
X /h exch def
X /w exch def
X /y exch def
X /x exch def
X gsave
X false setprintermatch
X Can setcanvas
X TM setmatrix
X Font setfont
X FgColor setcolor
X % --- Use the clip path to get x clipping
X x CanY 1 sub w CanHeight 1 add rectpath clip newpath
X y 1 y h add 1 sub {
X /i exch def
X 1 i moveto
X% 6 array identmatrix setmatrix % X11/NeWS
X 6 array defaultmatrix setmatrix
X Text i Yindex get show
X TM setmatrix
X } for
X grestore
X end
X } def
X
X /WriteLines { % stringarray insertmode? col row => - newcol newrow
X % Put lines into the text buffer and display them on screen.
X % stringarray is an array of lines to be displayed. Lines must
X % contain printable characters only. col,row specify the starting point
X % of the lines. The col,row of the next available text position are
X % returned. insertmode? specifies whether to overwrite existing text
X % or to insert each new line into the existing text.
X 10 dict begin
X /row exch def
X /col exch def
X /insertmode? exch def
X /lines exch def
X
X DEBUG {
X console (WriteLines: row: % col: % numlines: %\n) [row col lines length] fprintf
X 0 1 lines length 1 sub { /i exch def
X console (%\n) [lines i get] fprintf
X } for
X console flushfile
X } if
X SupressCaret
X /WriteInProgress? true store
X /numlines lines length def
X % --- Clear the current selection
X % XXX This should be more selective; only clear if overwriting
X ClearMySelection
X % --- Do one line case as fast as possible
X numlines 1 eq {
X lines col row WriteOneLine
X }{
X % --- Do any text throw-away required, either due to scrolling
X % region or exceeding the basic capacity of the Text array.
X ScrollLimitOn? {
X /numscroll 0 def
X % --- Note: No need to do anything if we are completely above
X % the scrolling region.
X
X % --- Are we starting within the scrolling region?
X row TopScrollLimit ge row BotScrollLimit le and {
X % --- Get rid of everything that won't fit in the scroll region
X numlines ScrollRegionLength gt {
X /lines lines numlines ScrollRegionLength sub
X ScrollRegionLength getinterval def
X /numlines ScrollRegionLength def
X /col 1 def
X } if
X % --- Determine number of lines to scroll
X /numscroll numlines BotScrollLimit row sub sub 1 sub def
X % --- Adjust the starting row, if needed
X row numlines add 1 sub BotScrollLimit gt {
X /row BotScrollLimit numlines 1 sub sub def
X } if
X }{
X % --- Are we starting above the scrolling region and extending
X % into it?
X row TopScrollLimit lt
X row numlines add TopScrollLimit gt and {
X % --- Write out the portion of the text that is above the
X % scrolling region by recursively calling WriteLines.
X /abovescroll TopScrollLimit row sub def
X lines 0 abovescroll getinterval insertmode? col row WriteLines
X % --- Get rid of what we just wrote out. This will make us
X % eligable for the "starting within the scrolling region"
X % case.
X /lines lines abovescroll numlines abovescroll sub
X getinterval def
X /row TopScrollLimit def
X /col 1 def
X /numlines lines length def
X } if
X % --- Are we starting below the scrolling region?
X row BotScrollLimit gt {
X % --- Get rid of everything but the last line
X /lines lines numlines 1 sub 1 getinterval def
X numlines 1 ne {
X /col 1 def
X } if
X /numscroll numlines 1 sub def
X /numlines 1 def
X } if
X } ifelse
X % --- Move existing text up, if necessary
X numscroll 0 gt {
X numscroll TopScrollLimit BotScrollLimit ScrollUp
X } if
X }{ % --- No scrolling limits set
X % --- We can handle a max of TextHeight lines. Throw everything
X % else away.
X numlines TextHeight gt {
X /lines lines numlines TextHeight sub
X TextHeight getinterval def
X /numlines TextHeight def
X } if
X % --- Scroll up the text array, if needed
X /numscroll numlines TextHeight row sub sub 1 sub def
X numscroll 0 gt {
X numscroll RollAllTextUp
X /row row numscroll sub def
X numscroll 1 1 TextWidth TextHeight MoveScreenArea
X col ViewportXdelta sub row ViewportYdelta sub TextWidth
X numscroll 1 add ClearScreenArea
X % --- If the viewport is off its original position, fill in text
X ViewportYdelta 0 ne {
X col ViewportXdelta sub row ViewportYdelta sub TextWidth
X numscroll 1 add DrawText
X % --- Clear out any partial rows or columns
X 1 CanY CanHeight add TextWidth 1 ClearScreenArea
X CanX 1 sub CanY 1 TextHeight ClearScreenArea
X } if
X } if
X } ifelse
X col 1 ne {
X lines 0 1 getinterval col row WriteOneLine /row exch def pop
X lines 1 numlines 1 sub getinterval row 1 add WriteManyLines
X }{
X lines row WriteManyLines
X } ifelse
X } ifelse
X /WriteInProgress? false store
X % --- Make sure that the newrow return value is within the scrolling limits,
X % if appropriate
X ScrollLimitOn? row BotScrollLimit le and {
X BotScrollLimit min
X } if
X end
X DelayedCaretMove % --- Must be called outside of this proc's temp dict
X } def
X
X /WriteOneLine { % stringarray col row => - newcol newrow
X % Put one line into the text buffer and display it on screen.
X % stringarray is an array containing a single line of text.
X % WriteOneLine makes use of the InputBuffer optimization.
X % col,row specify the starting point of the lines. The col,row
X % of the next available text position are returned.
X 10 dict begin
X /row exch def
X /col exch def
X /s exch 0 get def
X
X DEBUG {
X console (WriteOneLine row: % col: % slen: %\n) [row col s length] fprintf
X console (%\n) [s] fprintf
X console flushfile
X } if
X /slen s length def
X % --- Set the input buffer to this line if it isn't already there
X row InputBufferLine ne {
X FlushInputBuffer
X % --- Copy the existing Text string into InputBuffer
X /oldline Text row Yindex get def
X oldline InputBuffer copy pop
X /InputBufferLength oldline length store
X /InputBufferLine row store
X } if
X insertmode? {
X % --- Make sure we aren't exceeding the size of the input buffer
X slen col add slen InputBufferLength add max InputBuffer length gt {
X % --- If we are too big, simply grow the input buffer to accomodate!
X % Ain't automatic garbage collection wonderful...
X /InputBuffer slen col add string store
X Text row Yindex get InputBuffer copy pop
X } if
X % --- Move old Text over if necessary
X col InputBufferLength le {
X InputBuffer col slen add Xindex
X InputBuffer col Xindex InputBufferLength col sub 1 add getinterval
X putinterval
X /InputBufferLength InputBufferLength slen add store
X }{
X /InputBufferLength col slen add 1 sub store
X } ifelse
X InputBufferLength TextWidth gt {
X /TextWidth InputBufferLength store
X } if
X % --- Put insert string in
X InputBuffer col Xindex s putinterval
X }{
X % --- Make sure we aren't exceeding the size of the input buffer
X slen col add InputBuffer length gt {
X % --- If we are too big, simply grow the input buffer to accomodate!
X % Ain't automatic garbage collection wonderful...
X /InputBuffer slen col add string store
X Text row Yindex get InputBuffer copy pop
X } if
X % --- Slam the new text into the InputBuffer
X InputBuffer col Xindex s putinterval
X /InputBufferLength InputBufferLength col slen add 1 sub max store
X } ifelse
X % --- Update the text array with a substring of InputBuffer
X Text row Yindex InputBuffer 0 InputBufferLength getinterval put
X InputBufferLength TextWidth gt {
X /TextWidth InputBufferLength store
X } if
X % --- Paint the screen
X insertmode? {
X col row InputBufferLength 1 ClearScreenArea
X col row InputBufferLength 1 DrawText
X }{
X col row slen 1 ClearScreenArea
X col row slen 1 DrawText
X } ifelse
X % --- Remove any partial rows or columns
X ViewportXdelta 0 ne ViewportYdelta 0 ne or {
X 1 CanY CanHeight add TextWidth 1 ClearScreenArea
X CanX 1 sub CanY 1 TextHeight ClearScreenArea
X } if
X % --- Return new row,col
X col slen add row
X end
X } def
X
X /WriteManyLines { % stringarray row => - newcol newrow
X % Put one line into the text buffer and display it on screen.
X % stringarray is an array containing a single line of text.
X % row specifies the starting point of the lines. The col,row
X % of the next available text position are returned.
X 20 dict begin
X /row exch def
X /lines exch def
X
X DEBUG {
X console (WriteManyLines: row: % col: % numlines: %\n) [row col lines length] fprintf
X 0 1 lines length 1 sub { /i exch def
X console (%\n) [lines i get] fprintf
X } for
X console flushfile
X } if
X FlushInputBuffer
X /endrow row def
X lines {
X /s exch def
X /slen s length def
X /oldline Text endrow Yindex get def
X /oldlen oldline length def
X slen TextWidth gt {
X /TextWidth slen store
X } if
X insertmode? {
X oldlen 0 eq {
X Text endrow Yindex s put
X }{
X Text endrow Yindex s oldline append put
X } ifelse
X }{
X slen oldlen ge {
X Text endrow Yindex s put
X }{
X oldline 0 s putinterval
X } ifelse
X } ifelse
X /endrow endrow 1 add def
X /col slen 1 add def
X } forall
X % --- Clear the changed screen area and draw the new text
X 1 row TextWidth endrow row sub 1 add ClearScreenArea
X 1 row TextWidth endrow row sub 1 add DrawText
X % --- Remove any partial rows or columns
X ViewportXdelta 0 ne ViewportYdelta 0 ne or {
X 1 CanY CanHeight add TextWidth 1 ClearScreenArea
X CanX 1 sub CanY 1 TextHeight ClearScreenArea
X } if
X % --- Return values
X col endrow 1 sub
X end
X } def
X
X /CreateCaret { % - => -
X % --- Create, shape, and color the caret canvas
X CaretColor null eq {
X ColorDisplay?
X {/CaretColor DefaultColorCaret store}
X {/CaretColor DefaultMonoCaret store} ifelse
X } if
X gsave
X Can setcanvas
X /Caret Can newcanvas store
X Caret begin
X /Transparent false def
X Can /Retained get {
X% REMIND:
X% There doesn't seem to be any reason to make the cursor retained.
X% Let's try taking this out some time...
X% /Retained true def
X% HURRAY! IT WORKED! It even made the 386i X11/NeWS beta 2 server stop dumping!
X /Retained false def
X }{
X /SaveBehind true def
X } ifelse
X /EventsConsumed /MatchedEvents def
X end
X ShapeCaret
X grestore
X } def
X
X /ShapeCaret { % - => -
X % --- Shape the caret canvas from a proc in the CaretShapeDict
X gsave
X% framebuffer setcanvas % ???
X% matrix defaultmatrix setmatrix % ???
X Can setcanvas
X % ---Set up x,y arguments to caret shape proc
X PixColWidth PixRowHeight
X % ---Get the caret shape proc and execute it
X CaretShapeDict CaretShape get exec
X PixColWidth PixRowHeight neg scale
X 0 1 translate
X Caret reshapecanvas
X grestore
X } def
X
X /MapCaret { % - => -
X % --- Make the caret visible and color it
X gsave
X Caret mapcanvas
X Caret setcanvas
X CaretInactive? {
X% /mapcaret dbgbreak
X% CORE DUMPS X11/NeWS beta 2 386i:
X DefaultInactiveColor fillcanvas
X }{
X CaretColor fillcanvas
X } ifelse
X grestore
X } def
X
X /UnMapCaret { % - => -
X % --- Make the caret invisible
X Caret unmapcanvas
X } def
X
X /MoveCaret { % - => -
X gsave
X Caret unmapcanvas
X Caret setcanvas
X CaretX ViewportXdelta add CaretY ViewportYdelta add
X movecanvas
X Caret mapcanvas
X grestore
X } def
X
X /InactivateCaret { % - => -
X % --- Shade the caret with the inactive color and stop any blinking
X 10 dict begin
X /CaretInactive? true store
X CaretOn? {
X gsave
X Caret mapcanvas
X Caret setcanvas
X% Bombs X11/NeWS beta 2 on 386i: (sh_386_fill_shape, fillscans)
X DefaultInactiveColor fillcanvas
X grestore
X } if
X end
X } def
X
X /ReactivateCaret { % - => -
X % --- Set caret back to normal
X 10 dict begin
X /CaretInactive? false store
X CaretOn? {
X gsave
X Caret mapcanvas
X Caret setcanvas
X CaretColor fillcanvas
X grestore
X } if
X end
X } def
X
X /SupressCaret { % - => -
X % --- Temporarily turn the caret off
X 10 dict begin
X CaretOn? {
X /CaretSupressed? true store
X UnMapCaret
X } if
X end
X } def
X
X /UnSupressCaret { % - => -
X % --- Turn the caret back on
X 10 dict begin
X CaretOn? {
X /CaretSupressed? false store
X MapCaret
X } if
X end
X } def
X
X /DelayedCaretMove { % - => -
X % --- Move the caret after waiting CaretDelayTime seconds,
X % but only if a write or another delayed caret move is
X % not in progress
X % Note: This proc must be called with the class instance dictionary
X % being the first thing on the dict stack, since it forks a process
X % that change instance variables.
X CaretOn? {
X % --- Update the time that the caret move will actually be done
X /NextMoveTime currenttime 1 60 div CaretDelayTime mul add store
X % --- Only fork a timer if one isn't already going
X DelayedMoveProc null eq {
X % --- Fork the move timer
X /DelayedMoveProc {
X % Go to sleep, checking NextMoveTime each time we awaken
X {
X NextMoveTime currenttime sub sleep
X NextMoveTime currenttime le {
X exit
X } if
X } loop
X % --- If there is no write in progress then move the caret and
X % turn it on
X WriteInProgress? not {
X /CaretSupressed? false store
X MoveCaret
X MapCaret
X } if
X /DelayedMoveProc null store
X } fork store
X } if
X } if
X } def
X
X% /DrawSelectionText { % x y y1 => -
X% % --- Draw text onto the selection canvas
X% 10 dict begin
X% /y1 exch def
X% /y exch def
X% /x exch def
X% gsave
X% false setprintermatch
X% SelectionCan setcanvas
X% FgColor fillcanvas
X% FontDescentTM setmatrix
X% x 1 sub neg TextHeight y1 sub translate
X% /SelectTM 6 array currentmatrix def
X% Font setfont
X% BgColor setcolor
X% /j 1 def
X% y 1 y1 {
X% /i exch def
X% 1 i moveto
X% 6 array identmatrix setmatrix
X% Text i Yindex get show
X% SelectTM setmatrix
X% /j j 1 add def
X% } for
X% grestore
X% end
X% } def
X
X /DrawSelection { % state => -
X % --- Make the selection area visible or invisible, depending on state.
X 10 dict begin
X /state exch def
X %state {
X % SelectionPath null ne {
X % gsave
X % 6 array identmatrix setmatrix
X % SelectionPath setpath
X % SelectionCan reshapecanvas
X % SelectionY SelectionY1 lt {
X % 1 SelectionY SelectionY1 DrawSelectionText
X % } if
X % SelectionY SelectionY1 gt {
X % 1 SelectionY1 SelectionY DrawSelectionText
X % } if
X % SelectionY SelectionY1 eq {
X % SelectionX SelectionY1 SelectionY DrawSelectionText
X % } if
X % SelectionCan mapcanvas
X % /SelectionOn? true store
X % grestore
X % } if
X %}{ % --- state = off
X % SelectionCan unmapcanvas
X % /SelectionOn? false store
X %} ifelse
X % --- XXX Use xor for now; SelectionCanvas in the future...
X gsave
X SelectionPath null ne SelectionOn? state xor and {
X Can setcanvas
X TM setmatrix
X 5 setrasteropcode
X SelectionPath setpath
X fill
X /SelectionOn? state store
X } if
X grestore
X end
X } def
X
X /ClearMySelection { % - => -
X % --- Clear any selection I might have in the system selection mechanism
X % and on my screen.
X 10 dict begin
X SelectionOn? {
X false DrawSelection
X /SelectionPath null store
X } if
X /seldict /PrimarySelection getselection def
X seldict null ne {
X seldict XNeWS? /Holder /Canvas ifelse % not defined in X11/NeWS
X get Can eq {
X% Selections /PrimarySelection null put % broke in X11/NeWS
X /PrimarySelection clearselection
X } if
X } if
X end
X } def
X
X /SendClearSelection { % - => -
X % --- Clear anyone else's Primary selection
X 10 dict begin
X /seldict /PrimarySelection getselection def
X seldict null ne {
X seldict XNeWS? /Holder /Canvas ifelse % not defined in X11/NeWS
X get Can ne {
X /PrimarySelection clearselection
X } if
X } if
X end
X } def
X
X /ExtendSelection { % - => -
X % --- Draw the selection bounding outline
X 10 dict begin
X gsave
X FontDescentTM setmatrix
X /l Text SelectionY1 Yindex get length 2 add def
X SelectionX1 l gt {
X /SelectionX1 l def
X } if
X SelectionY SelectionY1 eq {
X SelectionX SelectionY SelectionX1 SelectionY1 1 sub
X points2rect rectpath
X }{
X SelectionY SelectionY1 gt {
X /y SelectionY1 def /x SelectionX1 def
X /y1 SelectionY def /x1 SelectionX def
X }{
X /y SelectionY def /x SelectionX def
X /y1 SelectionY1 def /x1 SelectionX1 def
X } ifelse
X 1 y moveto
X x y lineto
X 0 -1 rlineto
X /l Text y Yindex get length 2 add def
X l y 1 sub lineto
X 0 1 rlineto
X /y y 1 add def
X y 1 y1 1 sub {
X /i exch def
X /l Text i Yindex get length 2 add def
X l i 1 sub lineto
X l i lineto
X } for
X x1 y1 1 sub lineto
X x1 y1 lineto
X 1 y1 lineto
X closepath
X } ifelse
X /SelectionPath currentpath store
X 0 setlinewidth % Thick lines look funky with xor, but it's a bug...
X stroke
X grestore
X end
X } def
X
X /GetSelection { % - => string
X % --- Returns the text of the current selection
X 10 dict begin
X SelectionPath null eq {
X ()
X }{
X % --- We always want y <= y1, no matter what direction the selection
X % was done in
X SelectionY SelectionY1 lt {
X /y SelectionY def /x SelectionX def
X /y1 SelectionY1 def /x1 SelectionX1 1 sub def
X } if
X SelectionY SelectionY1 gt {
X /y SelectionY1 def /x SelectionX1 def
X /y1 SelectionY def /x1 SelectionX 1 sub def
X } if
X SelectionY SelectionY1 eq {
X /y SelectionY def /x SelectionX def
X /y1 SelectionY1 def /x1 SelectionX1 1 sub def
X % --- If we are on the same line, we want x <= x1
X x x1 gt {
X x
X /x x1 1 add def
X /x1 exch 1 sub def
X } if
X } if
X % --- Make a string that is at least the right size
X /slen 0 def
X y 1 y1 {/i exch def /slen Text i Yindex get length slen add 1 add def} for
X /s slen string def
X /sptr 0 def
X % --- Get the first line of the selection text
X /s1 Text y Yindex get def
X /l s1 length def
X % --- Index into it by x (add a LF if x > linelength)
X x l gt {
X s sptr LF put
X /sptr sptr 1 add def
X }{
X /s1 s1 x Xindex l x sub 1 add getinterval def
X s sptr s1 putinterval
X /sptr sptr s1 length add def
X } ifelse
X % --- Check for a single line selection
X y y1 eq {
X % --- Clip the line at x1 (add a LF if x1 > linelength)
X x1 l gt {
X % --- Make sure we don't put in two LF's
X x l le {
X s sptr LF put
X /sptr sptr 1 add def
X } if
X }{
X /sptr x1 x sub 1 add def
X } ifelse
X }{ % --- Multi-line selection
X % --- Put LF after first line if needed
X x l le {
X s sptr LF put
X /sptr sptr 1 add def
X } if
X y 1 add 1 y1 {
X /i exch def
X % --- Get the i'th line
X /l Text i Yindex get length def
X /s1 Text i Yindex get def
X % --- Check if this is the last line
X i y1 eq {
X x1 l gt {
X s sptr s1 putinterval
X /sptr sptr l add def
X s sptr LF put
X /sptr sptr 1 add def
X }{
X /s1 s1 0 x1 getinterval def
X s sptr s1 putinterval
X /sptr sptr s1 length add def
X } ifelse
X }{
X s sptr s1 putinterval
X /sptr sptr l add def
X s sptr LF put
X /sptr sptr 1 add def
X } ifelse
X } for
X } ifelse
X s 0 sptr getinterval
X } ifelse
X } def
X
X% ----------------------------- New Methods -----------------------------------
X
X /changefont { % fname fheight - => -
X % --- Change the current font and point size. Either fname or fheight
X % may be null, in which case they are ignored.
X 10 dict begin
X /fheight exch def
X /fname exch def
X fheight null ne {
X /FontHeight fheight store
X % --- Check for minimum visibility
X FontHeight 6 lt {
X /FontHeight 6 store
X } def
X } if
X fname null ne {
X /FontName fname store
X } if
X InitFont
X false Reshape
X 1 1 TextWidth TextHeight DrawText
X CaretOn? {
X ShapeCaret
X MapCaret
X MoveCaret
X } if
X /ResizeCallback self send
X end
X } def
X
X /writelines { % arrayofstrings insertmode? col row => -
X % --- Write an array of strings, starting the first string at col,row
X % with subsequent strings going at 1,row+1 1,row+2 etc. insertmode?
X % specifies whether the new lines will overwrite existing text or
X % be inserted at the specified location.
X BaseY add
X WriteLines pop pop
X pause
X } def
X
X /writeatcaret { % arrayofstrings insertmode? => -
X % --- Similar to writelines, except start at the current caret location. The
X % caret is moved to the next available character position when the write is
X % done.
X CaretX CaretY WriteLines
X /CaretY exch store
X /CaretX exch store
X pause
X } def
X
X /deletestring { % length col row => -
X % --- Delete a string starting at col,row for length characters.
X % length must be 0 or a positive integer.
X BaseY add
X 10 dict begin
X /row exch def
X /col exch def
X /len exch def
X
X % --- Set the input buffer to this line if it isn't already there
X row InputBufferLine ne {
X FlushInputBuffer
X % --- Copy the existing Text string into InputBuffer
X /oldline Text row Yindex get def
X /oldlength oldline length def
X oldline InputBuffer copy pop
X /InputBufferLine row store
X /InputBufferLength oldlength store
X }{
X /oldlength InputBufferLength def
X } ifelse
X col InputBufferLength le {
X % --- Move old text over
X InputBuffer col Xindex
X InputBuffer col len add Xindex InputBufferLength len add getinterval
X putinterval
X % --- Update line length
X /InputBufferLength InputBufferLength len sub col 1 sub max store
X } if
X % --- Update the Text array
X Text row Yindex InputBuffer 0 InputBufferLength getinterval put
X % --- Update display
X col row oldlength 1 ClearScreenArea
X col row oldlength 1 DrawText
X end
X } def
X
X /insertline { % numlines row => -
X % --- Insert numlines blank lines, starting at line row.
X % numlines must be 0 or a positive integer
X BaseY add
X 10 dict begin
X /row exch def
X /numlines exch def
X numlines row TextHeight ScrollDown
X end
X } def
X
X /deleteline { % numlines row => -
X % --- Delete numlines lines, starting at line row.
X % numlines must be 0 or a positive integer
X BaseY add
X 10 dict begin
X /row exch def
X /numlines exch def
X numlines row TextHeight ScrollUp
X end
X } def
X
X /setscrollinglimits { % toprow bottomrow => -
X % --- Sets the scrolling limits for the TextCanvas. All up or down scrolling
X % will be limited to this region instead of affecting the entire Text
X % canvas. When scrolling limits are set, those methods which can
X % trigger scrolling (writelines, writeatcaret, movecaretdelta) will
X % only cause scrolling if they affect lines within the scrolling region.
X % Any scrolling that is initiated will only move lines within the
X % scrolling region.
X /BotScrollLimit exch BaseY add def
X /TopScrollLimit exch BaseY add def
X /ScrollRegionLength BotScrollLimit TopScrollLimit sub 1 add def
X /ScrollLimitOn? true def
X } def
X
X /removescrollinglimits { % - => -
X % --- Removes any scrolling bounds set by setscrollinglimits.
X /BotScrollLimit TextHeight def
X /TopScrollLimit CanY def
X /ScrollRegionLength BotScrollLimit TopScrollLimit sub 1 add def
X /ScrollLimitOn? false def
X } def
X
X /clearviewport { % - => -
X % --- Clear the text and screen area of the base viewport
X ScrollLimitOn? {
X CanHeight BaseY 1 add BaseY CanHeight add ScrollUp
X }{
X CanHeight RollAllTextUp
X 1 BaseY 1 add TextWidth CanHeight ClearScreenArea
X } ifelse
X } def
X
X /flashviewport { % - => -
X % --- Flash the contents of the viewport (visible bell)
X gsave
X Can setcanvas
X initclip
X clipcanvaspath
X 5 setrasteropcode
X fill
X clipcanvaspath
X fill
X grestore
X } def
X
X /moveviewport { %x y => -
X % --- Move the viewport to another part of the underlying Text array.
X % x and y must be between 0 and 1. This represents a percentage of the
X % current total width or height of the Text array. Either argument
X % can be null, in which case it is ignored.
X 10 dict begin
X SupressCaret
X dup null ne {
X /newY exch TextHeight CanHeight sub mul 1 add round def
X newY 1 lt {
X /newY 1 def
X } if
X /ydelta CanY newY sub def
X ClearMySelection
X }{
X /newY exch def
X /ydelta 0 def
X } ifelse
X dup null ne {
X /newX exch TextWidth CanWidth sub mul 1 add round def
X newX 1 lt {
X /newX 1 def
X } if
X /xdelta CanX newX sub def
X ClearMySelection
X }{
X /newX exch def
X /xdelta 0 def
X } ifelse
X gsave
X Can setcanvas
X FontDescentTM setmatrix
X CanX CanY 1 sub CanWidth CanHeight 1 add rectpath
X xdelta ydelta copyarea
X xdelta ydelta translate
X /FontDescentTM 6 array currentmatrix store
X % --- XXX translate doesn't work with a matrix operand yet
X TM setmatrix
X xdelta ydelta translate
X /TM 6 array currentmatrix store
X grestore
X xdelta 0 ne {
X /CanX newX store
X xdelta 0 gt {
X CanX CanY xdelta CanHeight ClearScreenArea
X CanX CanY xdelta CanHeight DrawText
X }{
X CanX CanWidth add xdelta add CanY
X xdelta neg CanHeight ClearScreenArea
X CanX CanWidth add xdelta add CanY
X xdelta neg CanHeight DrawText
X % --- Clear out column 0
X CanX 1 sub CanY 1 TextHeight ClearScreenArea
X } ifelse
X } if
X ydelta 0 ne {
X /CanY newY store
X ydelta 0 gt {
X CanX CanY CanWidth ydelta 1 add ClearScreenArea
X CanX CanY CanWidth ydelta 1 add DrawText
X }{
X CanX CanY CanHeight add ydelta add
X CanWidth ydelta neg ClearScreenArea
X CanX CanY CanHeight add ydelta add
X CanWidth ydelta neg DrawText
X } ifelse
X } if
X CanX CanY CanHeight add CanWidth 1 ClearScreenArea
X /ViewportXdelta ViewportXdelta xdelta add store
X /ViewportYdelta ViewportYdelta ydelta add store
X MoveCaret
X UnSupressCaret
X end
X } def
X
X /getviewportsize { % - => col rows xpixels ypixels
X % --- Return the number of columns, rows, pixel height and width of
X % the viewport.
X CanWidth CanHeight CanPixWidth CanPixHeight
X } def
X
X /getlinelength { % row => length
X % --- Return the current length of the line at row.
X BaseY add
X Text exch Yindex get
X length
X } def
X
X /calcarea { % pixwidth pixheight => numcols numrows
X % --- Returns the number of rows and columns that will fit into the pixel
X % area specified by pixwidth and pixheight, given the current Font and
X % point size.
X 10 dict begin
X /pixheight exch def
X /pixwidth exch def
X % --- Compute numcols
X pixwidth PixColWidth idiv
X % --- Compute numrows
X pixheight PixRowHeight idiv 1 add
X end
X } def
X
X /calcpixarea { % numcols numrows => pixwidth pixheight
X % --- Returns the minimum pixel area required to display numrows and numcols,
X % given the current Font and point size.
X 10 dict begin
X /numcols exch def
X /numrows exch def
X % --- Compute pixwidth
X numcols PixColWidth mul
X % --- Compute pixheight
X numrows PixRowHeight mul 1 sub
X end
X } def
X
X /oncaret { % - => -
X % --- Turn the caret on.
X /CaretOn? true def
X MapCaret
X MoveCaret
X } def
X
X /offcaret { % - => -
X % --- Turn the caret off.
X UnMapCaret
X /CaretOn? false def
X } def
X
X /movecaret { % col row => -
X % --- Move the caret to an absolute position. col and row are integers. Scrolling is
X % never triggered.
X /CaretY exch BaseY add def
X /CaretX exch def
X CaretX TextWidth gt {/TextWidth CaretX store} if
X MoveCaret
X } def
X
X /movecaretdelta { % deltax deltay => -
X % --- Move the caret relative to its current position. deltax and deltay must be
X % integers (negatives allowed). Scrolling is triggered if deltay moves the caret
X % outside of the scrolling limits. If no scrolling limits are set, scrolling is
X % triggered if deltay moves the caret outside of the original viewport region.
X 10 dict begin
X /deltay exch def
X /deltax exch def
X /CaretY CaretY deltay add store
X /CaretX CaretX deltax add store
X CaretY TopScrollLimit lt {
X TopScrollLimit CaretY sub TopScrollLimit BotScrollLimit ScrollDown
X /CaretY TopScrollLimit store
X } if
X CaretY BotScrollLimit gt {
X CaretY BotScrollLimit sub TopScrollLimit BotScrollLimit ScrollUp
X /CaretY TextHeight store
X } if
X CaretX 1 lt {/CaretX 1 store} if
X CaretX TextWidth gt {/TextWidth CaretX store} if
X MoveCaret
X end
X } def
X
X /setcaretblink { % blink-rate duty-cycle => -
X % --- Set the caret blink rate and the blink duty cycle. blink-rate is
X % in seconds and represents a complete on/off cycle. duty-cycle is
X % between 0 and 1, and represents the percentage of on time.
X dup null ne {
X /CaretDutyCycle exch def
X }{
X pop
X } ifelse
X dup null ne {
X dup 0 ne {
X /CaretBlinkTime exch def
X /CaretBlinkEnabled? true def
X }{
X % --- Disable caret, but keep blink events going at a
X % 2 second rate
X pop
X /CaretBlinkTime 2 def
X /CaretBlinkEnabled? false def
X CaretOn? {MapCaret} if
X } ifelse
X }{
X pop
X } ifelse
X } def
X
X /setcaretcolor { % color => -
X % --- Set the current caret color. color is a color object.
X /CaretColor exch def
X CaretOn? {MapCaret} if
X } def
X
X /setcaretshape { % shapename => successful?
X % --- Set the caret shape. shapename should be an entry in the CaretShapeDict.
X % Return a boolean that tells whether shapename was found.
X dup CaretShapeDict exch known {
X /CaretShape exch def
X Caret null ne {ShapeCaret MoveCaret} if
X true
X } {
X pop pop
X false
X } ifelse
X } def
X
X /getcaretpos { % - => col row
X % --- Return the current caret position
X CaretX
X CaretY BaseY sub
X } def
X
X /setbgcolor { % color => -
X % --- Set the current canvas background color
X ClearMySelection
X /BgColor exch def
X } def
X
X /setfgcolor { % color => -
X % --- Set the current text color
X ClearMySelection
X /FgColor exch def
X } def
X
X /fixdamage { % - => -
X % --- Damage handler; goes in the PaintClient window callback routine
X BgColor fillcanvas
X CanX CanY CanWidth CanHeight DrawText
X } def
X
X /new { % numrows can => object
X % --- Create a new instance of the TextCanvas. numrows is the number
X % of lines to be allocated in the Text array; it is fixed for
X % the life of the instance. can is the viewport canvas.
X /new super send begin
X /Can exch def
X /TextHeight exch def
X% Here's an attempt to keep the 386i X11/NeWS beta 2 server from core dumping.
X%Can /Transparent false put
X Can /Retained true put % XXX - Non-retained will work, but NeWS sometimes
X % reports more damage than has actually occurred,
X % so going non-retained can be very costly
X gsave
X % --- Determine canvas pixel width and height
X Can setcanvas
X initclip clipcanvaspath pathbbox % llx lly urx ury
X points2rect % x y w h
X grestore
X /CanPixHeight exch def
X /CanPixWidth exch def
X /CanPixY exch def
X /CanPixX exch def
X InitFont
X true Reshape
X currentdict
X end
X } def
X
X /reshape { % - => -
X % --- This method must be called whenever the viewport canvas has changed
X % size. It updates the number of rows and columns in the TextCanvas,
X % repositions the caret to be as close to its old position as possible,
X % resets the scrolling region, and moves the viewport to its base position.
X gsave
X % --- Determine the new pixel width and height
X Can setcanvas
X initclip clipcanvaspath pathbbox % llx lly urx ury
X points2rect % x y w h
X grestore
X /CanPixHeight exch def
X /CanPixWidth exch def
X /CanPixY exch def
X /CanPixX exch def
X false Reshape
X /ResizeCallback self send
X } def
X
X /destroy { % - => -
X mark {
X KeyboardInterest Can revokekbdinterests
X MoreInterests { revokeinterest } forall
X } stopped cleartomark
X EventMgr null ne {
X EventMgr killprocess
X } if
X MouseDragEventMgr null ne {
X MouseDragEventMgr killprocess
X } if
X } def
X
Xclassend def
Xend % systemdict
X%} if % /TextCanvas known not...
X
//go.sysin dd *
if [ `wc -c < textcan.ps` != 83120 ]; then
made=false
echo error transmitting textcan.ps --
echo length should be 83120, not `wc -c < textcan.ps`
else
made=true
fi
if $made; then
chmod 664 textcan.ps
echo -n ' '; ls -ld textcan.ps
fi
echo Extracting overlay.ps
sed 's/^X//' <<'//go.sysin dd *' >overlay.ps
X%!
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%
X% Class OverlayWindow
X% Copyright (C) 1989.
X% By Don Hopkins. (don@brillig.umd.edu)
X% All rights reserved.
X%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%
X% This program is provided for UNRESTRICTED use provided that this
X% copyright message is preserved on all copies and derivative works.
X% This is provided without any warranty. No author or distributor
X% accepts any responsibility whatsoever to any person or any entity
X% with respect to any loss or damage caused or alleged to be caused
X% directly or indirectly by this program. This includes, but is not
X% limited to, any interruption of service, loss of business, loss of
X% information, loss of anticipated profits, core dumps, abuses of the
X% virtual memory system, or any consequential or incidental damages
X% resulting from the use of this program.
X%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%
X% Overlay plane compatibility hack for cg4 frame buffer.
X% This is a nebulous layer abstracted from a messy program, to make it run
X% on generic NeWS servers. It should be rethought and rewritten. Repent!
X%
X% Requires the devices /dev/cgfour0, /dev/cgfour0_ovl, and /dev/cgfour0_ove
X% (which can all be major 39 minor 0, or whatever), and the following patch
X% to the NeWS 1.1 server sources (but X11/NeWS doesn't need to be patched!),
X% in order to take advantage of a cg4 under NeWS 1.1 (Otherwise it falls back
X% to using exclusive-or).
X%
X% Put the flag -DCG4_ENABLE_HACK into COPTS in the top level server Makefile.
X% Make the following patch to the file SUN/src/server/dev/sunw/pixrectint.c:
X% In function cg4_make:
X% Replace the block starting with the following comment:
X% /* set up pixrect initial state */
X% {
X% #ifdef CG4_ENABLE_HACK
X% int initplanes, initfb = CG4_INITFB;
X% extern char *sun_fb_name;
X% char *index();
X% int len = strlen (sun_fb_name);
X%
X% /* Special file names get overlay and enable planes */
X% if (index(sun_fb_name, '_') != NULL) {
X% if (sun_fb_name[len-1] == 'l') /* cgfour0_ovl */
X% initfb = 0; /* overlay plane */
X% else if (sun_fb_name[len-1] == 'e') /* cgfour0_ove */
X% initfb = 1; /* enable plane */
X% else initfb = 2; /* color plane */
X% }
X%
X% initplanes =
X% PIX_GROUP(fbdesc[initfb].group) |
X% fbdesc[initfb].allplanes;
X% #else !CG4_ENABLE_HACK
X% int initplanes =
X% PIX_GROUP(fbdesc[CG4_INITFB].group) |
X% fbdesc[CG4_INITFB].allplanes;
X% #endif !CG4_ENABLE_HACK
X%
X% (void) cg4_putattributes(pr, &initplanes);
X% }
X%
X% Damn damn damn! X11/NeWS Version 1.0 FCS on a cg4 can open up the
X% enable plane, but there's a bug that trashes the enable plane color map,
X% so we can draw in gray scales but we can't draw in white (black?).
X%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X
Xsystemdict begin
X
Xsystemdict /XNeWS? known not {
X systemdict /XNeWS? false put
X} if
X
X/overlay-dev (/dev/cgfour0_ovl) def
X/enable-dev (/dev/cgfour0_ove) def
X/color-dev (/dev/cgfour0) def
X
Xmark
Xsystemdict /fb_overlay known not {
X /fb_overlay null def /fb_enable null def /fb_color null def
X /mono? framebuffer /Color get not def
X systemdict /no_funny_stuff known
X XNeWS? or % disabled, because of pre-fsc X11/NeWS...
X { true } {
X {
X /fb_overlay overlay-dev createdevice store
X %fb_overlay /Retained true put
X /fb_enable enable-dev createdevice store
X XNeWS? {
X% this-is-currently-disabled % delete this line to re-enable, but it don't work
X % Attempt to work around bug with X11/NeWS pre-fcs:
X % The color map of the enable plane is bogus.
X % 1 setgray results in black instead of white.
X % All other setgrays < 1 come out the right color.
X /fb_enable fb_enable
X{
X fb_overlay begin
X Visual Colormap
X end
X} pop
X newcanvas store
X framebuffer setcanvas
X clippath fb_enable reshapecanvas
X fb_enable /Transparent false put
X fb_enable /Mapped true put
X } if
X fb_enable /Retained true put % is there any damage?
X % if so, have event mgr clean it up instead of retaining?
X /fb_color color-dev createdevice store
X % createdevice bug: ignores file name (MacNeWS)
X fb_enable /Color get not fb_color /Color get and {
X gsave
X fb_enable setcanvas
X mono? 0 1 ifelse fillcanvas
X grestore
X } {
X /fb_overlay null store
X /fb_enable null store
X /fb_color null store
X that-aint-no-overlay-plane!
X } ifelse
X } errored
X } ifelse
X /cg4? exch not def
X cg4? not {
X systemdict /fb_overlay undef
X systemdict /fb_enable undef
X systemdict /fb_color undef
X } if
X} if
Xcleartomark
X
X/OverlayWindow DefaultWindow
Xdictbegin
X /EnableCanvas null def
X /EnableOverlay null def
X /OverlayCanvas null def
X /ColorCanvas null def
X /TrackCanvas null def
X /OtherCanvas null def
X /HiliteCanvas null def
X /SpriteCanvas null def
X /SpriteMaskCanvas null def
X /BubbleRadius 32 def
X /LastX 0 def /LastY 0 def
X /LastW 0 def /LastH 0 def
X /InitialOverlayGray 0 def
X /InitialEnableGray 1 def
Xdictend
Xclassbegin
X
Xcg4? { % cg4
X
X /ShapeClientCanvas {
X /ShapeClientCanvas super send
X gsave
X ClientCanvas setcanvas
X /nouse /nouse_m ClientCanvas setstandardcursor
X clippath OverlayCanvas reshapecanvas
X clippath EnableCanvas reshapecanvas
X EnableCanvas setcanvas
X InitialEnableGray fillcanvas
X OverlayCanvas setcanvas
X InitialOverlayGray fillcanvas
X ClientCanvas setcanvas
X ClientWidth 2 div ClientHeight 2 div
X SpriteShape
X SpriteMaskCanvas reshapecanvas
X grestore
X DrawSpriteMask
X } def
X
X /UpdateSprite { % x y => -
X gsave
X SpriteMaskCanvas setcanvas
X XNeWS? not {
X SpriteHotY
X dup add sub
X } if % ARGH!
X movecanvas
X SpriteMaskCanvas /Mapped true put
X grestore
X } def
X
X /HideSprite {
X SpriteCanvas /Mapped false put
X SpriteMaskCanvas /Mapped false put
X } def
X
X /SpriteShape { % x y => -
X translate
X SpriteHotX neg SpriteHotY neg translate
X 0 0 BubbleRadius 0 360 arc
======== END OF cyber.shar.splitab ========