don@TUMTUM.CS.UMD.EDU (Don Hopkins) (11/23/89)
======== START OF cyber.shar.splitad ========
X
X } LiteMenu send
X
X { % send to Item:
X
X% Beta 2 bug, liteitem.ps, class Item
X /ThingSize { % thing textfont => width height
X gsave
X setfont
X% dup type { % X11/NeWS font type = dicttype, so use 'truetype'
X dup truetype {
X /stringtype {stringwidth pop currentfont fontheight}
X /nametype {
X dup { load } stopped pop xcheck {
X false exch cvx exec
X } {
X iconfont setfont iconstring stringbbox 4 2 roll pop pop
X } ifelse
X }
X /nulltype {0 0}
X /Default {0 0}
X } case
X grestore
X } def
X
X% Beta 2 bug, liteitem.ps, class Item
X /ShowThing { % thing color x y textfont => -
X gsave
X setfont translate setcolor
X 0 0 moveto % moveto establishs current pt.
X% dup type { % X11/NeWS font type = dicttype, so use 'truetype'
X dup truetype {
X /stringtype {0 currentfont fontdescent rmoveto show}
X /nametype {
X dup { load } stopped pop xcheck {
X true exch cvx exec
X } {
X iconfont setfont iconstring show
X } ifelse
X }
X /nulltype {pop}
X /Default {pop}
X } case
X grestore
X } def
X
X% Beta 2 bug, liteitem.ps, class Item
X /EraseThing { % thing color x y textfont => -
X gsave
X% X11/NeWS: {load} stopped => ... `load` true, but {load} errored => ... true
X% 4 index dup type /nametype eq exch { load } stopped pop xcheck and {
X 4 index dup type /nametype eq exch { load } errored pop xcheck and {
X 5 -1 roll exch ThingSize rectpath setcolor fill
X } {
X ShowThing
X } ifelse
X grestore
X } def
X
X } Item send
X
X { % send to SimpleScrollbar:
X
X% Beta 2 bug, liteitem.ps, class SimpleScrollbar
X% /ScrollDownArrow 16 16 1 { } { < % X11/NeWS: matrix arg isn't ignored!
X% > } buildimage def
X /ScrollDownArrow 16 16 1 [16 0 0 -16 0 16] { <
X 07F8 0FF8 0818 0818 0818 0818 781F F81F
X 8002 4004 2008 1010 0820 0440 0280 0100
X > } buildimage def
X
X% Arrgh, it's still hosing me! I'm mad now!
X /PaintArrow {
X gsave
X translate scale setshade
X .5 .1 moveto
X .1 .9 lineto
X .5 .6 lineto
X .9 .9 lineto
X closepath
X fill
X grestore
X } def
X
X } SimpleScrollbar send
X
X} if % version 1.0 (beta 2 bugs)
X
Xend % systemdict
X
X% end of X11/NeWS compatibility crud
X
X} { % else if not X11/NeWS (install NeWS 1.1 compatibility stuff)
X systemdict begin
X
X /truetype { type } ?def
X /RootUserDict 10 dict def
X
X end % systemdict
X} ifelse
X
X% End of compatibility crud. You can empty your barf bag now.
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Icky system globals and merciless kludges
X
Xsystemdict begin
X
X/array? { % obj => bool
X type dup /arraytype eq exch /packedarraytype eq or
X} def
X
X/comment { pop } def
X
X% Reap dead debuggers
X/rd {
X systemdict /DbgDicts known {
X [ DbgDicts {pop} forall ] {
X dup /State get /zombie eq {
X dup killprocess
X DbgDicts exch undef
X } { pop } ifelse
X } forall
X } if
X} def
X
Xrd
X
X/_ViewCanvas null def
X
X/_SendUpdateStack {
X count array astore aload
X null /UpdateStack _SendViewEvent
X% { flush } errored {
X% { dbgstop } errored quit
X% } if
X} def
X
X/_SendViewEvent { % ClientData Action Name => -
X createevent begin
X /Name exch def
X /Action exch def
X /ClientData exch def
X /Canvas
X currentprocess /Interests get 0 get % event
X /ClientData get /ViewCanvas get % can
X def
X currentdict end sendevent
X} def
X
X/_ReadyProcess {
X {
X currentprocess
X XNeWS? {
X dup /ProcessName (Spike) put
X } if
X createevent begin
X /Canvas _ViewCanvas def
X /Name /ProcessReady def
X /Action currentprocess def
X count array astore aload
X /ClientData exch def
X currentdict end sendevent
X createevent begin
X /Name 20 dict def
X Name begin
X /ExecIt {
X /ClientData get
X exec
X _SendUpdateStack
X } def
X /ReplaceStack {
X dup /Action get dup type /stringtype ne { pop } {
X { print flush } errored {
X { dbgstop } errored
X clear currentprocess killprocessgroup
X } if
X } ifelse
X /ClientData get
X count 1 roll
X count 1 sub {pop} repeat
X aload pop
X } def
X /DropDead {
X { dbgstop } errored
X { (Ayyyeee!\n) print flush } errored
X clear currentprocess killprocessgroup
X } def
X end % Name
X /ClientData 20 dict def
X ClientData begin
X /ViewCanvas _ViewCanvas def % Stash!
X end % ClientData
X currentdict end expressinterest
X
X% The /execfile kludge is to get around the fact that /execfile is a
X% function defined in systemdict in X11/NeWS pre fcs, instead of being
X% a file defined in userdict by executive, as in earlier versions.
X% The problem is that "dbgstart" checks for /execfile in userdict to
X% tell if an executive has already been started, and if it's not (or
X% even if it is, in our case), it starts one. (and executive doesn't
X% return, so we've lost control!) (Supposedly a call to "executive"
X% occurs right before "_ReadyProcess" on the input stream.) So until
X% such a time as "dbgstart" knows how to tell an executive has already
X% been started, we must fool it...
X /execfile dup load def
X
X dbgstart
X
X 256 {
X rd % reap dead rebuggers
X dstack { eventloop } stopped {
X (\nI'm confused...\n) print
X pause pause
X ExecutiveErrorHandler
X pause pause
X } if
X (\nTry again...\n) print
X pause pause
X } repeat
X (\nGame over, man!\n) print
X } fork
X createevent begin
X /Name /ExecIt def
X /Process exch def
X currentdict
X end
X { currentfile dup null eq { clear exit } if
X token {
X 1 index createevent copy % ev1 ob ev2
X dup /ClientData 4 -1 roll % ev1 ev2 /CD obj
X [ exch ] cvx
X put % ev1 ev2
X sendevent
X } {
X clear exit
X } ifelse
X } loop
X} def
X
X/eventloop {
X { awaitevent } loop
X} def
X
X/dstack {
X currentprocess /DictionaryStack get
X dup length (dstack[%]: ) printf
X {
X smart-name print ( ) print
X } forall
X (\n) print
X} def
X
X/enter-eventloop {
X dstack eventloop
X} def
X
X% This does not exit when you type "exit"...(invalidexit error)
X/enter-executive {
X { dstack executive exit } loop
X} def
X
X/enter {
X currentprocess /Interests get length 0 eq
X /enter-executive /enter-eventloop ifelse
X exch send
X dstack
X} def
X
X% Debugger Aliases
X/dbe {dbgbreakenter} def
X/dbx {dbgbreakexit} def
X/dc {dbgcontinue} def
X/dcb {dbgcontinuebreak} def
X/dcc {dbgcopystack dbgcontinue} def
X/dcs {dbgcopystack} def
X/de {dbgenter} def
X/deb {dbgenterbreak} def
X/dgb {dbggetbreak} def
X/dk {dbgkill} def
X/dkb {dbgkillbreak} def
X/dlb {dbglistbreaks} def
X/dmp {dbgmodifyproc} def
X/dp {dbgpatch} def
X/dpe {dbgprintfenter} def
X/dpx {dbgprintfexit} def
X/dw {dbgwhere} def
X/dwb {dbgwherebreak} def
X/dx {dbgexit} def
X
X% Useful aliases
X/fb {framebuffer} def
X/ls {[currentdict {pop} forall] ==} def
X
XXNeWS? not { % XXX?
X /revokekbdinterests { % [ int1 int2 ... intn ] can => -
X removefocusinterest
X % aload pop revokeinterest revokeinterest revokeinterest
X {{revokeinterest} errored {pop} if} forall
X } store
X} if
X
X{
X /getmenuaction { % index => action
X dup null ne {
X MenuActions 1 index MenuActions length 1 sub min get
X % Execute actions that are names! (This is so we can have the executable
X % name of a submenu, or a functions to compute the menu action!)
X dup type /nametype eq { exec } if
X } {nullproc} ifelse
X exch pop
X } def
X} LiteMenu send
X
XXNeWS? {
X % ick!
X /Primary dup framebuffer /new ClassSelection send
X exch setselection
X} if
X
Xsystemdict /old-setselection known not {
X /old-setselection /setselection load def
X /setselection { % dict rank
X 2 copy old-setselection
X createevent begin
X /Name /SelectionChanged def
X /Action exch def
X /ClientData exch def
X currentdict end sendevent
X } def
X} if
X
X/select-object { % obj => -
X 20 dict begin
X /SelectionType /object def
X /ContentsPostScript 1 index def
X /ContentsAscii exch (%) sprintf def
X /SelectionObjSize 1 def
X /SelectionResponder null def
X /Canvas currentcanvas def % XXX?
X /SelectionHolder currentprocess def % XXX?
X currentdict
X end
X /PrimarySelection setselection
X} def
X
X/select-pointer { % obj index => -
X 20 dict begin
X /SelectionType /pointer def
X /SelectionStartIndex exch def
X /ContentsPostScript exch def
X /ContentsAscii
X /ContentsPostScript load
X /SelectionStartIndex load get
X (%) sprintf
X def
X /SelectionObjSize 1 def
X /SelectionResponder null def
X /Canvas currentcanvas def % XXX?
X /SelectionHolder currentprocess def % XXX?
X currentdict
X end
X /PrimarySelection setselection
X} def
X
X/select-interval { % obj start len => -
X 20 dict begin
X /SelectionType /interval def
X /SelectionObjSize exch def
X /SelectionStartIndex exch def
X /SelectionLastIndex
X SelectionStartIndex SelectionObjSize add 1 sub
X def
X /ContentsPostScript exch def
X /ContentsAscii
X /ContentsPostScript load
X SelectionStartIndex SelectionObjSize getinterval
X (%) sprintf
X def
X /SelectionResponder null def
X /Canvas currentcanvas def % XXX?
X /SelectionHolder currentprocess def % XXX?
X currentdict
X end
X /PrimarySelection setselection
X} def
X
X/dissect-selection { % seldict => obj
X dup selection-type {
X /empty {
X pop null % null
X }
X /unknown {
X % seldict
X }
X /text {
X /ContentsAscii get % string
X }
X /object {
X /ContentsPostScript get % obj
X }
X /pointer {
X dup /ContentsPostScript get % seldict container
X exch /SelectionStartIndex get % container index
X 1 index type /dicttype eq {
X 2 copy known
X } true ifelse {
X get % obj
X } {
X pop pop null % null
X } ifelse
X }
X /interval {
X dup /ContentsPostScript get % seldict container
X exch dup /SelectionStartIndex get % container seldict start
X exch /SelectionLastIndex get % container start last
X 1 index sub 1 add % container start len
X getinterval % obj
X }
X /Default {
X % seldict
X }
X } case
X} def
X
X/selection-type { % seldict => name
X dup null ne {
X dup /SelectionType known {
X dup /SelectionType get dup null ne exch /UnknownRequest ne and
X } false ifelse {
X /SelectionType get
X } {
X dup /ContentsAscii known {
X pop /text
X } {
X pop /unknown
X } ifelse
X } ifelse
X } {
X pop /empty
X } ifelse
X} def
X
X/interesting-keys [
X /SelectionType
X /ContentsAscii /ContentsPostScript
X /SelectionStartIndex /SelectionLastIndex
X] def
X
XXNeWS? {
X /request-selection { % rank => seldict
X 10 dict begin
X interesting-keys { null def } forall
X currentdict
X end
X exch selectionrequest
X } def
X} {
X /request-selection { % rank => seldict
X dup getselection dup null ne {
X exch pop
X } {
X pop
X 10 dict begin
X interesting-keys { null def } forall
X currentdict
X end
X exch selectionrequest
X } ifelse
X } def
X} ifelse
X/selected-object { % - => obj
X /PrimarySelection request-selection
X dissect-selection
X} def
X
X/selected-pointer? { % - => false / collection index true
X /PrimarySelection request-selection
X dup selection-type /pointer eq {
X dup /ContentsPostScript get exch /SelectionStartIndex get
X true
X 2 index type /dicttype eq {
X 3 copy pop known not { % invalid pointer
X pop pop pop false
X } if
X } if
X } {
X pop false
X } ifelse
X} def
X
X/selected-interval? { % - => false / collection start last true
X /PrimarySelection request-selection
X dup selection-type /interval eq {
X dup /ContentsPostScript get
X exch dup /SelectionStartIndex get
X exch /SelectionLastIndex get true
X } {
X pop false
X } ifelse
X} def
X
X/selected-pointer-or-interval? { % - => false / collection first last true
X /PrimarySelection request-selection dup selection-type {
X /interval {
X dup /ContentsPostScript get exch
X dup /SelectionStartIndex get exch
X /SelectionLastIndex get
X true
X }
X /pointer {
X dup /ContentsPostScript get exch
X /SelectionStartIndex get dup
X true
X 2 index type /dicttype eq {
X 3 copy pop known not { % invalid pointer
X pop pop pop false
X } if
X } if
X }
X /Default {
X pop false
X }
X } case
X} def
X
X% NeWS-print 0.996
X% Written by Josh Siegel
X% Munged by Don Hopkins
X
X/Externals 512 dict def
X/ExternalsBack 512 dict def
XExternals /Count 0 put
X
X/string-magic
X dictbegin
X (\b) 0 get (\\b) def
X (\f) 0 get (\\f) def
X (\n) 0 get (\\n) def
X (\r) 0 get (\\r) def
X (\t) 0 get (\\t) def
X (\() 0 get (\\\() def
X (\)) 0 get (\\\)) def
X (\\) 0 get (\\\\) def
X dictend
Xdef
X
X/fixstring {
X 10 dict
X begin
X /len 0 def
X /out 1 index length 3 mul string def
X {
X dup string-magic exch known {
X string-magic exch get
X } {
X cvis
X } ifelse
X out len 2 index putinterval
X /len exch length len add def
X } forall
X out 0 len getinterval dup length string copy
X end
X} def
X
X/stringer { % proc => string
X dup type cvlit
X {
X /arraytype {
X pause
X /arraylvl arraylvl 1 add store
X dup xcheck {
X /the_string the_string ( {\n) append store
X {
X stringer
X } forall
X /the_string the_string ( }\n) append store
X } {
X /the_string the_string ( [\n) append store
X {
X stringer
X } forall
X /the_string the_string ( ]\n) append store
X } ifelse
X /arraylvl arraylvl 1 sub store
X }
X /nametype {
X dup xcheck {
X the_string
X arraylvl 0 eq (% /% cvx ) (% %) ifelse
X sprintf
X /the_string exch store
X } {
X the_string (% /%) sprintf
X /the_string exch store
X } ifelse
X }
X /operatortype {
X 255 string cvs dup length 2 sub 1 exch getinterval
X the_string
X arraylvl 0 eq (% /% cvx ) (% %) ifelse
X sprintf
X /the_string exch store
X }
X /stringtype {
X fixstring
X the_string (% \(%\)) sprintf
X /the_string exch store
X }
X /marktype {
X (mark ) % [ DANGER! ]
X }
X /booleantype /integertype /realtype /nulltype {
X the_string (% %) sprintf
X /the_string exch store
X }
X /Default {
X dup type /dicttype ne dictlvl 0 ne or arraylvl 0 ne or {
X ExternalsBack 1 index known {
X ExternalsBack exch get % name
X } {
X Externals begin Count /Count Count 1 add def end % obj count
X 1 index type (&%_%) sprintf % obj name
X Externals 1 index 3 index put % obj name
X ExternalsBack 3 -1 roll 2 index put % name
X } ifelse
X the_string ( //) append exch append /the_string exch store
X } {
X /dictlvl dictlvl 1 add store
X /the_string the_string ( dictbegin\n) append store
X { pause
X /the_string the_string (\t) append store
X exch stringer stringer
X /the_string the_string ( def\n) append store
X } forall
X /the_string the_string ( dictend \n) append store
X /dictlvl dictlvl 1 sub store
X } ifelse
X } def
X } case
X} def
X
X/tokeout { % obj => string
X 10 dict
X begin
X /cnt Externals /Count get def
X /dictlvl 0 def
X /arraylvl 0 def
X /the_string () def
X stringer the_string
X cnt Externals /Count get ne {
X (Externals begin\n%\nend\n) sprintf
X } def
X end
X} def
X
X% Short readable names
X
X /ShortNameDict 40 dict def
X
X ShortNameDict begin
X /nametype {
X dup xcheck (%) (/%) ifelse
X sprintf
X } def
X /dicttype {
X dup maxlength exch length (<%/%>)
X sprintf
X } def
X /arraytype {
X dup length exch xcheck ({%}) ([%]) ifelse
X sprintf
X } def
X /packedarraytype /arraytype load def
X /stringtype {
X dup length 80 gt { 0 80 getinterval ((%)...) } ((%)) ifelse
X sprintf
X } def
X /marktype {
X pop (mark)
X } def
X /eventtype {
X dup /Name get short-name
X exch /IsInterest get
X (interest(%)) (event(%)) ifelse
X sprintf
X } def
X /canvastype {
X gsave
X dup setcanvas
X clippath pathbbox points2rect 4 2 roll pop pop exch % h w
X framebuffer setcanvas
X 3 -1 roll
X dup /Parent get null eq {
X pop (can(%,%)) sprintf
X } {
X getcanvaslocation exch
X (can(%,%,%,%)) sprintf
X } ifelse
X grestore
X } def
XXNeWS? {
X /processtype {
X dup /Execee get exch
X dup /State get exch
X dup /ProcessName known { /ProcessName get } (anonymous) ifelse
X (proc('%',%,%)) sprintf
X } def
X} { % not XNeWS?
X /processtype {
X% One or more of these is causing a core dump some of the time... (NeWS 1.1)
X% dup /Interests get length exch
X% dup /ExecutionStack get length exch % CORE DUMP
X% dup /DictionaryStack get length exch
X% dup /OperandStack get length exch
X% dup /Execee get exch
X% /State get
X% (proc(%,%,o%,d%,e%,i%)) sprintf
X dup /Execee get exch
X /State get
X (proc(%,%)) sprintf
X } def
X} ifelse % XNeWS?
X end % ShortNameDict
X
X /short-name {
X dup type ShortNameDict 1 index known {
X ShortNameDict exch get exec
X } {
X pop 80 string cvs
X } ifelse
X } def
X
X /smart-name {
X dup smart-type ( ) append exch short-name append
X } def
X
X /SmartTypeDict 40 dict def
X
X SmartTypeDict begin
X
X /dicttype {
X dup systemdict eq {
X pop (systemdict)
X } {
X % TODO: Detect the process's userdict ...
X magic-type
X } ifelse
X } def
X
X /canvastype {
X% dup framebuffer eq {
X% pop (framebuffer)
X% } {
X% magic-type
X% } ifelse
X magic-type
X } def
X
X /eventtype {
X magic-type
X } def
X
X /processtype {
X magic-type
X } def
X
X /fonttype {
X magic-type
X } def
X
X /integertype {
X dup floor sub 0 eq
X (integer) (real) ifelse
X } def
X
X end % SmartTypeDict
X
X /smart-type { % obj => str
X dup truetype % obj type
X SmartTypeDict 1 index known {
X SmartTypeDict exch get exec % str
X } { % obj type
X pop short-type % str
X } ifelse
X } def
X
X /magic-type {
X dup /ParentDictArray known
X { dup /ParentDictArray get type /nametype ne } % Detect bogus classes!
X false ifelse {
X dup /ClassName known { % class
X /ClassName get 64 string cvs
X } { % instance
X % ugly ugly!
X /ClassName exch send
X 64 string cvs (.) exch append
X } ifelse
X } {
X short-type
X } ifelse
X } def
X
X /short-type { % obj => str
X truetype 20 string cvs
X 0 1 index length 4 sub getinterval
X } def
X
Xsystemdict /quicksort known not {
X
X%
X% quicksort by Don Woods at Sun Microsystems, Inc.
X%
X/quicksort { % array proc => array (sorted, reuses same storage)
X10 dict begin
X /Bigger? exch cvx def % a b bigger? => t if a<b
X dup quickrecur % start recursion
Xend
X} def % quicksort
X
X/quickrecur { % array => -- sorts array in place, using Bigger? for comparisons
X dup length dup 2 gt { % A N
X % the next lines (until but not incl /Key...) subsort three elements
X % so we can use the median as the partitioning element; this improves
X % performance for the case where the array is initially nearly sorted,
X % but is not strictly necessary for the algorithm to work (it does
X % seem to improve average runtime by about 10%)
X 2 copy 1 sub 2 copy 2 idiv 1 index 0 % A N A N-1 A (N-1)/2 A 0
X 6 copy get 5 1 roll get 3 1 roll get % above & A[N-1] A[(N-1)/2] A[0]
X 2 copy Bigger? {exch} if % subsort for three elements
X 3 1 roll 2 copy Bigger? {exch} if % ... (call them min mid max)
X 3 -1 roll 2 copy Bigger? {exch} if % ... subsort finished
X 9 index % A N A N-1 A (N-1)/2 A 0 min mid max N
X 3 eq {
X 5 2 roll put 4 1 roll put put % store min/mid/max back
X pop pop % pop A & N
X } { % else store mid at 0, max at N-1, min at (N-1)/2, then partition
X 3 -1 roll 5 2 roll put exch 4 1 roll put put % A N
X /Key 2 index 0 get def % partitioning value
X 0 % A N 0, also known as A j i
X { % main partitioning loop
X % incr i until i=j or A[i]>=A[0]; note A[j] is rangecheck
X { 1 add 2 copy gt { % i++; A j i j>i?
X dup 3 index exch get % A j i A[i]
X Key exch Bigger? not {exit} if
X } {exit} ifelse
X } loop
X % decr j until A[j]<=A[0]; happens at j=i-1 if not sooner
X exch { % A i j
X 1 sub dup 3 index exch get % A i j A[j]
X Key Bigger? not {exit} if
X } loop
X 2 copy gt {exit} if % if i>=j, finished partition
X % swap A[j] & A[i]; stack has: A i j
X 2 index 4 copy exch get % A i j A A i A[j]
X 4 1 roll get % A i j A[j] A A[i]
X 3 index exch put % A i j A[j]
X 4 copy exch pop put pop exch % A j i
X } loop
X % finish partition by exchanging A[j] with A[0]; stack has: A i j
X exch pop 2 copy 4 copy get % A j A j A j A[j]
X exch pop 0 exch put Key put % A j
X % now recur on A[0..j-1] and A[j+1..N-1]
X 2 copy 1 add 1 index length 1 index sub % A j A j+1 N-1
X getinterval 3 1 roll 0 exch getinterval % A[j+1..N-1] A[0..j-1]
X 2 copy length exch length gt {exch} if % put smaller on top
X quickrecur quickrecur % tail recursion avoids deep stack
X } ifelse % =3 or >3 elements
X } { % handle 1- and 2-element cases specially for efficiency
X 2 eq {
X dup aload pop Bigger? {aload 3 1 roll exch 3 -1 roll astore} if
X } if
X pop % pop the array
X } ifelse
X} def % quickrecur
X
X% end of quicksort
X
X} if % quicksort not known
X
X% This function in systemdict makes sure ClassName is always in a
X% dictionary on the dict stack. Objects all have their own class
X% name. This function provides names for /systemdict and /userdict.
X% It returns the dictionary itself for other dictionaries.
X%
X% The use of this is a little bad and hacky because /ClassName is used
X% as a method for any object (including classes themselves), even though
X% it is not an advertised method in class Object.
X%
X/ClassName { % - => name | dict
X currentdict
X dup userdict eq {pop /userdict} if
X dup systemdict eq {pop /systemdict} if
X} ?def
X
Xend % systemdict
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Userdict Utilities
X
X/shift-names 10 dict def
Xshift-names begin
X /Meta false def
X /Shift false def
X /Control false def
Xend % shift-names
X
X/update-shifts {
X shift-names {store} forall
X /KeyState get {
X shift-names 1 index known { true store } { pop } ifelse
X } forall
X} def
X
X/key-names 40 dict def
Xkey-names begin
X 8 (Backspace) def
X 9 (Tab) def
X 10 (Newline) def
X 13 (Return) def
X 27 (Escape) def
X 32 (Space) def
X 127 (Delete) def
Xend % key-names
X
X/key-name { % key => string
X dup type /integertype eq {
X dup 127 and
X key-names 1 index known {
X key-names exch get
X } {
X dup 32 lt {
X 64 add cvis (^%) sprintf
X } {
X cvis
X } ifelse
X } ifelse
X exch 128 ge {
X (Meta-%) sprintf
X } if
X } {
X (%) sprintf
X } ifelse
X} def
X
X/comment-string { % obj => string
X dup array? {
X dup length 2 ge {
X dup 1 get /comment eq {
X 0 get
X } if
X } if
X } if
X (%) sprintf
X} def
X
X/destroy { % dummy destroy method for items
X} def
X
X% Forward messages on to stack
X/prompt {
X {} execute-it
X} def
X
X/execute-it {
X /execute-it dialog-item send
X} def
X
X/exec-it {
X /exec-it dialog-item send
X} def
X
X/push-it {
X /push-it dialog-item send
X} def
X
X/kbd-select-object {
X gsave
X can setcanvas
X select-object
X grestore
X} def
X
X/kbd-select-pointer {
X gsave
X can setcanvas
X select-pointer
X grestore
X} def
X
X/kbd-select-interval {
X gsave
X can setcanvas
X select-interval
X grestore
X} def
X
X% This is here because the scanner doesn't believe that \r's end comments!
X/remove-returns { % str => str'
X dup (\r) search not { pop } { % str rest \r pre
X length 1 add exch pop % str rest len
X 3 -1 roll dup length string copy % rest len str'
X 3 1 roll { % str' rest len
X 2 index 1 index 1 sub 10 put
X exch (\r) search { % str' len rest \r pre
X length 1 add exch pop % str' len rest len
X 3 -1 roll add % str' rest len
X } { % str' len rest
X pop pop exit
X } ifelse
X } loop
X } ifelse
X} def
X
X% Quantize the font size to a multiple of .5 so we don't blow up the
X% font cache. (This is mainly for X11/NeWS.)
X/scalefontquant { % font size => font
X 2 mul round 2 div scalefont
X} def
X
X% Stolen from:
X% stickem version 1.0
X% Written by Josh Siegel (Wed Jun 29 1988)
X
XXNeWS? {
X
X /find_canvas { % x y => [canvases]
X canvasesunderpoint
X } def
X
X} { % NeWS 1.1
X
X % getxyloc returns the position of the next left-button
X % mouse up event. It passes all other events.
X
X /getxyloc { % => x y
X gsave % ???
X framebuffer setcanvas % ???
X 10 dict
X begin
X createevent
X dup /Priority 20 put
X dup /Name /LeftMouseButton put
X dup /Action /UpTransition put
X /foobar exch def
X foobar expressinterest
X {
X awaitevent
X dup /Name get /LeftMouseButton eq {
X exit
X } if
X redistributeevent
X } loop
X foobar revokeinterest
X dup /XLocation get
X exch /YLocation get
X end
X grestore % ???
X } def
X
X % find_tree traverses the canvas tree passed to it and calls
X % check_canvas to check to see if the point is in the
X % canvas. It is also a example of a recursive NeWS routine.
X
X /find_tree { % canvas => found?
X dup null eq {
X pop false
X } {
X dup /Mapped get {
X dup check_canvas {
X dup [ exch ] answer exch append /answer exch def
X /TopChild get
X { dup null eq {
X pop true exit
X } if
X dup find_tree { pop true exit } if
X /CanvasBelow get
X } loop
X } {
X pop false
X } ifelse
X } {
X pop false
X } ifelse
X } ifelse
X } def
X
X % Check canvas checks to see if the point is inside of the
X % clipping path of the canvas. This is VERY important for things
X % like the clock where the clipping path is round.
X %
X
X /check_canvas { % canvas => boolean
X framebuffer setcanvas % ???
X dup getcanvaslocation % can xwin ywin
X ypnt exch sub % can xwin ypnt-ywin
X exch xpnt exch sub exch % can xpnt-xwin ypnt-ywin
X 3 -1 roll setcanvas clipcanvaspath pointinpath % boolean
X framebuffer setcanvas
X } def
X
X % find_canvas is a convient front end to the whole system.
X % I use a local dictionary to help in garbage collected in case
X % this routine is later used as part of a larger piece of code.
X
X /find_canvas { % x y => [canvas]
X gsave % ???
X framebuffer setcanvas % ???
X 10 dict
X begin
X /answer [ ] def
X /ypnt exch def
X /xpnt exch def
X framebuffer find_tree
X answer
X end
X grestore % ???
X } def
X
X} ifelse
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% CyberMenu class definition
X
X/CyberMenu
X systemdict /SoftMenu known { SoftMenu } { PieMenu } ifelse
Xdef
X
X/PulloutCyberMenu
X PulloutPieMenu
Xdef
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% NeWSScrollBar item definition
X
Xsystemdict begin % this is for textcan.ps
X
X/NeWSScrollbar SimpleScrollbar []
Xclassbegin
X /setbgcolor { % color - => -
X /BoxFillColor exch def
X /ButtonFillColor BoxFillColor def
X } def
Xclassend def
X
Xend % systemdict
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% StructItem class definition
X
X% This huge blob implements the data doo-dads.
X% It just kept getting bigger and bigger, before I realized what
X% was happening. This class should be factored out into several
X% classes... (I'll probably just reimplement it in NDE from
X% scratch.)
X
X/StructItem LabeledItem
Xdictbegin
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Instance variables
X
X /Shrink .9 def
X /Pad 3 def
X /Point null def
X /x 0 def
X /y 0 def
X /Levels 0 def
X /DL null def
X /ItemFrame 2 def
X /ItemRadius 5 def
X /ItemBorder 6 def
X /ItemButton [PointButton AdjustButton MenuButton] def
X /StackI null def
X /LayoutLock null def
X /LastX 0 def
X /LastY 0 def
X /LastTime 0 def
X /Clicks 1 def
X /TrackProc null def
X /DX 0 def /DY 0 def
X /TabX 0 def
X /TabY 0 def
X /TabWidth 0 def
X /TabHeight 0 def
X /PinX 0 def
X /StartIndex 0 def
X /LastIndex 0 def
X /OldIndex 0 def
X /MySiblings null def
X /layout-proc /layout-struct def
X /click-proc /click-transfer def
X /transfer-proc /paste-obj def
X /display-proc /display-tree-struct def
X /erase-proc /erase-label def
X /label-proc /object-label def
X /lw null def
X /lh null def
X /lx null def
X /ly null def
X /BigWidth 64 def
X /BigHeight 64 def
X /Filter? false def
X /OpenToRight? false def
X /ShowFan? true def
Xdictend
Xclassbegin
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Class variables
X
X /StartPoint 18 def
X /DoubleClickTime 2 60 div def
X /DoubleClickDistanceSquared 8 dup mul def
X /CanvasYFudge 2 store
X /Sort? true def
X /SubStructureIndent 10 def
X /LineGap 30 def
X /Icon? false def
X /SortBy /by-name def
X /ItemLabelFont /Helvetica-Bold findfont 14 scalefontquant def
XXNeWS? { % How about something sexy...
X% /ItemFont /AvantGarde-Book findfont def % Normal font
X% /ItemXFont /AvantGarde-BookOblique findfont def % Executable font
X% /ItemSFont /AvantGarde-Book findfont def % Small font
X% /ItemFont /GillSans findfont def % Normal font
X% /ItemXFont /GillSans-Italic findfont def % Executable font
X% /ItemSFont /GillSans findfont def % Small font
X /ItemFont /LucidaSans findfont def % Normal font
X /ItemXFont /LucidaSans-Italic findfont def % Executable font
X /ItemSFont /LucidaSans findfont def % Small font
X /SmallPointSize 7 def % Use small font when smaller than this.
X} { % NeWS 1.1
X /ItemFont /Courier-Bold findfont def % Normal font
X /ItemXFont /Courier-BoldOblique findfont def % Executable font
X /ItemSFont /Courier findfont def % Small font
X /SmallPointSize 10 def % Use small font when smaller than this.
X} ifelse
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Initialization stuff
X
X /new { % Collection Index notifyproc parentcanvas => instance
X 4 2 roll 2 copy get type (% \267) sprintf % notify parent cont ind label
X 5 1 roll 2 array astore % label notify parent object
X 3 1 roll /Right % label object notify parent loc
X 3 1 roll % label object loc notify parent
X /new super send begin
X ItemCanvas /Transparent false put
X% ItemCanvas /Transparent true put
X ItemCanvas /Retained true put
X /LayoutLock createmonitor def
X /xhair /xhair_m ItemCanvas setstandardcursor
X currentdict end
X } def
X
X /ensure-DL {
X DL null eq {
X Collection Index Levels grow-struct
X /DL exch store
X /ObjectWidth 0 store
X } if
X ObjectWidth 0 eq ObjectHeight 0 eq or {
X perform-layout
X } if
X } def
X
X /makestartinterests {
X /makestartinterests super send
X [ exch aload pop
X /DoTransfer {/DoTransfer /Self GetFromCurrentEvent send}
X null ItemCanvas eventmgrinterest
X dup /Exclusivity true put
X dup /Self self PutInEventMgrInterest
X ]
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Event handlers
X
X /DoTransfer { % event => -
X ItemBegin
X /it self store
X CurrentEvent update-shifts
X do-search
X ob null eq {
X % pththth
X } {
X % Are we transfering something to where it already is?
X CurrentEvent /ClientData get ob eq {
X % Transfering an object into itsself toggles its opened/closed state
X click-open
X } {
X % Beam me up, Scotty!
X ob begin /transfer-proc load end
X cvx { exec } fork pop pop
X } ifelse
X } ifelse
X ItemEnd
X pop % XXX?
X } def
X
X /ClientDown {
X ItemBegin
X /it self store
X currenttime LastTime sub DoubleClickTime lt
X CurrentEvent begin
X LastX XLocation sub dup mul LastY YLocation sub dup mul add
X /LastX XLocation store /LastY YLocation store
X end
X DoubleClickDistanceSquared lt
X and {
X /Clicks Clicks 1 add store
X } {
X /Clicks 1 store
X } ifelse
X /LastTime currenttime store
X CurrentEvent update-shifts
X CurrentEvent /Name get MenuButton eq {
X event-in-tab? {
X show-tab-menu
X } {
X show-struct-menu
X } ifelse
X } {
X CurrentEvent /Name get PointButton eq {
X% CurrentEvent recallevent
X event-in-tab? {
X items FillColor self slideitem
X } {
X do-search
X ob null eq {
X items FillColor self slideitem
X } {
X Clicks 1 eq {
X make-selection
X } {
X TrackProc null ne { TrackProc killprocess } if
X click-exec
X } ifelse
X } ifelse
X } ifelse
X } {
X CurrentEvent /Name get AdjustButton eq {
X event-in-tab? {
X toggle-icon
X } {
X do-search
X ob null eq {
X } {
X NotifyUser
X } ifelse
X } ifelse
X } if
X } ifelse
X } ifelse
X ItemEnd
X } def
X
X /make-selection {
X TrackProc null ne { TrackProc killprocess } if
X 2 60 div blockinputqueue
X /TrackProc {
X unblockinputqueue
X /OldIndex null store
X obs length 1 le {
X /MySiblings [ob] store
X /TipX null def /TipY null def
X /Multiple? false def
X } {
X obs dup length 2 sub get
X /MySiblings
X 1 index /Branches get dup null eq { pop nullarray } if
X 2 index /Controls get dup null eq { pop } { append } ifelse
X store
X /Pointers? false def
X /TipX 1 index /TipX get def
X /TipY exch /TipY get def
X /Multiple?
X ob /C get array-or-string?
X Shift and
X def
X } ifelse
X /StartIndex
X 0 MySiblings {
X /I get ob /I get eq { exit } if
X 1 add
X } forall
X store
X /LastIndex StartIndex store
X ItemCanvas createoverlay setcanvas
X ObjectX ObjectY ObjectHeight add translate
X currentcursorlocation
X { newpath pop pop
X /LastIndex
X 0 MySiblings {
X /Y get y le {
X exit
X } if
X 1 add
X } forall
X MySiblings length 1 sub min
X store
X Multiple? not {
X /StartIndex LastIndex store
X } if
X TipX null ne {
X% TipX TipY moveto
X TipX 1 add TipY moveto
X MySiblings StartIndex LastIndex min get begin
X% X Y H add lineto
X X Y H add 1 sub lineto
X end
X MySiblings StartIndex LastIndex max get begin
X% X Y lineto
X X Y 1 add lineto
X end
X closepath
X fill
X } if
X MySiblings StartIndex LastIndex min get begin
X X 1 sub Y H add moveto
X end
X StartIndex LastIndex min 1 StartIndex LastIndex max {
X MySiblings exch get begin
X X W add dup Y H add lineto
X Y lineto
X end
X } for
X MySiblings StartIndex LastIndex max get begin
X X 1 sub Y lineto
X end
X closepath
X Shift { stroke } { fill } ifelse
X
X OldIndex LastIndex ne {
X /OldIndex LastIndex store
X Multiple? {
X % Don't select part of control panel
X MySiblings StartIndex get /C get
X MySiblings LastIndex get /C get eq {
X MySiblings StartIndex get /C get
X StartIndex LastIndex 2 copy gt {exch} if
X MySiblings exch get /I get exch
X MySiblings exch get /I get exch
X 1 index sub 1 add
X kbd-select-interval
X } if
X } {
X MySiblings LastIndex get
X Shift { % Shift to select array index
X /I get kbd-select-object
X } {
X dup /C get exch /I get kbd-select-pointer
X } ifelse
X } ifelse
X } if
X
X } getanimated waitprocess
X /MySiblings null store
X /TrackProc null store
X } fork store
X } def
X
X /show-tab-menu {
X userdict /it self put
X CurrentEvent /showat TabMenu send
X } def
X
X /show-struct-menu {
X ItemBegin
X do-search
X ob null eq { /ob DL store } if
X ob null ne {
X CurrentEvent /showat StructMenu send
X } if
X ItemEnd
X } def
X
X /ClientUp {
X StopItem
X } def
X
X /click-exec {
X Shift { click-step } {
X ob /Obj get exec-it
X } ifelse
X } def
X
X /click-transfer {
X 2 60 div blockinputqueue
X {
X unblockinputqueue
X % (Aaah, that feels much better -- thanks Stan!)
X gsave 10 dict begin
X Shift { % Shift to select the index
X ob /I get
X } {
X ob /Obj get
X } ifelse
X /thing exch def
X /thing load kbd-select-object
X /str /thing load smart-name def
X ItemLabelFont setfont
X fboverlay setcanvas
X currentcursorlocation
X { lineto str show } getanimated waitprocess aload pop % x y
X createevent begin
X /Name /DoTransfer def
X /YLocation exch def /XLocation exch def
X /Action 1 dict def
X Action begin
X /Source /thing load def
X end
X % We're sneaking this in so DoTransfer can tell if we're transfering
X % something to where it already is, in which case we just do a
X % click-open, to open or close the object's internal structure.
X /ClientData ob def
X currentdict sendevent
X end
X grestore
X } fork pop
X } def
X
X /click-magic {
X % Invoke magic editing function...
X obs length 1 gt {
X { ob /C get dup array-or-string? { pop currentdict } if
X begin
X ob /Obj get
X use-parent-obj
X cvx exec
X end
X } fork pop pause
X } if
X } def
X
X /click-edit {
X % Invoke magic editing function...
X obs length 1 gt {
X { ob /C get dup array-or-string? { pop currentdict } if
X begin
X ob /Obj get cvx change-parent-obj
X end
X } fork pop pause
X } if
X } def
X
X /click-push {
X push-obj
X } def
X
X /old-click-step {
X [ ob /Obj get ] cvx exec-it
X } def
X
X /click-step {
X gsave
X ItemCanvas createoverlay setcanvas
X ObjectX ObjectY ObjectHeight add translate
X ob dup begin
X X Y W H rectpath
X end
X [ exch /Obj get
X /gsave load % Whip me beat me make me check bad writes!
X currentstate /setstate load /erasepage load
X /grestore load
X ] cvx fill exec-it
X
X obs length 1 le {
X /MySiblings [ob] store
X }{
X obs dup length 2 sub get
X /MySiblings
X 1 index /Branches get dup null eq { pop nullarray } if
X store
X } ifelse
X /StartIndex
X 0 MySiblings {
X /I get ob /I get eq { exit } if
X 1 add
X } forall
X store
X /LastIndex StartIndex store
X currentcursorlocation
X { newpath pop pop
X /LastIndex
X 0 MySiblings {
X /Y get y le {
X exit
X } if
X 1 add
X } forall
X MySiblings length 1 sub min
X store
X { StartIndex LastIndex ge { exit } if
X /StartIndex StartIndex 1 add store
X
X MySiblings StartIndex get dup begin
X newpath X Y W H rectpath
X end
X [ exch /Obj get
X /gsave load % Whip me beat me make me check bad writes!
X currentstate /setstate load /erasepage load
X /grestore load
X ] cvx fill exec-it
X } loop
X } getanimated waitprocess
X /MySiblings null store
X grestore
X } def
X
X /click-type-dict 100 dict def
X click-type-dict begin
X /integertype {
X Shift 1 -1 ifelse add
X } def
X /realtype {
X Shift -1 1 ifelse add
X } def
X /booleantype {
X not
X } def
X end % click-type-dict
X
X /click-type {
X ob /Obj get dup type
X click-type-dict 1 index known {
X click-type-dict exch get
X cvx exec
X replace-obj
X } {
X pop pop %%% /click-proc load cvx exec
X } ifelse
X } def
X
X /click-dragcanvas {
X { ob /C get ob /I get get
X dup /Parent get null eq { pop } {
X gsave
X setcanvas false dragcanvas
X grestore
X obs { begin } forall
X ItemTextColor setcolor
X ObjectX ObjectY ObjectHeight add translate
X currentdict end draw-struct
X obs length 1 sub { end } repeat
X } ifelse
X } fork pop
X } def
X
X /click-dragimage {
X { ob /C get ob /I get get % % can
X gsave
X dup createoverlay setcanvas
X ob /C get % EditorDict
X begin % EditorDict
X currentcursorlocation
X { 2 copy
X y0 sub ViewY exch sub /ViewY exch store
X x0 sub ViewX exch sub /ViewX exch store
X /y0 exch store /x0 x store
X ViewX ViewY ViewWidth ViewHeight rectpath
X } getanimated waitprocess pop
X end % EditorDict
X obs { begin } forall
X ItemCanvas setcanvas
X ItemTextColor setcolor
X ObjectX ObjectY ObjectHeight add translate
X currentdict end draw-struct
X obs length 1 sub { end } repeat
X grestore
X } fork pop
X } def
X
X /handle-click { % - => -
X ob null ne {
X% obs /begin load forall
X ob begin
X /click-proc load
X end % ob
X% obs length /end load repeat
X cvx exec
X } if
X% pop % ??? the notifyproc should not pop the event
X } def
X
X /open-icon {
X Icon? {
X /ObjectWidth OW store
X /ObjectHeight OH store
X currentdict /Icon? undef
X redo-shape
X } if
X } def
X
X /close-icon {
X Icon? not {
X gsave
X /OW ObjectWidth def
X /OH ObjectHeight def
X Font setfont Str stringbbox points2rect
X /IconH exch def /IconW exch def
X pop pop
X /ObjectWidth IconW store
X /ObjectHeight IconH store
X grestore
X /Icon? true def
X redo-shape
X } if
X } def
X
X /toggle-icon {
X DL begin
X Icon? { open-icon } { close-icon } ifelse
X end
X /LastTime 0 store
X } def
X
X /click-select {
X Clicks 1 eq {
X % first click
X ob null ne {
X Shift { % Shift to select the index
X ob /I get
X } {
X ob /Obj get
X } ifelse
X Control {
X exec-it
X /LastTime 0 store
X } {
X kbd-select-object
X } ifelse
X } if
X } {
X click-open
X } ifelse
X } def
X
X /click-open {
X ob null ne {
X DL begin Icon? end {
X toggle-icon
X } {
X Shift {
X ob /L get 1 add open-struct
X } {
X ob /L get 0 eq {
X 1 open-struct
X } {
X close-struct
X } ifelse
X } ifelse
X } ifelse
X } if
X } def
X
X /event-in-tab? {
X ItemBegin
X newpath label-bbox rectpath
X CurrentEvent begin XLocation YLocation end pointinpath
X ItemEnd
X } def
X
X /ClientExit {
X StopItem
X } def
X
X /Silent? { % - => bool
X Meta Control Shift or and
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Menu callbacks
X
X /push-array-obj {
X ob /Obj get % [stack]
X selected-object % [stack] top
X 1 index type /stringtype eq 1 index type /integertype ne and {
X pop pop
X } {
X 1 index type /stringtype eq {
X cvis
X } {
X [ exch ]
X } ifelse % [stack] [top]
X 1 index exch append % [stack] [stack top]
X exch xcheck { cvx } if
X replace-obj
X } ifelse
X } def
X
X /pop-array-obj {
X ob /Obj get
X dup length 0 eq { pop } {
X dup dup length 1 sub get kbd-select-object
X 0 1 index length 1 sub getinterval
X replace-obj
X } ifelse
X } def
X
X /prepend-to-array-obj {
X selected-object dup array-or-string? not { pop } { % [sel]
X ob /Obj get % [sel] {obj}
X dup type /stringtype eq % [sel] {obj} objstring?
X 1 index type /stringtype eq xor { % [sel] {obj}
X % incompatible types
X pop pop %
X } { % [sel] {obj}
X exch 1 index % {obj} [sel] {obj}
X append % {obj} [sel obj]
X exch xcheck { cvx } if % {sel obj}
X replace-obj %
X } ifelse
X } ifelse
X } def
X
X /append-to-array-obj {
X selected-object dup array-or-string? not { pop } { % [sel]
X ob /Obj get % [sel] {obj}
X dup type /stringtype eq % [sel] {obj} objstring?
X 1 index type /stringtype eq xor { % [sel] {obj}
X % incompatible types
X pop pop %
X } { % [sel] {obj}
X dup 3 -1 roll % {obj} {obj} [sel]
X append % {obj} [obj sel]
X exch xcheck { cvx } if % {obj sel}
X replace-obj %
X } ifelse
X } ifelse
X } def
X
X /top-array-obj {
X selected-pointer-or-interval? { % collection start last
X 2 index ob /Obj get ne {
X pop pop pop
X % error: first select part of this array
X } {
X 10 dict begin
X /Last exch def /Start exch def /Len exch length def
X [ ob /Obj get {} forall
X Len Start neg roll
X Start Len Last sub 1 sub add Start roll
X ] ob /Obj get
X dup type /stringtype eq { % [65 66 67] (abc)
X exch 0 exch { % (abc) 0 65
X 3 copy put pop 1 add
X } forall
X pop pop
X } {
X copy pop
X } ifelse
X end
X ob /Obj get replace-obj
X } ifelse
X } if
X } def
X
X /bottom-array-obj {
X selected-pointer-or-interval? { % collection start last
X 2 index ob /Obj get ne {
X pop pop pop
X % error: first select a part of this array
X } {
X 10 dict begin
X /Last exch def /Start exch def /Len exch length def
X [ ob /Obj get {} forall
X Len Start sub
X Len Last sub 1 sub roll
X ] ob /Obj get
X dup type /stringtype eq { % [65 66 67] (abc)
X exch 0 exch { % (abc) 0 65
X 3 copy put pop 1 add
X } forall
X pop pop
X } {
X copy pop
X } ifelse
X end
X ob /Obj get replace-obj
X } ifelse
X } if
X } def
X
X /delete-array-obj {
X selected-pointer-or-interval? { % collection start last
X 2 index ob /Obj get ne {
X pop pop pop
X % error: first select a part of this array
X } {
X 10 dict begin
X /Last exch def /Start exch def /Cont exch cvlit def
X /Len Cont length def
X Cont 0 Start getinterval cvlit
X Cont Last 1 add Len Last 1 add sub getinterval cvlit
X append
X% [ ob /Obj get aload pop
X% Len Start sub
X% Len Last sub 1 sub roll
X% Last Start sub 1 add {pop} repeat
X% ]
X end
X ob /Obj get xcheck {cvx} if
X replace-obj
X } ifelse
X } if
X } def
X
X /splice-array-obj {
X selected-interval? { % collection start last
X 2 copy get dup array? {
X 2 index ob /Obj get eq {
X 10 dict begin
X /Last exch def /Start exch def /Len exch length def
X [ ob /Obj get 0 Start getinterval aload pop
X ob /Obj get Start Last Start sub 1 add getinterval
X ob /Obj get xcheck {cvx} if
X ob /Obj get Last 1 add Len Last sub 1 sub getinterval aload pop
X ]
X end
X ob /Obj get xcheck {cvx} if
X replace-obj
X } {
X pop pop pop
X % error: select an array or an interval of this array
X } ifelse
X } {
X pop pop pop
X % error: can't do that to strings!
X } ifelse
X } {
X selected-pointer? { % collection index
X 2 copy get dup array? { % collection index array
X 2 index ob /Obj get eq {
X 10 dict begin
X /Arr exch cvlit def /Start exch def /Len exch length def
X [ ob /Obj get 0 Start getinterval aload pop
X Arr aload pop
X ob /Obj get Start 1 add Len Start sub 1 sub
X getinterval aload pop
X ]
X end
X ob /Obj get xcheck {cvx} if
X replace-obj
X } {
X pop pop pop
X % error: select an array or an interval of this array
X } ifelse
X } {
X pop pop pop
X % error: select an array or an interval of this array
X } ifelse
X } if
X } ifelse
X } def
X
X /def-in-dict-obj {
X selected-pointer? { % collection index
X exch 1 index get % index obj
X true
X } {
X selected-object dup null eq { pop false } { % index
X dup type /stringtype eq { cvn } if
X null % index object
X true
X } ifelse
X } ifelse
X { % index obj
X ob /Obj get 3 copy pop put % index obj
X pop ob /Obj get exch % dict index
X ob /Branches get null eq { pop pop } { % dict index
X 0 grow-struct % DL
X ob begin
X /Branches [ % DL mark
X Branches { % DL mark branch
X dup /I get
X counttomark 2 add index /I get
X eq {pop} if
X } forall
X counttomark 3 add -1 roll % mark branches... DL
X ] Sort? {SortBy quicksort} if def %
X end
X } ifelse %
X redo-layout
X } if
X } def
X
X /undef-in-dict-obj {
X selected-pointer? { % collection index
X exch pop ob /Obj get exch % dict index
X true
X } {
X selected-object null eq { pop false } {
X ob /Obj get exch % dict index
X dup type /stringtype eq { cvn } if % XXX: NeWS BUG in undef!! (Marja)
X true
X } ifelse
X } ifelse
X { % dict index
X ob /Obj get 1 index known not { pop } { % index
X ob /Obj get exch % dict index
X 2 copy get kbd-select-object
X undef %
X ob begin
X Branches null ne {
X /Branches [
X Branches {
X begin /C load /I load known { currentdict } if end
X } forall
X ] def
X } if
X end
X redo-layout
X } ifelse %
X } if
X } def
X
X /break-obj {
X { clear
X ob /Obj get dup type /dicttype eq {
X dup /ParentDict known {
X { { ClassName dbgbreak } exch send }
X } {
X { countdictstack 1 sub { end } repeat
X dup begin currentdict 30 string cvs cvn dbgbreak }
X } ifelse
X } {
X { dup type dbgbreak }
X } ifelse
X { exec } fork pop pop
X } fork pop
X } def
X
X /begin-obj {
X ob /Obj get begin-it
X } def
X
X /enter-obj {
X ob /Obj get enter-it
X } def
X
X /change-obj { % func => -
X { { count 1 roll
X count 1 sub { pop } repeat
X ob /Obj get exch exec } errored pop
X } fork
X exch pop waitprocess
X modify-obj
X } def
X
X % Execute token with Externals on the dict stack, so externalized
X % //&type_123 object references are resolved.
X /tokein-obj {
X ob /Obj get type /stringtype eq {
X { clear Externals begin
X ob /Obj get remove-returns
X { { token { exch } { exit } ifelse
X } loop
X } errored {
X clear ob /Obj get
X } {
X count array astore cvx
X } ifelse
X end
X } fork waitprocess
X kbd-select-object
X } if
X } def
X
X /cvx-obj {
X { ob /Obj get cvx } errored {pop} {
X% replace-obj
X kbd-select-object
X } ifelse
X } def
X
X /cvn-obj {
X { ob /Obj get cvn } errored {pop} {
X% replace-obj
X kbd-select-object
X } ifelse
X } def
X
X /cvs-obj {
X { ob /Obj get 256 string cvs } errored {pop} {
X% replace-obj
X kbd-select-object
X } ifelse
X } def
X
X /tokeout-obj {
X ob /Obj get tokeout
X kbd-select-object
X } def
X
X /cvlit-obj {
X { ob /Obj get cvlit } errored {pop} {
X% replace-obj
X kbd-select-object
X } ifelse
X } def
X
X /cvi-obj {
X { ob /Obj get cvi } errored {pop} {
X% replace-obj
X kbd-select-object
X } ifelse
X } def
X
X /cvr-obj {
X { ob /Obj get cvr } errored {pop} {
X% replace-obj
X kbd-select-object
X } ifelse
X } def
X
X /load&push-obj {
X ob /Obj get load&push-it
X } def
X
X /load&push-it { %
X [ exch cvlit {dup load} /errored cvx
X { pop smart-name (%% ) (%Load: % is not defined!\n) printf }
X { exch smart-name 1 index smart-name exch
X (%% ) (%Load: % Push: %\n) printf }
X /ifelse cvx ] cvx
X execute-it
X } def
X
X /load-obj {
X ob Shift /I /Obj ifelse get load-it
X } def
X
X /load-it { %
X [ exch cvlit {dup load} /errored cvx
X { pop smart-name (%% ) (%Load: % is not defined!\n) printf }
X { exch smart-name 1 index smart-name exch
X (%% ) (%Load: % Select: %\n) printf
X select-object } /ifelse cvx ] cvx
X execute-it
X } def
X
X /pointsize-obj { % point => -
X dup /Default eq {
X pop ob /Point undef
X } {
X ob exch /Point exch put
X } ifelse
X redo-layout
X } def
X
X /shrink-obj { % shrink => -
X dup /Default eq {
X pop ob /Shrink undef
X } {
X ob exch /Shrink exch put
X } ifelse
X redo-layout
X } def
X
X /update-obj {
X % ...
X } def
X
X /open-obj { % levels => -
X dup 0 eq { pop close-struct } { open-struct } ifelse
X } def
X
X /set-open-direction { % bool => -
X { /Right {
X ob /OpenToRight? true put
X }
X /Below {
X ob /OpenToRight? false put
X }
X /Default {
X ob /OpenToRight? undef
X }
X } case
X } def
X
X /open-right-obj { % levels => -
X /Right set-open-direction open-obj
X } def
X
X /open-below-obj { % levels => -
X /Below set-open-direction open-obj
X } def
X
X /set-show-fan { % bool => -
X dup {
X true false { ob exch /ShowFan? exch put }
X /Default { pop ob /ShowFan? undef }
X } case
X } def
X
X /push-obj {
X ob Shift /I /Obj ifelse get push-it
X } def
X
X /push-it {
X [ exch [ exch ] 0 /get cvx
X /dup cvx /smart-name cvx (%% ) (%Push: %\n) /printf cvx ] cvx
X execute-it
X } def
X
X /begin-it {
X [ exch [ exch ] 0 /get cvx
X /dup cvx /smart-name cvx (%% ) (%Begin: %\n) /printf cvx
X /begin cvx /dstack cvx
X ] cvx
X execute-it
X } def
X
X /enter-it {
X [ exch [ exch ] 0 /get cvx
X /dup cvx /smart-name cvx (%% ) (%Enter: %\n) /printf cvx
X /enter cvx
X ] cvx
X execute-it
X } def
X
X /insert-before-obj {
X } def
X
X /insert-after-obj {
X } def
X
X /molecule-obj {
X ob /Obj get start_visualizer
X } def
X
X % construct a reference to a piece of substructure relative to the
X % top level object
X /reference-obj {
X obs length 2 lt { {} } {
X [ obs dup 1 exch length 1 sub getinterval {
X /I get cvlit /get cvx
X } forall
X ] cvx kbd-select-object
X } ifelse
X } def
X
X /exec-obj {
X ob /Obj get Shift {[exch]cvx} if exec-it
X } def
X
X /exec-it { % obj => -
X { [ exch cvlit /cvx cvx
X /dup cvx /smart-name cvx (%% ) (%Exec: %\n) /printf cvx
X cvx /exec cvx ] cvx
X execute-it
X } fork pop pop pause
X } def
X
X /paste-obj {
X selected-object
X replace-obj
X } def
X
X /replace-obj { % obj => -
X ob begin
X replace-struct
X end
X Silent? not { redo-layout } if
X ob DL eq StackI null ne and { % Tell processes if we changed its stack.
X /ReplaceStack items StackI get send
X } if
X } def
X
X /modify-obj { % obj => -
X LayoutLock {
X ob begin
X gsave
X ItemCanvas setcanvas
X ObjectX ObjectY ObjectHeight add translate
X /erase-proc load cvx exec
X C I 3 -1 roll put
X make-label change-label
X grestore
X end
X } monitor
X ob DL eq StackI null ne and { % Tell processes if we changed its stack.
X /ReplaceStack items StackI get send
X } if
X } def
X
X /make-label { % - => str
X /Obj /C load /I load get def
X % get default if not defined (don't use parent's)
X currentdict /label-proc known {
X /label-proc load
X } {
X self /label-proc get
X } ifelse
X cvx exec
X } def
X
X
X % func is passed the object, and the object is replaced by
X % whatever's left on the top of stack.
X /transform-obj { % func => -
X LayoutLock {
X ob begin
X gsave
X ItemCanvas setcanvas
X ObjectX ObjectY ObjectHeight add translate
X /erase-proc load cvx exec
X C I 2 copy get 4 -1 roll {errored pop} fork waitprocess
X exch pop exch pop put
X pop pop
X make-label change-label
X grestore
X end
X } monitor
X ob DL eq StackI null ne and { % Tell processes if we changed its stack.
X /ReplaceStack items StackI get send
X } if
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Moving and shaping
X
X /just-reshape {
X% Core dumps X11/NeWS beta 1:
X ItemCanvas null ne { ItemCanvas /Mapped false put } if
X
X /ItemHeight exch store /ItemWidth exch store
X
X ItemWidth 0 eq ItemHeight 0 eq or {
X /DL null store
X } if
X ensure-DL
X
X adjust-geometry
X
X ItemWidth ItemHeight /reshape super send
X gsave ItemCanvas setcanvas ItemFillColor fillcanvas grestore
X
X ItemCanvas /Mapped true put
X } def
X
X /reshape { % x y w h => -
X just-reshape
X location move
X } def
X
X /just-move { % x y => -
X /move super send
X } def
X
X /move { % x y => -
X label-bbox /lh exch store /lw exch store % x y lx ly
X 2 index add /ly exch store % x y lx
X 2 index add /lx exch store % x y
X ly 0 max /ClientHeight win send lh sub min ly sub add exch
X lx 0 max /ClientWidth win send lw sub min lx sub add exch
X cvi exch cvi exch /move super send
X snaps-here? pop
X Index ThisI eq {
X /paint-hilite win send
X } if
X StackI null ne StackI Index ne and {
X /MoveMe TellStack
X } if
X } def
X
X /redo-layout {
X gsave
X ItemCanvas setcanvas
X ObjectX ObjectY ObjectHeight add translate
X perform-layout
X redo-shape
X grestore
X } def
X
X /redo-shape {
X %location 10 10 just-reshape
X location 10 10 reshape
X damage-view
X } def
X
X /label-bbox { % x y w h
X TabX TabY TabWidth TabHeight
X } def
X
X /tab-top { % - => y
X location TabY add TabHeight add exch pop
X } def
X
X /tab-bottom { % - => y
X location TabY add exch pop
X } def
X
X /label-rect { % X Y w h
X location TabY add exch TabX add exch TabWidth TabHeight
X } def
X
X /object-bbox { % x y w h
X ObjectX ItemBorder sub ObjectY ItemBorder sub % x y
X ObjectWidth ItemBorder dup add add % w
X ObjectHeight ItemBorder dup add add % h
X } def
X
X /ItemPath {
X ItemRadius label-bbox rrectpath
X ItemRadius object-bbox rrectpath
X } def
X
X /AdjustItemSize { % - => - [uses item context]
X ObjectLoc {
X /Right /Left /RightBelow /RightAbove /LeftBelow /LeftAbove {
X /ItemWidth ItemBorder 3 mul ItemGap add
X LabelWidth add ObjectWidth add store
X /ItemHeight ItemBorder 2 mul LabelHeight
X ObjectHeight max add store
X }
X /Top /Bottom /AboveLeft /AboveRight /BelowLeft /BelowRight {
X /ItemWidth ItemBorder 2 mul LabelWidth ObjectWidth max add store
X /ItemHeight ItemBorder 3 mul ItemGap add
X LabelHeight add ObjectHeight add store
X }
X } case
X } def
X
X /CalcObj&LabelXY { % - => - [uses item context]
X ObjectLoc {
X /RightAbove {
X /LabelX ItemBorder def /LabelY ItemBorder store
X /ObjectX ItemBorder dup add LabelWidth add ItemGap add store
X /ObjectY ItemHeight ObjectHeight sub 2 div store
X /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
X /TabWidth
X ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store
X /TabHeight LabelHeight ItemBorder dup add add def }
X /RightBelow /Right {
X /LabelX ItemBorder store
X /LabelY ItemHeight ItemBorder sub LabelHeight sub store
X /ObjectX ItemBorder dup add LabelWidth add ItemGap add store
X /ObjectY ItemHeight ObjectHeight sub 2 div store
X /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
X /TabWidth
X ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store
X /TabHeight LabelHeight ItemBorder dup add add def }
X /LeftAbove {
X /LabelX ItemBorder dup add ItemGap add ObjectWidth add store
X /LabelY ItemBorder store
X /ObjectX ItemBorder store
X /ObjectY ItemHeight ObjectHeight sub 2 div store
X /TabX LabelX ItemGap sub ItemRadius dup add sub store
X /TabY LabelY ItemBorder sub store
X /TabWidth
X ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store
X /TabHeight LabelHeight ItemBorder dup add add def }
X /LeftBelow /Left {
X /LabelX ItemBorder dup add ItemGap add ObjectWidth add store
X /LabelY ItemHeight ItemBorder sub LabelHeight sub store
X /ObjectX ItemBorder store
X /ObjectY ItemHeight ObjectHeight sub 2 div store
X /TabX LabelX ItemGap sub ItemRadius dup add sub store
X /TabY LabelY ItemBorder sub store
X /TabWidth
X ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store
X /TabHeight LabelHeight ItemBorder dup add add def }
X /AboveRight /Top {
X /LabelX ItemBorder def /LabelY ItemBorder store
X /ObjectX ItemWidth ObjectWidth sub 2 div store
X /ObjectY ItemBorder dup add LabelHeight add ItemGap add store
X /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
X /TabWidth LabelWidth ItemBorder dup add add store
X /TabHeight
X ItemBorder LabelHeight add ItemGap add ItemRadius dup add add
X def }
X /AboveLeft {
X /LabelX ItemWidth ItemBorder sub LabelWidth sub store
X /LabelY ItemBorder store
X /ObjectX ItemWidth ObjectWidth sub 2 div store
X /ObjectY ItemBorder dup add LabelHeight add ItemGap add store
X /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
X /TabWidth LabelWidth ItemBorder dup add add store
X /TabHeight
X ItemBorder LabelHeight add ItemGap add ItemRadius dup add add
X def }
X /BelowRight /Bottom {
X /LabelX ItemBorder store
X /LabelY ItemBorder dup add ObjectHeight add ItemGap add store
X /ObjectX ItemWidth ObjectWidth sub 2 div store
X /ObjectY ItemBorder store
X /TabX LabelX ItemBorder sub store
X /TabY LabelY ItemGap sub ItemRadius dup add sub store
X /TabWidth LabelWidth ItemBorder dup add add store
X /TabHeight
X ItemRadius dup add ItemGap add LabelHeight add ItemBorder add
X def }
X /BelowLeft {
X /LabelX ItemWidth ItemBorder sub LabelWidth sub store
X /LabelY ItemBorder dup add ObjectHeight add ItemGap add store
X /ObjectX ItemWidth ObjectWidth sub 2 div store
======== END OF cyber.shar.splitad ========