don@TUMTUM.CS.UMD.EDU (Don Hopkins) (11/23/89)
======== START OF cyber.shar.splitaf ========
X ObjectSize /ObjectHeight exch def /ObjectWidth exch def
X AdjustItemSize
X CalcObj&LabelXY
X } def
X
X /replace-obj { % obj => -
X Collection Index 2 index put
X kbd-select-object
X } def
X
X /toggle-icon {} def
X
X /show-tab-menu {
X /it self store
X CurrentEvent /showat DialogMenu send
X } def
X
X /show-struct-menu {
X /it self store
X /ob 20 dict store
X ob begin
X /C Collection def
X /I Index def
X /Obj Collection Index get def
X end
X CurrentEvent /showat SelectionMenu send
X } def
X
X /do-search {
X /it self store
X /ob null store
X } def
X
X /make-selection { % We ARE the selection.
X } def
X
X /pin-rect { % X Y w h
X location exch PinX add 3 sub exch % x y
X PinHeight 0 lt {
X PinHeight add
X } if
X ItemHeight PinHeight abs add
X 6 exch
X } def
X
X /exec-and-update { % func => -
X null /ExecIt TellMyProcess
X } def
X
X /TellMyProcess { % ClientData Action Name
X 8 { % wait up to 4 seconds if no process
X MyProcess null eq { .5 60 div sleep } { exit } ifelse
X } repeat
X MyProcess null eq {
X pop pop pop
X gsave framebuffer setcanvas
X currentcursorlocation [(No process!)] popmsg pop
X grestore
X } {
X createevent begin
X /Name exch def
X /Action exch def
X /ClientData exch def
X /Process MyProcess def
X currentdict end sendevent
X } ifelse
X } def
X
X /UpdateStack { % event => -
X DeferedUpdateEvent null ne {
X DeferedUpdateEvent recallevent
X } if
X /DeferedUpdateEvent CurrentEvent store
X DeferedUpdateEvent begin
X /Name /DeferedUpdate def
X /TimeStamp currenttime UpdateDelay add def
X end % event
X DeferedUpdateEvent sendevent
X pop
X } def
X
X /DeferedUpdate { % event => -
X /DeferedUpdateEvent null store
X dialog-promptlines 0 ne {
X /getcaretpos dialog-text send
X exch pop 1 exch dialog-promptlines 1 sub 0 max sub
X 2 copy /movecaret dialog-text send
X exch pop dialog-promptlines exch /deleteline dialog-text send
X } if
X [
X dialog-string dialog-buf
X CurrentEvent /ClientData get length
X (NeWS[%]> %%) sprintf
X { (\n) search { % chop string up at newlines
X exch pop exch
X } {
X exit
X } ifelse
X } loop
X ]
X dup length /dialog-promptlines exch store
X false /writeatcaret dialog-text send
X pause
X CurrentEvent /ClientData get
X setoperandstack
X pop
X } def
X
X /ProcessReady { % event => -
X dup /ClientData get
X exch /Action get
X set-process
X } def
X
X /set-process { % stack process => -
X /MyProcess exch def
X setoperandstack
X { currentprocess (%% ) (%Hello, my name is %!\n) printf } execute-it
X } def
X
X /SelectionChanged { % event => -
X CurrentEvent /Action get /PrimarySelection eq {
X CurrentEvent /ClientData get % selection
X dup selection-type % selection type
X dup /text eq {
X pop dissect-selection
X Collection Index 2 index put
X (text: %) exch [ exch ]
X } { % selection type
X (%: %) [ 4 2 roll % fmt mark selection type
X exch % fmt mark type selection
X dissect-selection
X Collection Index 2 index put
X smart-name % fmt mark type name
X ]
X } ifelse
X sprintf
X /printstring Notifier send
X } if
X pop
X } def
X
X /makestartinterests {
X /makestartinterests super send
X [ exch aload pop
X /ProcessReady {/ProcessReady /Self GetFromCurrentEvent send}
X null ItemCanvas eventmgrinterest
X dup /Self self PutInEventMgrInterest
X /UpdateStack {/UpdateStack /Self GetFromCurrentEvent send}
X null ItemCanvas eventmgrinterest
X dup /Self self PutInEventMgrInterest
X /DeferedUpdate {/DeferedUpdate /Self GetFromCurrentEvent send}
X null ItemCanvas eventmgrinterest
X dup /Self self PutInEventMgrInterest
X /SelectionChanged {/SelectionChanged /Self GetFromCurrentEvent send}
X null null eventmgrinterest
X dup /Self self PutInEventMgrInterest
X /PushMe {/DoPushMe /Self GetFromCurrentEvent send}
X Index ItemParent eventmgrinterest
X dup /Self self PutInEventMgrInterest
X /PopMe {/DoPopMe /Self GetFromCurrentEvent send}
X Index ItemParent eventmgrinterest
X dup /Self self PutInEventMgrInterest
X /MoveMe {/DoMoveMe /Self GetFromCurrentEvent send}
X Index ItemParent eventmgrinterest
X dup /Self self PutInEventMgrInterest
X ]
X } def
X
X /DoPushMe { % event => -
X /ClientData get PushMe
X } def
X
X /DoPopMe { % event => -
X /ClientData get PopMe
X } def
X
X /DoMoveMe { % event => -
X ItemLock {
X SortStack ReplaceStack
X } monitor
X pop
X } def
X
X /PushMe { % index => -
X ItemLock {
X /I exch def
X /MyStack [
X MyStack {
X dup I eq {pop} if
X } forall
X I
X ] store
X SortStack
X getoperandstack
X {Collection Index get} items I get send
X smart-name (%% Push: ) exch append (\n) append
X /ReplaceStack TellMyProcess
X } monitor
X } def
X
X /PopMe { % index => -
X ItemLock {
X /I exch def
X /MyStack [
X MyStack {
X dup I eq {pop} if
X } forall
X ] store
X getoperandstack
X {Collection Index get} items I get send
X smart-name (%% Pop: ) exch append (\n) append
X /ReplaceStack TellMyProcess
X } monitor
X } def
X
X /ReplaceStack {
X ItemLock {
X getoperandstack
X null
X /ReplaceStack TellMyProcess
X } monitor
X } def
X
X /SortStack {
X ItemLock {
X MyStack {
X /tab-top exch items exch get send exch
X /tab-top exch items exch get send
X lt
X } quicksort pop
X } monitor
X } def
X
X % This code was designed to be rewritten!
X % To do:
X % Make the stack display premptable: Each pass it does one thing to make the
X % display look more like MyStack. (bottom to top priority)
X /SetStack { % stack => -
X ItemLock {
X ItemBegin 10 dict begin
X /NewStack exch def
X /OldStack 200 dict def
X MyStack {
X items 1 index get {Collection Index get} exch send
X OldStack 3 1 roll put
X } forall
X /MyStack [] store
X NewStack { % new
X pause
X /I null def
X OldStack { % new ind old
X dup 3 index eq { % new ind old
X xcheck 2 index xcheck eq { % new ind
X /I exch def exit % new
X } { pop } ifelse % new
X } { pop pop } ifelse % new
X } forall % new
X pause
X /I load null ne {
X pop %
X OldStack /I load undef
X /MyStack [
X MyStack aload pop /I load
X ] store
X } { % new
X /MyStack [
X MyStack aload length 3 add -1 roll % /MyStack [ ... new
X create-struct % /MyStack [ ... newind
X ] store %
X } ifelse
X } forall
X pause
X OldStack { % ind old
X pop % ind
X items exch get % item
X dup /StackI null put % XXX
X /Free exch send %
X pause
X } forall
X pause
X /Y tab-top def
X MyStack { % ind
X items exch get % item
X Y { % PrevTop
X dup tab-bottom exch sub % PrevTop below
X dup 0 lt {
X location 2 index sub just-move
X pause
X } if
X pop pop tab-top
X } 3 -1 roll send % NextTop
X /Y exch def %
X } forall %
X pin-rect % x y w h
X exch pop add exch pop % PinTop
X Y lt { % if we ran off the top of the stack, then pack it down.
X PackStack
X } if
X pause
X ItemEnd end
X } monitor
X } def
X
X /create-struct { % obj => i
X ItemLock {
X 20 dict begin
X /Obj exch def
X NextStackPos
X /NextY exch def /NextX exch def
X free-items length 0 eq {
X Stack SP /Obj load put
X Stack SP {handle-click} can
X /new StructItem send
X /It exch def
X /items [
X items aload pop
X It
X ] store
X /I SP def
X /SP SP 1 add store
X It /StackI Index put
X createevent begin
X /Name /UpdateInterests def
X /Canvas ItemParent def
X /ClientData I def
X currentdict end sendevent
X } {
X /I free-items dup length 1 sub get def
X /It items I get def
X /free-items free-items 0 1 index length 1 sub getinterval store
X It /StackI Index put
X /Obj load /Reuse It send
X } ifelse
X NextX NextY
X { 2 copy 20 20 just-reshape
X exch PinX sub exch just-move
X map damage-view
X } It send
X I
X pause pause
X end
X } monitor
X } def
X
X /getoperandstack {
X % Don't use [ ... ] in case there are marks on the stack!!
X MyStack {
X {Collection Index get} exch items exch get send
X } forall
X MyStack length array astore
X } def
X
X /getdictstack { % - => dictstack
X MyProcess null eq { nullarray } {
X MyProcess /DictionaryStack get
X } ifelse
X } def
X
X /PackStack {
X 10 dict begin
X /Y tab-top def
X MyStack {
X items exch get
X Y { % PrevTop
X dup tab-bottom exch sub % PrevTop below
X location 2 index sub just-move
X pause pause
X pop pop tab-top
X } 3 -1 roll send
X /Y exch def
X pause pause
X } forall
X end
X pause
X } def
X
X /NextStackPos { % - => x y
X MyStack length 0 eq {
X NextPos
X } {
X MyStack dup length 1 sub get items exch get
X /NextPos exch send
X } ifelse
X } def
X
X /setoperandstack {
X SetStack
X } def
X
X /ClientExit {
X CurrentEvent /KeyState get {
X dup AdjustButton eq {
X {
X ItemBegin
X /StackI Index store
X /ThisI Index store
X ItemCanvas setcanvas
X location TabY add TabHeight 2 div add exch PinX add exch
X ItemParent createoverlay setcanvas
X { 2 setlinewidth exch pop x0 exch lineto }
X getanimated waitprocess aload pop % x y
X exch pop location exch pop sub
X dup 0 gt {ItemHeight sub 0 max} if
X /PinHeight exch store
X /paint-hilite win send
X ItemEnd
X } fork pop pop exit
X } if
X } forall
X StopItem
X } def
X
X /paint-struct {
X gsave
X ensure-DL
X /paint Scroller send
X /paint Notifier send
X dialog-can setcanvas
X /fixdamage dialog-text send
X grestore
X } def
X
X /DrawHilite {
X gsave can setcanvas
X location CanvasYFudge add translate
X ItemRadius object-bbox
X 4 -1 roll DropShadow add
X 4 -1 roll DropShadow sub
X 4 2 roll
X rrectpath
X .5 setgray fill
X% -3 ItemRadius label-bbox insetrrect rrectpath
X 2 setlinewidth 0 setgray stroke
X PinHeight 0 ne {
X 1 setlinecap
X 2 setlinewidth
X 0 setgray
X PinX 0 dup PinHeight add min 6 sub moveto
X 0 ItemHeight PinHeight abs add 12 add rlineto
X stroke
X
X 1 setlinecap
X 6 setlinewidth
X 0 setgray
X
X PinX 0 dup PinHeight add min moveto
X 0 ItemHeight PinHeight abs add rlineto
X
X gsave stroke grestore
X 2 setlinewidth
X 1 setgray
X stroke
X } if
X grestore
X } def
X
X /reshapefromuser {
X } def
X
X /reshape {
X /reshape super send
X gsave
X% ensure-DL
X ItemCanvas setcanvas
X ObjectX ScrollerWidth add SubItemGap add ObjectY translate
X 0 0
X ObjectWidth ScrollerWidth sub SubItemGap sub
X ObjectHeight NotifierHeight sub SubItemGap sub
X rectpath dialog-can reshapecanvas
X dialog-can /Mapped true put
X /reshape dialog-text send
X
X ItemCanvas setcanvas
X { [ 1 0 1 TextHeight div dup CanHeight floor 1 sub mul null ] }
X dialog-text send
X /setrange Scroller send
X ObjectX ObjectY
X ScrollerWidth ObjectHeight NotifierHeight sub SubItemGap sub
X /reshape Scroller send
X /paint Scroller send
X
X ObjectX ObjectY ObjectHeight add NotifierHeight sub
X ObjectWidth NotifierHeight
X { /ObjectX 0 def /ObjectY 0 def
X reshape } Notifier send
X /paint Notifier send
X
X SubItemMgr null eq {
X /SubItemMgr
X dictbegin
X /Scroller Scroller def
X /Notifier Notifier def
X dictend forkitems
X store
X } if
X grestore
X } def
X
X /ensure-DL {
X dialog-text null eq {
X /dialog-can ItemCanvas newcanvas store
X%dialog-can /Transparent false put
X%dialog-can /Retained true put
X%dialog-can /Parent get dup /Transparent false put /Retained true put
X /dialog-text 200 dialog-can /new TextCanvas send store
X { /KeyDict 200 dict def
X KeyDict begin
X
X 0 { (prompt) comment
X prompt
X } def
X
X 127 { (erase character) comment % Rubout
X dialog-string length 0 ne {
X getcaretpos
X exch dup 1 gt {
X 1 sub exch
X movecaret
X getcaretpos
X 1 3 1 roll deletestring
X /dialog-string dialog-string dup length 1 sub
X 0 max 0 exch getinterval store
X } if
X } if
X } def
X 8 127 load def % Backspace
X
X 23 { (erase word) comment % ^W
X 0
X { dialog-string length 1 index sub % i
X dup 0 le { pop exit } if
X 1 sub dialog-string exch get
X DelimDict exch known 1 index 0 ne and {
X exit
X } if
X 1 add
X } loop
X dup 0 eq { pop } {
X dup
X getcaretpos exch 2 index sub exch
X 2 copy movecaret
X deletestring
X /dialog-string dialog-string dup length 4 -1 roll sub
X 0 max 0 exch getinterval store
X } ifelse
X } def
X
X 24 { (erase line) comment % ^X
X getcaretpos
X exch dialog-string length sub 1 max exch
X 2 copy
X movecaret
X dialog-string length 3 1 roll
X deletestring
X /dialog-string () store
X } def
X 21 24 load def % ^U
X
X 13 { (exec line) comment % Return
X [ () () ] false writeatcaret
X dialog-string /dialog-enter dialog-item send
X /dialog-string () store
X /dialog-promptlines
X 0 dialog-buf {
X (\n) search {
X pop pop exch 1 add exch
X } {
X pop exit
X } ifelse
X } loop
X 1 add
X store
X } def
X
X 10 { (select line) comment % Newline
X [ () () ] false writeatcaret
X dialog-string kbd-select-object
X /dialog-string () store
X prompt
X } def
X
X 10 128 add { (input line) comment % Meta-Newline
X [ () () ] false writeatcaret
X dialog-string /dialog-newline dialog-item send
X /dialog-string () store
X prompt
X } def
X
X 19 { (insert selection) comment % ^S
X selected-object (%) sprintf
X [ 1 index ] false writeatcaret
X /dialog-string exch dialog-string exch append store
X } def
X
X 12 { (load) comment % ^L
X { (%% load\n) print
X load
X } execute-it
X } def
X
X 20 { (exchange) comment % ^T
X { (%% exch\n) print
X exch
X } execute-it
X } def
X
X 11 { (stack to selection) comment % ^K
X { (%% Stack to selection\n) print
X count 0 ne { select-object } if
X } /execute-it dialog-item send
X } def
X
X 25 { (selection to stack) comment % ^Y
X { (%% Selection to stack\n) print
X selected-object
X } /execute-it dialog-item send
X } def
X
X /FunctionR3 { (execute selection) comment
X selected-object
X % Since 'token' doesn't recognize \r's as ending comments,
X % if the selection has \r's in it, make a copy with \r's
X % mapped to \n's.
X dup type /stringtype eq {
X dup remove-returns exch 1 index ne {
X kbd-select-object
X } if
X } if
X { selected-object cvx
X dup (%) sprintf
X (\n) search { exch pop exch pop ( ...) append} if
X (%% ) (%Execute selection %\n) printf
X exec
X } /execute-it dialog-item send
X } def
X (x) 0 get 128 add /FunctionR3 load def % Meta-x
X (X) 0 get 128 add /FunctionR3 load def % Meta-X
X
X 3 { (reset input) comment % ^C
X /kbd-reset dialog-item send
X } def
X
X 255 { (reboot process) comment % Meta-Delete
X Control {
X [ () (Hey! This ain't no stinkin' MS-DOS!!!) () ]
X false writeatcaret
X } if
X /kbd-reboot dialog-item send
X } def
X 31 128 add 255 load def
X
X /FunctionR9 { (page up) comment
X /ScrollPageForward /FakeScroll dialog-scroll send
X } def
X (v) 0 get 128 add /FunctionR9 load def % Meta-v
X (V) 0 get 128 add /FunctionR9 load def % Meta-V
X
X /FunctionR15 { (page down) comment
X /ScrollPageBackward /FakeScroll dialog-scroll send
X } def
X 22 /FunctionR15 load def % ^V
X
X /FunctionR7 { (scroll up) comment
X /ScrollLineForward /FakeScroll dialog-scroll send
X } def
X (z) 0 get 128 add /FunctionR7 load def % Meta-z
X (Z) 0 get 128 add /FunctionR7 load def % Meta-Z
X
X /FunctionR13 { (scroll down) comment
X /ScrollLineBackward /FakeScroll dialog-scroll send
X } def
X 26 /FunctionR13 load def % ^Z
X
X /FunctionR11 { (scroll to bottom) comment
X 1 /ScrollTo dialog-scroll send
X } def
X (>) 0 get 128 add /FunctionR11 load def % Meta->
X (.) 0 get 128 add /FunctionR11 load def % Meta-.
X
X /FunctionF10 { (help) comment % Alternate
X [ () (Key Bindings:) ()] false writeatcaret
X [ KeyDict {
X comment-string exch key-name
X (%: %) sprintf
X pause pause
X } forall ]
X {gt} quicksort
X { [ exch () ] false writeatcaret
X pause pause pause } forall
X prompt
X } def
X (?) 0 get 128 add /FunctionF10 load def % Meta-?
X (/) 0 get 128 add /FunctionF10 load def % Meta-/
X
X /FunctionR1 { (describe key) comment
X [ () (Describe key: ) ] false writeatcaret
X /DescribingKey? true store
X } def
X (k) 0 get 128 add /FunctionR1 load def % Meta-k
X (K) 0 get 128 add /FunctionR1 load def % Meta-K
X
X /FunctionR2 { (bind selection to key) comment
X [ () selected-object smart-type (Bind selection %) sprintf
X (to key: ) ]
X false writeatcaret
X /BindingKey? true store
X } def
X (b) 0 get 128 add /FunctionR2 load def % Meta-b
X (B) 0 get 128 add /FunctionR2 load def % Meta-B
X
X /FunctionL9 { (find completions) comment
X [ dialog-string {
X DelimDict 1 index known { cleartomark mark } if
X } forall
X ] cvas
X dup length 0 eq { pop } {
X kbd-select-object
X { selected-object
X (%% Finding completions of ") print dup print (":\n) print
X currentprocess /DictionaryStack get
X 20 dict begin
X /DS exch def
X /pat exch def
X /found null def
X /complete null def
X% X11/NeWS pre fcs gives rangecheck errors when we try to cvs something
X% into a string it's too long for...
X% /str pat length string def
X /wholestr 256 string def
X /str wholestr 0 pat length getinterval def
X DS length 1 sub -1 0 { /i exch def
X DS i get {
X /val exch def
X% dup str cvs pat ne { pop } {
X dup wholestr cvs pop str pat ne { pop } {
X found null eq {
X /found 1 index 256 string cvs def
X /complete found def
X } {
X /found 1 index 256 string cvs def
X found length complete length lt {
X /complete found def
X } {
X 0 complete {
X found 2 index get ne {
X /complete complete 0 3 index getinterval store
X exit
X } if
X 1 add
X } forall
X pop
X } ifelse
X } ifelse
X /val load smart-name exch i (%: /% %\n) printf
X } ifelse
X } forall
X pause pause
X } for
X pause pause pause
X complete null eq { () } {
X complete pat length 1 index length 1 index sub
X getinterval
X } ifelse
X createevent begin
X /Name /InsertValue def
X /Action exch def
X /Canvas
X % Fails with more than one interest!
X% currentprocess /Interests get 0 get % event
X currentprocess /Interests get
X % the first interest expressed is the last on the list
X dup length 1 sub get % event
X /ClientData get /ViewCanvas get % can
X /Parent get % clientcanvas has keyboard interests!
X def
X currentdict end sendevent
X complete null ne { complete select-object } if
X end
X } execute-it
X } ifelse
X } def
X 27 128 add /FunctionL9 load def
X
X 27 { (complete) comment % Escape
X [ dialog-string {
X DelimDict 1 index known { cleartomark mark } if
X } forall
X ] cvas
X dup length 0 eq { pop } {
X kbd-select-object
X { selected-object
X currentprocess /DictionaryStack get
X 20 dict begin
X /DS exch def
X /pat exch def
X /found null def
X /complete null def
X% X11/NeWS pre fcs gives rangecheck errors when we try to cvs something
X% into a string it's too long for...
X% /str pat length string def
X /wholestr 256 string def
X /str wholestr 0 pat length getinterval def
X DS length 1 sub -1 0 { /i exch def
X DS i get {
X /val exch def
X% dup str cvs pat ne { pop } {
X dup wholestr cvs pop str pat ne { pop } {
X found null eq {
X /found 1 index 256 string cvs def
X /complete found def
X } {
X /found 1 index 256 string cvs def
X found length complete length lt {
X /complete found def
X } {
X 0 complete {
X found 2 index get ne {
X /complete complete 0 3 index getinterval store
X exit
X } if
X 1 add
X } forall
X pop
X } ifelse
X } ifelse
X pop
X } ifelse
X } forall
X pause
X } for
X pause
X complete null ne {
X complete pat length 1 index length 1 index sub
X getinterval
X createevent begin
X /Name /InsertValue def
X /Action exch def
X /Canvas
X currentprocess /Interests get 0 get % event
X /ClientData get /ViewCanvas get % can
X /Parent get % clientcanvas has keyboard interests!
X def
X currentdict end sendevent
X complete null ne { complete select-object } if
X } if
X end
X } execute-it
X } ifelse
X } def
X
X 4 { (completions) comment % ^D
X [ dialog-string {
X DelimDict 1 index known { cleartomark mark } if
X } forall
X ] cvas
X dup length 0 eq { pop } {
X kbd-select-object
X { selected-object
X (%% Completions of ") print dup print (":\n) print
X currentprocess /DictionaryStack get
X 20 dict begin
X /DS exch def
X /pat exch def
X /found null def
X /complete null def
X% X11/NeWS pre fcs gives rangecheck errors when we try to cvs something
X% into a string it's too long for...
X% /str pat length string def
X /wholestr 256 string def
X /str wholestr 0 pat length getinterval def
X DS length 1 sub -1 0 { /i exch def
X DS i get {
X /val exch def
X% dup str cvs pat ne { pop } {
X dup wholestr cvs pop str pat ne { pop } {
X found null eq {
X /found 1 index 256 string cvs def
X /complete found def
X } {
X /found 1 index 256 string cvs def
X found length complete length lt {
X /complete found def
X } {
X 0 complete {
X found 2 index get ne {
X /complete complete 0 3 index getinterval store
X exit
X } if
X 1 add
X } forall
X pop
X } ifelse
X } ifelse
X (% ) printf
X } ifelse
X } forall
X pause
X } for
X (\n) printf
X pause pause
X complete null ne {
X complete pat length 1 index length 1 index sub
X getinterval
X select-object
X } if
X end
X } execute-it
X } ifelse
X } def
X
X end % KeyDict
X
X /DelimDict 50 dict def
X DelimDict begin
X 0 1 32 { dup def } for
X (%/()<>[]{}) { dup def } forall
X end
X
X /typein {
X [1 index] false writeatcaret
X /dialog-string exch dialog-string exch append store
X } def
X
X /DescribingKey? false def
X /BindingKey? false def
X /key 0 def
X
X /KeyHitCallback { % event =>
X dup update-shifts
X /Name get
X dup type /integertype eq {
X% Meta {128 add} if
X Meta {128 or} if
X } {
X (%) sprintf % X11/NeWS pre fcs bug: /foo cvn => typecheck error!
X Meta { (Meta%) sprintf } if
X Shift { (Shift%) sprintf } if
X Control { (Control%) sprintf } if
X cvn
X } ifelse
X /key exch def
X BindingKey? DescribingKey? or {
X BindingKey? {
X selected-object
X KeyDict key known {
X KeyDict key get
X } { null } ifelse
X kbd-select-object
X dup null eq {
X pop KeyDict key undef
X } {
X KeyDict exch key exch put
X } ifelse
X } if
X [ ()
X KeyDict key known {
X KeyDict key get comment-string
X } {
X key type /integertype eq (self insert) (unbound) ifelse
X } ifelse
X key key-name
X (%: %) sprintf
X ()
X ] false writeatcaret
X /BindingKey? false store
X /DescribingKey? false store
X prompt
X } {
X KeyDict key known {
X { KeyDict key get cvx exec } fork pop
X pause
X } {
X key type /integertype eq {
X key cvis typein
X } {
X % beep
X } ifelse
X } ifelse
X } ifelse
X } def
X
X /s null def
X /skip 0 def
X /newlines 0 def
X /i 0 def
X /a null def
X /pre null def
X /lastnl 0 def
X
X /InsertValueCallback { % string => -
X /skip dialog-string length store
X /s exch dialog-string exch append store
X /newlines 0 store
X /lastnl null store
X 0 1 s length 1 sub {
X /i exch store
X s i get 13 eq { s i 10 put } if
X s i get 10 eq {
X /newlines newlines 1 add store
X /lastnl i store
X pause
X } if
X } for
X lastnl null ne {
X s 0 lastnl 1 add getinterval
X /dialog-enter dialog-item send
X pause pause pause
X /dialog-string
X s lastnl 1 add 1 index length 1 index sub
X getinterval
X store
X pause
X } if
X /s s skip 1 index length 1 index sub
X getinterval store
X /a newlines 1 add array store
X 0 1 newlines 1 sub {
X pause
X /i exch store
X s (\n) search pop
X /pre exch store
X pop
X /s exch store
X a i pre put
X } for
X
X /dialog-string dialog-string s append store
X
X a newlines s put
X a false writeatcaret
X
X /dialog-promptlines
X newlines 1 add % dialog-string length 0 eq { 1 add } if
X store
X } def
X
X% XXXX: Here be the start of the trouble.
X
X /KeyboardHandler { % - => -
X % --- Handler for keyboard, InsertValue, and Deselect events
X /KeyboardInterest can addkbdinterests def
X % X11/NeWS pre fcs: Now I don't get any key events at all when the
X % meta keys is held down. I used to get 0..127, and I was looking
X % for /Meta in the event KeyStates and or'ing in the 128 by hand,
X % but it stopped working, so now I have to do this...
X XNeWS? { % We want meta keys 128..255 as well as 0..127
X% KeyboardInterest 0 get revokeinterest % is this necessary?
X 256 dict begin
X KeyboardInterest 0 get /Name get currentdict copy
X 128 1 255 {
X dup def
X } for
X KeyboardInterest 0 get /Name currentdict put
X end
X% KeyboardInterest 0 get expressinterest % is this necessary?
X } if
X /MoreInterests [
X can addselectioninterests aload pop
X revokeinterest % Get rid of mouse interests
X% can addfunctionstringsinterest
X can addfunctionnamesinterest
X dup /Action 1 dict begin
X /DownTransition dup def
X currentdict
X end
X put % only want down transitions!
X ] def
X /dialog-proc currentprocess store
X { awaitevent dup /Name get {
X /DeSelect {
X dup /Action get /PrimarySelection eq {
X false DrawSelection
X /SelectionPath null store
X } if
X /Action get /InputFocus eq {
X InactivateCaret
X } if
X }
X /RestoreFocus {
X pop ReactivateCaret
X }
X /InsertValue {
X /Action get InsertValueCallback
X }
X /Ignore {
X pop
X }
X /Default {
X KeyHitCallback
X }
X } case
X } loop
X } def
X
X /destroy { % - => -
X /Scroller null store
X /Notifier null store
X KeyboardInterest null ne {
X { KeyboardInterest can revokekbdinterests } errored pop
X MoreInterests {
X { revokeinterest } errored pop
X } forall
X } if
X KeyboardEventMgr null ne { % added! -deh
X KeyboardEventMgr killprocess
X } if
X EventMgr null ne {
X EventMgr killprocess
X } if
X DelayedMoveProc null ne { % added! -deh
X DelayedMoveProc killprocess
X } if
X MouseDragEventMgr null ne {
X MouseDragEventMgr killprocess
X } if
X } def
X
X /CaretBlinkTime 3 def
X /CaretDutyCycle 0.95 def % Percentage on
X
X % This doesn't work:
X /FontHeight 12 def
X /FontName FontName def
X
X [ () (%% Ready!) () ] false writeatcaret
X
X oncaret
X } dialog-text send
X
X /Scroller
X [1 0 .005 .05 null] 1 {} ItemCanvas /new NeWSScrollbar send
X def
X
X /dialog-scroll Scroller store
X
X {
X /NotifyUser {
X null ItemValue /moveviewport dialog-text send
X } def
X
X /ClientDrag {
X DoScroll null ItemValue /moveviewport dialog-text send
X } def
X
X /FakeScroll { % motion => -
X ItemBegin
X /ScrollMotion exch def
X DoScroll
X EraseBox PaintBox
X NotifyUser
X ItemEnd
X } def
X
X /ScrollTo { % val => -
X ItemBegin
X /ItemValue exch def
X EraseBox PaintBox
X NotifyUser
X ItemEnd
X } def
X
X } Scroller send
X
X /Notifier
X (Selected:) () /Right {} ItemCanvas /new MessageItem send
X def
X
X {
X /LabelFont /Courier findfont 20 scalefontquant def
X /ItemFont /Courier-Bold findfont 20 scalefontquant def
X /ItemFrame 1 def
X } Notifier send
X } if
X
X } def
X
X /dialog-newline { % str => -
X psh-socket exch writestring
X psh-socket 10 write
X psh-socket flushfile
X } def
X
X% /dialog-enter { % str => -
X% /dialog-buf exch dialog-buf (%%\n) sprintf remove-returns store
X% { dialog-buf
X% { token } errored {
X% [(%% Syntax error!)] false /writeatcaret dialog-text send
X% kbd-reset exit
X% } {
X% { exch /dialog-buf exch store
X% [ exch ] cvx execute-it
X% } {
X% dialog-buf ( _FOO_) append token { % Ignore white space
X% exch pop /_FOO_ eq {
X% /dialog-buf () store
X% prompt
X% } if
X% } if
X% exit
X% } ifelse
X% } ifelse
X% pause
X% } loop
X% } def
X
X /dialog-enter { % str => -
X dialog-newline
X } def
X
X /destroy {
X shut-down
X SubItemMgr null ne {
X SubItemMgr killprocess
X /SubItemMgr null store
X } if
X dialog-text null ne {
X% {{destroy} errored pop} dialog-text send
X dialog-can /Retained false put
X /destroy dialog-text send
X /dialog-text null store
X /dialog-can null store
X } if
X MyProcess type /processtype eq {
X pause pause pause % maybe it will kill itsself
X MyProcess killprocessgroup
X } if
X /MyProcess null store
X /DeferedUpdateEvent null store
X /Stack null store
X /Pallets null store
X /destroy super send
X } def
X
Xclassend def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Nasty userdict variables
X
X/dialog-text null def
X/dialog-can null def
X/dialog-proc null def
X/dialog-string () def
X/dialog-buf () def
X/dialog-promptlines 0 def
X/dialog-item null def
X/dialog-scroll null def
X
X(NEWSSERVER) getenv
X(;) search pop
X(.) search pop pop pop
X/socket-port exch def
Xpop
X/socket-host exch def
X/socket-file (%socketc) socket-port append socket-host append def
X/psh-socket null def
X
X/SP 0 def
X/Stack 256 array def
XStack 0 {By Don Hopkins (don@brillig.umd.edu)} put
XStack 1 (Nothing!) put
X
X/ThisI null def
X
X/it null def
X/ob null def
X/obs null def
X
X/FillColor 1 1 1 rgbcolor def
X
X/ItemLock createmonitor def
X
X/items [] def
X/free-items [] def
X
X/Meta false def
X/Control false def
X/Shift false def
X
X/win null def
X/can null def
X
X/slidemgr null def
X/itemmgr null def
X/incoming null def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Item managment
X
X/createitems {
X ItemLock {
X /items [
X Stack 0 {handle-click} can
X /new StructItem send
X 200 400 0 0 /reshape 5 index send
X Stack 1 {} can
X /new TextStructItem send
X { /ObjectWidth 600 def
X /ObjectHeight 200 def
X 30 20 0 0 reshape
X } 1 index send
X ] def
X /SP items length store
X /dialog-item items 1 get store
X {/PinHeight 600 def /StackI 1 def} dialog-item send
X /ThisI 1 store
X } monitor
X} def
X
X/slideitem { % items fillcolor item => -
X ItemLock {
X gsave
X% dup 4 1 roll % item items fillcolor item
X {ItemCanvas canvastotop
X moveinteractive location move} exch send % item
X grestore
X } monitor
X} def
X
X/update-slide-interests { % event => -
X CurrentEvent /ClientData get % Index
X items exch get % item
X dup /ItemCanvas get % item can
X MiddleMouseButton [/pop cvx items FillColor % item can name [ dict color
X 6 -1 roll /slideitem cvx] cvx % can name proc
X DownTransition % can name proc action
X 4 -1 roll eventmgrinterest % interest
X expressinterest
X pop
X} def
X
X/update-start-interests { % event => -
X CurrentEvent /ClientData get % Index
X items exch get % item
X mark
X [/makestartinterests 3 index send aload pop]
X {dup xcheck {exec} {expressinterest} ifelse} forall
X cleartomark % event mark
X pop pop %
X} def
X
X/transfer-to-deck { % event => -
X gsave
X can setcanvas
X selected-object
X ItemLock {
X 20 dict begin
X /Obj exch def
X currentcursorlocation
X /NextY exch def /NextX exch def
X free-items length 0 eq {
X Stack SP /Obj load put
X Stack SP {handle-click} can
X /new StructItem send
X /It exch def
X /items [
X items aload pop
X It
X ] store
X /I SP def
X /SP SP 1 add store
X It /StackI null put
X createevent begin
X /Name /UpdateInterests def
X /Canvas can def
X /ClientData I def
X currentdict end sendevent
X } {
X /I free-items dup length 1 sub get def
X /It items I get def
X /free-items free-items 0 1 index length 1 sub getinterval store
X It /StackI null put
X /Obj load /Reuse It send
X } ifelse
X NextX NextY
X { 2 copy 20 20 just-reshape
X exch PinX sub exch move
X map damage-view
X } It send
X pause pause
X end
X } monitor
X grestore
X pop
X} def
X
X/start-event-mgrs {
X% Create event manager to slide around the items.
X% Create a bunch of interests to move the items.
X% Note we actually create toe call-back proc to have the arguments we need.
X% The proc looks like: {items color "thisitem" slideitem}.
X% We could also have used the interest's clientdata dict.
X slidemgr null ne {slidemgr killprocess} if
X% { %XXX
X% /slidemgr [
X% items { % key item
X% dup /ItemCanvas get % item can
X% MiddleMouseButton [items FillColor % item can name mark dict color
X% 6 -1 roll /slideitem cvx] cvx % can name proc
X% DownTransition % can name proc action
X% 4 -1 roll eventmgrinterest % interest
X% } forall
X% /UpdateInterests /update-slide-interests
X% null can eventmgrinterest
X% ] forkeventmgr store
X% } pop %XXX
X itemmgr null ne {itemmgr killprocess} if
X /itemmgr [
X items iteminterests aload pop
X /UpdateInterests /update-start-interests
X null can eventmgrinterest
X /DoTransfer /transfer-to-deck
X null can eventmgrinterest
X ] forkeventmgr store
X
X { % send to dialog-item
X psh-socket null eq {
X
X MyProcess null ne { MyProcess killprocessgroup } if
X /MyProcess null store
X incoming null ne { incoming killprocess } if
X /incoming null store
X
X systemdict /_ViewCanvas ItemCanvas put
X
X /psh-socket { socket-file (r) file } errored {
X { newprocessgroup
X framebuffer setcanvas
X 500 500 [(Could not establish connection)] popmsg pop
X } fork pause pause pop
X currentprocess killprocessgroup
X } if store
X
X% /incoming {
X% { { psh-socket CanWidth string readline false eq {
X% [() (Lost it!) ()] false writeatcaret
X% % 1 60 div sleep
X% % /kbd-reboot dialog-item send
X% /incoming null store
X% currentprocess killprocess
X% } if
X% dialog-promptlines 0 ne {
X% getcaretpos exch pop 1 exch dialog-promptlines sub 1 add
X% dup dialog-promptlines exch deleteline
X% movecaret
X% /dialog-promptlines 0 store
X% } if
X% [ exch ()
X% ] false writeatcaret
X% psh-socket bytesavailable 0 eq { prompt } if
X% } loop
X% } dialog-text send
X% } fork store
X
X /incoming {
X { { psh-socket CanWidth string readline false eq {
X [() (Lost it!) ()]
X false writeatcaret
X % 1 60 div sleep
X % /kbd-reboot dialog-item send
X /incoming null store
X currentprocess killprocess
X } if
X [ exch ()
X ] false writeatcaret
X% psh-socket bytesavailable 0 eq { prompt } if
X } loop
X } dialog-text send
X } fork store
X
X psh-socket
X% (systemdict/dbgstart known not{(NeWS/debug.ps)run}if dbgstart\n_ReadyProcess\n)
X (executive\n_ReadyProcess\n) % X11/NeWS pre fcs
X writestring
X psh-socket flushfile
X } if
X } dialog-item send
X} def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Window class definition
X
X/DeckWindow DefaultWindow
Xdictbegin
X /FrameLabel (CyberSpace Deck) def
X /IconLabel (CyberSpace Deck) def
X /IconImage /galaxy def
Xdictend
Xclassbegin
X /dragframe? true def
X
X /PaintClient {
X paint-hilite
X items paintitems
X } def
X
X /paint-hilite {
X ClientCanvas setcanvas
X erasepage
X /DrawHilite dialog-item send
X } def
X
X /ClientMenu BackgroundMenu def
X
X /display-credits {
X gsave
X framebuffer setcanvas
X currentcursorlocation
X [ (CyberSpace Deck:)
X ( by Don Hopkins)
X (----------------)
X (Code stolen from:)
X ( Josh Siegel)
X ( Don Woods)
X ] popmsg pop
X grestore
X } def
X
X /DestroyClient {
X {
X newprocessgroup
X FrameCanvas /Mapped false put
X FrameCanvas /Retained false put
X ClientCanvas /Retained false put
X itemmgr type /processtype eq { itemmgr killprocess } if
X slidemgr type /processtype eq { slidemgr killprocess } if
X items null ne {
X items
X /items null store
X {
X /destroy exch send
X } forall
X } if
X /_ViewCanvas null store
X /PrimarySelection clearselection % XXX?
X /DestroyClient super send
X } fork pop
X } def
Xclassend def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Create objects
X
X/win framebuffer /new DeckWindow send def % Create a window
X
X%0 0 900 900 /reshape win send
X/reshapefromuser win send
X/can win /ClientCanvas get def
X
X% BOO HISS
Xcan /Parent get /Retained true put
Xcreateitems
X
X% /reshapefromuser win send
X/map win send
Xstart-event-mgrs
X
Xbreakpoint % so we can catch stdout from psh
//go.sysin dd *
if [ `wc -c < cyber.ps` != 166395 ]; then
made=false
echo error transmitting cyber.ps --
echo length should be 166395, not `wc -c < cyber.ps`
else
made=true
fi
if $made; then
chmod 644 cyber.ps
echo -n ' '; ls -ld cyber.ps
fi
echo Extracting distill.ps
sed 's/^X//' <<'//go.sysin dd *' >distill.ps
X%!
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%
X% @(#)distill.ps
X% NeWS distillery
X% Copyright (C) 1989.
X% By Don Hopkins. (don@brillig.umd.edu)
X% All rights reserved.
X%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%
X% You are free to redistribute this program. Please leave the comments
X% intact, add your own interpretations, views, hallucinations, navagation
X% aids, and pass it on to friends! The author is not responsible for any
X% time or brain cells wasted with this software.
X%
X% The following is in the spirit of Glenn Reid's Distillery.
X%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X
Xsystemdict begin
X
X%
X%
X% litstring replace escapes in strings with escaped escapes!
X% Thus (foo\n) products (\(foo\\n\)) which prints as (foo\n)
X% Mainly used with printf when you want the arg to print as
X% the string you typed to the interpreter.
X% test: /s (\b\t\n\f\r\(\\\)\200\300) def s litstring
X%
X/litstring { % str => str'
X [
X 40 3 -1 roll {
X dup {
X 8 9 10 12 13 { % \b \11 \n \f \r
X (\\ ) dup 1 (--------btn-fr) 4 index get put
X }
X 40 41 92 { % ( ) & \
X (\\ ) 1 2 index put
X }
X% true { % all other chars
X /Default { % all other chars
X dup 32 lt 1 index 126 gt or {
X (\\000) dup % i s s
X 2 index dup 0 lt {256 add} if % BUG workaround
X 8 4 string cvrs % i s s os
X dup length 4 exch sub exch putinterval
X } if
X }
X } case
X dup type /stringtype eq {exch pop {} forall} if
X } forall 41 % 41 is ')'
X ] cvas
X} def
X
X/StillDict 200 dict def
XStillDict begin
X
X /_out null def
X /_out? false def
X% /_outfile (/dev/ttya) def
X% /_outfile (%socketc2000) def
X /_outfile (still_out.ps) def
X
X /_ascii? true def % false doesn't work yet because of typedprint
X
X /_display_def? false def
X
X /_showpage? true def
X
X /_eof? false def
X
X /_wrap_things? true def
X
X /_buf 80 string def
X
X /_smartcolor? false def
X /_usefont? false def
X
X /_fonts 100 dict def
X /_fcount 0 def
X /_font null def
X /_font_id null def
X /_font_name null def
X /_font_size null def
X /_color null def
X /_linecap null def
X /_linejoin null def
X /_linewidth null def
X /_miterlimit null def
X /_dashoff null def
X /_dasharray null def
X
X /_output_flatness 0 def
X
X /_output_tx -80 def
X /_output_ty -100 def
X /_output_sx 2 def
X /_output_sy 2 def
X /_output_r 0 def
X
X /_outputmatrix matrix def
X
X /_MOVETO (m\n) def
X /_LINETO (l\n) def
X /_CURVETO (c\n) def
X /_CLOSEPATH (p\n) def
X /_CONTROLPOINT (k\n) def
X /_FILL (f\n) def
X /_EOFILL (e\n) def
X /_STROKE (s\n) def
X /_SHOW (t\n) def
X /_NEWPATH (x\n) def
X /_SETFONT (n\n) def
X /_GSAVE (gs\n) def
X /_GRESTORE (gr\n) def
X /_SETGRAY (sg\n) def
X /_SETHSBCOLOR (sh\n) def
X /_SETLINECAP (sc\n) def
X /_SETLINEJOIN (sj\n) def
X /_SETLINEWIDTH (sw\n) def
X /_SETMITERLIMIT (sm\n) def
X /_SETDASH (sd\n) def
X /_DISPLAYBEGIN (/display {\n) def
X /_DISPLAYEND (} def\n) def
X /_SHOWPAGE (showpage\n) def
X /_SETUP () def
X /_SETDOWN () def
X /_STILLBEGIN (
X100 dict begin
X
X/m /moveto load def
X/l /lineto load def
X/c /curveto load def
X/p /closepath load def
X/k
X /controlpoint where { /controlpoint get } { { pop lineto } } ifelse
Xdef
X/f /fill load def
X/e /eofill load def
X/s /stroke load def
X/t /show load def
X/x /newpath load def
X/n /setfont load def
X/gs /gsave load def
X/gr /grestore load def
X/sg /setgray load def
X/sh /sethsbcolor load def
X/sc /setlinecap load def
X/sj /setlinejoin load def
X/sw /setlinewidth load def
X/sm /setmiterlimit load def
X/sd /setdash load def
X
X) def
X /_STILLEND (end % StillHeaderDict\n) def
X /_BOF () def
X /_EOF (\004) def
X /_BEGINGROUP { ProcessMax 1 gt (\n) (% BeginGroup {\n) ifelse } def
X /_ENDGROUP { ProcessMax 1 gt (\n) (%} EndGroup\n) ifelse } def
X /_BEGINTHING ({\n) def
X /_ENDTHING (} exec\n) def
X
X /_stillon {
X /_out? true store
X } def
X
X /_stilloff {
X /_out? false store
X } def
X
X /_stillbegin {
X _init
X _out null eq {
X _out? {
X systemdict /_printer known {
X /_out _printer store
X } {
X /_out _outfile (w) file store
X } ifelse
X _eof? { _BOF _write_out } if
X (%!\n%BoundingBox: % % % %\n/display_w % def\n/display_h % def\n\n)
X [ (%) (%%)
X gsave
X clippath pathbbox
X points2rect
X 4 2 roll pop pop 0 0 4 2 roll
X grestore
X 2 copy
X ] sprintf
X _write_out
X _display_def? { _DISPLAYBEGIN _write_out } if
X _SETUP _write_out
X _STILLBEGIN _write_out
X _GSAVE _write_out
X } {
X NoStillDict begin
X } ifelse
X } if
X } def
X
X /_stillend {
X _out? {
X _SETDOWN _write_out
X _GRESTORE _write_out
X _STILLEND _write_out
X _display_def? { _DISPLAYEND _write_out } if
X _showpage? { _SHOWPAGE _write_out } if
X _eof? { _EOF _write_out } if
X _out flushfile
X systemdict /_printer known not {
X _out closefile
X } if
X /_out null store
X } if
X currentdict NoStillDict eq { end } if
X } def
X
X /_init {
X gsave
X _output_tx _output_ty translate
X _output_sx _output_sy scale
X _output_r rotate
X _outputmatrix currentmatrix pop
X grestore
X /_fonts 100 dict store
X /_fcount 0 store
X /_font null store
X /_color null store
X /_linecap null store
X /_linejoin null store
X /_linewidth null store
X /_miterlimit null store
X /_dasharray null store
X /_dashoff null store
X _output_flatness setflat
X } def
X
X /_write_out {
X _out exch writestring
X } def
X
X % XXX: Writes to stdout!
X /_typed_out {
X typedprint
X } def
X
X /_write_string {
X _ascii? { litstring _write_out } { _typed_out } ifelse
X } def
X
X /_write_number {
X _ascii? { _buf cvs _write_out ( ) _write_out } { _typed_out } ifelse
X } def
X
X /_write_state {
X _usefont? {
X _font_id
X /_font_id currentfont (%) sprintf store
X _font_id ne
X } false ifelse {
X /_font_id currentfont (%) sprintf store
X /_font_name currentfont /FontName get store
X /_font_size currentfont /FontMatrix get 0 get store
X _fonts _font_id (%) sprintf known {
X _fonts _font_id get _write_out ( ) _write_out
X } {
X _fonts _font_id _fcount (_f%) sprintf put
X _font_name (/% findfont ) sprintf _write_out
X _font_size _write_number
X _fcount (scalefont dup /_f% exch def ) sprintf _write_out
X /_fcount _fcount 1 add store
X } ifelse % (_f#)
X _SETFONT _write_out
X /_font currentfont store
X } if
X _smartcolor? {
X % ...
X } {
X _color currentcolor ne {
X currentrgbcolor
X 1 index eq { eq } { pop pop false } ifelse {
X currentgray _write_number _SETGRAY _write_out
X } {
X currenthsbcolor
X 3 -1 roll _write_number exch _write_number _write_number
X _SETHSBCOLOR _write_out
X } ifelse
X /_color currentcolor store
X } if
X } ifelse
X _linecap currentlinecap ne {
X currentlinecap _write_number _SETLINECAP _write_out
X /_linecap currentlinecap store
X } if
X _linejoin currentlinejoin ne {
X currentlinejoin _write_number _SETLINEJOIN _write_out
X /_linejoin currentlinejoin store
X } if
X _miterlimit currentmiterlimit ne {
X currentmiterlimit _write_number
X _SETMITERLIMIT _write_out
X /_miterlimit currentmiterlimit store
X } if
X gsave _outputmatrix setmatrix
X _linewidth currentlinewidth ne {
X currentlinewidth _write_number
X _SETLINEWIDTH _write_out
X /_linewidth currentlinewidth store
X } if
X currentdash exch _dashoff ne { pop false } {
X dup length _dasharray length ne { pop false } {
X _dasharray {eq} arrayop
X true exch {not {not exit} if} forall
X } ifelse
X } ifelse {
X currentdash exch
X ([) _write_out { _write_number } forall (]) _write_out
X _write_number
X _SETDASH _write_out
X currentdash /_dasharray exch store /_dashoff exch store
X } if
X grestore
X } def
X
X /_write_path {
X gsave _outputmatrix setmatrix
X _output_flatness setflat
X %flattenpath
X { { exch _write_number _write_number
X _MOVETO _write_out }
X { exch _write_number _write_number
X _LINETO _write_out }
X { 6 -1 roll _write_number
X 5 -1 roll _write_number
X 4 -1 roll _write_number
X 3 -1 roll _write_number
X exch _write_number _write_number
X _CURVETO _write_out }
X { _CLOSEPATH _write_out }
X% { 3 -1 roll _write_number exch _write_number _write_number
X% _CONTROLPOINT _write_out }
X } pathforallvec
X grestore
X } def
X
X /_begingroup {
X _out? {
X _BEGINGROUP _write_out
X } if
X } def
X
X /_endgroup {
X _out? {
X _ENDGROUP _write_out
X } if
X } def
X
X /_fill {
X _out? {
X gsave fill grestore
X _write_path
X _write_state
X _FILL _write_out
X newpath
X } {
X fill
X } ifelse
X } def
X
X /_eofill {
X _out? {
X gsave eofill grestore
X _write_path
X _write_state
X _EOFILL _write_out
X newpath
X } {
X eofill
X } ifelse
X } def
X
X /_stroke {
X _out? {
X gsave stroke grestore
X _write_path
X _write_state
X _STROKE _write_out
X newpath
X } {
X stroke
X } ifelse
X } def
X
X /_show {
X _out? {
X gsave
X _write_state
X _outputmatrix setmatrix
X% _GSAVE _write_out
X% _write_matrix
X currentpoint exch _write_number _write_number
X _MOVETO _write_out
X dup _write_string
X _SHOW _write_out
X% _GRESTORE _write_out
X grestore
X } if
X show
X } def
X
X /_newpath { % signifies a new object
X _out? {
X _NEWPATH _write_out
X } if
X newpath
X } def
X
Xend % StillDict
X
X/NoStillDict 200 dict def
XNoStillDict begin
X
X /_init nullproc def
X /_begingroup nullproc def
X /_endgroup nullproc def
X /_fill /fill load def
X /_eofill /eofill load def
X /_stroke /stroke load def
X /_show /show load def
X /_newpath /newpath load def
X
Xend % NoStillDict
X
Xend % systemdict
//go.sysin dd *
if [ `wc -c < distill.ps` != 9959 ]; then
made=false
echo error transmitting distill.ps --
echo length should be 9959, not `wc -c < distill.ps`
else
made=true
fi
if $made; then
chmod 664 distill.ps
echo -n ' '; ls -ld distill.ps
fi
echo Extracting ps.ps
sed 's/^X//' <<'//go.sysin dd *' >ps.ps
X%!
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X%
X% @(#)ps.ps
X% PostScript meta-interpreter.
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. If you have read this far,
X% you obviously take this stuff far too seriously, and if you're a
X% lawyer, you should give up your vile and evil ways, and go find
X% meaningful employment. So there.
X%
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X
X% Problems:
X% How do we catch the execution of event Name and Action dict values,
X% executed by awaitevent?
X
Xsystemdict begin
X
X/iexec-types 100 dict def
X/iexec-operators 100 dict def
X/iexec-names 200 dict def
X/iexec-exit-stoppers 20 dict def
X/iexec-single-forall-types 20 dict def
X/iexec-array-like-types 20 dict def
X
X/iexec-continue-procs? true def
X/iexec-continue-names? true def
X
X/iexecing? false def
X
X/signal-error { % name => -
X dbgbreak
X} def
X
X/iexec-stopped-pending? { % - => bool
X false
X ExecSP 1 sub -1 0 {
X ExecStack exch get % ob
X dup type /dicttype eq {
X dup /continuation known {
X dup /continuation get /stopped eq {
X pop true exit
X } { pop } ifelse
X } { pop } ifelse
X } { pop } ifelse
X } for
X} def
X
X/olddbgerrorhandler /DbgErrorHandler load ?def
X
X/iexec-handle-error {
X iexec-stopped-pending?
X true { stoppedpending? } ifelse
X {
X /stop load PushExec
X } {
X $error /errorname get signal-error
X } ifelse
X} def
X
X/DbgErrorHandler {
X iexecing? {
X iexec-handle-error
X } //olddbgerrorhandler ifelse
X} def
X
X/isarray? { % obj => bool
X type iexec-array-like-types exch known
X} ?def
X
X%
X% A procedure to allow programmer to know if there is a "stopped"
X% pending somewhere within the scope of the call. This is used
X% to check if it's safe to rely on stopped to handle an error,
X% rather than the errordict. The debugger can use this to
X% catch errors that have no stopped call pending.
X%
X/stoppedpending? { % - => bool
X false currentprocess /ExecutionStack get % result a
X dup length 1 sub -2 1 { % result a i
X 2 copy get % result a i index
X exch 1 sub 2 index exch get % result a index proc
X dup isarray? {
X exch 1 sub get % result a caller
X /stopped load eq {pop true exch exit} if
X } {
X pop pop
X } ifelse
X } for
X pop
X} ?def
X
X/?iexec-handle-error { % - => -
X { iexec-handle-error } if
X} def
X
X% interpretivly execute an object
X
X/iexec { % obj => ...
X 100 dict begin
X % This functions "end"s the interpreter dict, executes an object in the
X % context of the interpreted process, and "begin"'s back onto the
X % interpreter dict. Note the circularity.
X /MumbleFrotz [ % obj => ...
X /end load /exec load currentdict /begin load
X ] cvx def
X
X /ExecStack 32 array def
X /ExecSP -1 def
X
X /PushExec [ % obj => -
X /ExecSP dup cvx 1 /add load /store load
X ExecStack /exch load /ExecSP cvx /exch load /put load
X ] cvx def
X
X /PopExec [ % obj => -
X ExecStack /ExecSP cvx /get load
X /ExecSP dup cvx 1 /sub load /store load
X ] cvx def
X
X /TraceStep {
X iexec-step
X } def
X
X PushExec
X
X { ExecSP 0 lt { nullproc exit } if % nothing left to execute? goodbye.
X
X ExecStack 0 ExecSP 1 add getinterval
X TraceStep pop
X
X % pop top of exec stack onto the operand stack
X PopExec
X
X % is it executable? (else just push literal)
X dup xcheck { % obj
X % do we know how to execute it?
X dup type
X //iexec-types 1 index known { % obj type
X //iexec-types exch get exec % ...
X } { % obj type
X % some random type. just push it.
X pop % obj
X } ifelse
X } if % else: obj
X
X } loop % goodbye-proc
X
X currentdict /MumbleFrotz undef % Clean up circular reference
X end
X exec % whoever exited the above loop left a goodbye proc on the stack.
X} def
X
X% visually execute an object, dumping drawing of stacks to trace-file
X
X/vexec { % obj => ...
X { {
X (
X%!
X/l { % gray x y lastx lasty
X moveto
X 2 copy lineto
X 0 setgray
X stroke
X
X 2 copy .3 0 360 arc
X 0 setgray
X fill
X
X .25 0 360 arc
X setgray
X fill
X
X pause
X} def
X/e { % x y => -
X gsave
X translate
X 0 setlinewidth
X 360 32 div rotate
X 16 {
X 0 0 moveto
X 1 0 rlineto
X 0 setgray
X stroke
X 1 0 .1 0 360 arc
X random setgray
X fill
X 360 16 div rotate
X } repeat
X grestore
X} def
Xsystemdict /pause known not {
X /pause {} def
X} if
Xgsave
X20 20 scale
X1 1 translate
X0 setgray
X0 setlinewidth
Xerasepage
X)
X trace-print
X /TraceX 0 def
X /TraceY count 1 sub def
X /TraceZ 0 def
X /TraceStep {
X% (\() print ExecSP iexec-printexec (\)print ) trace-print
X TraceY TraceX % x y
X /TraceX ExecSP def
X /TraceY count 2 sub def
X /TraceZ TraceZ 1 add 360 mod def
X TraceZ 15 mul cos 1 add 3 div 1 exch sub trace-print#
X TraceX trace-print# TraceY trace-print#
X trace-print# trace-print# % print x,y
X (l\n) trace-print
X random .2 le { flush pause pause pause } if
X } def
X /signal-error { % name => -
X /TraceX ExecSP def
X /TraceY count 3 sub def
X TraceX trace-print# TraceY trace-print#
X (e\n) trace-print
X (grestore showpage\n) trace-print trace-flush
X /stop load PushExec
X } def
X } meta-exec
X exec
X (grestore showpage\n) trace-print trace-flush
X } iexec
X} def
X
X/trace-file (%socketc2000) (w) file def
X
X/trace-flush {
X trace-file dup null eq { pop currentfile } if
X flushfile
X} def
X
X/trace-print { % string => -
X trace-file dup null eq { pop currentfile } if
X exch writestring
X} def
X
X%/trace-print# {typedprint} def
X%/trace-print# {=} def
X/trace-print# {
X (%\n) sprintf trace-print
X} def
X
X/iexec-printexec { % index => -
X ExecStack 1 index get
X dup type /dicttype eq {
X dup /namestring known {
X begin namestring end
X } if
X } if
X exch (% %\n) printf
X} def
X
X/iexec-where {
X 0 1 ExecSP {
X iexec-printexec
X } for
X} def
X
X% execute step by step on the cyberspace deck stack display.
X% To step, execute 'exit'. (make an 'exit' button to step with the mouse).
X
X/cexec {
X { { /TraceStep {
X ExecSP
X iexec-printexec
X select-object
X /ThisStep ThisStep 1 add def
X ThisStep Steps ge {
X /ThisStep 0 def
X _SendUpdateStack
X eventloop
X } if
X null
X } def
X /Steps 1 def
X /ThisStep 0 def
X } meta-exec
X exec
X } iexec
X} def
X
X/iexec-step { % operand stack ... execee
X} def
X
X/iexec-sends { % - => context0 context1 ... contextn
X ExecSP 1 sub -1 0 {
X ExecStack exch get % ob
X dup type /dicttype eq {
X dup /continuation known {
X dup /continuation get /send eq {
X /context get
X dup null eq { pop } if
X } { pop } ifelse
X } { pop } ifelse
X } { pop } ifelse
X } for
X} def
X
X% Re-enter the NeWS PS interpreter, execute object, and return.
X% We need to construct the currentprocess's /SendStack from the interpreter's
X% send stack, so ThisWindow and other functions that look at the SendStack
X% will work.
X/iexec-reenter { % obj => ...
X mark
X /ParentDictArray where pop
X iexec-sends % obj mark context0 context1 ... contextn
X { { % obj mark context0 context1 ... contextn {func}
X 1 index mark eq { % obj mark {func}
X pop pop % obj
X {exec} stopped % ... bool
X } { % obj mark context0 context1 ... contextn {func}
X dup 3 -1 roll send % ...
X } ifelse
X } dup exec
X } MumbleFrotz
X ?iexec-handle-error
X} def
X
Xiexec-array-like-types begin
X /arraytype true def
X /packedarraytype true def
Xend % iexec-array-like-types
X
X/iexec-token { % token => ...
X dup xcheck {
X % This is the "weird" thing about PostScript:
X % If object is isn't an executable array, execute it, else push it.
X //iexec-array-like-types 1 index type known not { PushExec } if
X } if
X} def
X
Xiexec-types begin
X
X /nametype { % name => ...
X pause
X iexec-continue-names? {
X % We push a dummy name continuation on the exec stack here to
X % help with debugging, by making stack dumps more informative...
X 10 dict begin
X /continuation /name def
X /continue { % dict
X pop
X } def
X /name 1 index def
X /namestring {
X /name load cvlit (name: % *done*) sprintf
X } def
X currentdict cvx PushExec
X end
X } if
X //iexec-names 1 index known { % name
X //iexec-names exch get % func
X exec %
X } {
X % name
X {{load}stopped} MumbleFrotz {
X true ?iexec-handle-error
X } {
X PushExec
X } ifelse
X } ifelse
X } def
X
X /arraytype { % array => ...
X iexec-continue-procs? {
X 10 dict begin
X /continuation /procedure def
X /proc exch def
X /i 0 def
X /len /proc load length def
X /continue { % dict => -
X begin
X i len lt {
X currentdict cvx PushExec
X /proc load i get iexec-token
X /i i 1 add def
X } if
X end
X } def
X /namestring {
X (procedure % @ %: %)
X [ /proc load i
X 1 index length 1 index gt { 2 copy get } (*done*) ifelse
X ] sprintf
X } def
X currentdict cvx PushExec
X end
X } {
X dup length dup 0 eq { % array length
X pop pop %
X } { % array length
X 1 eq { % array
X 0 get %
X iexec-token %
X } { % array
X dup 0 get % array head
X % push rest of array to execute later
X exch 1 1 index length 1 sub getinterval % head tail
X PushExec % head
X iexec-token %
X } ifelse
X } ifelse
X } ifelse
X } def
X
X /packedarraytype /arraytype load def
X
X /stringtype { % string => ...
X dup token { % string rest token
X exch dup length 0 eq { pop } { PushExec } ifelse % string token
X exch pop % token
X iexec-token % ...
X } { % str
X dup length 0 eq {
X pop %
X } { % str
X /syntax signal-error
X } ifelse
X } ifelse
X } def
X
X /filetype { % file => -
X dup token { % file token
X exch dup % token file file
X status { PushExec } { pop } ifelse % token
X iexec-token % ...
X } { % file
X dup status {
X /syntax signal-error
X } {
X pop
X } ifelse
X } ifelse
X } def
X
X /operatortype { % operator => -
X //iexec-operators 1 index known {
X //iexec-operators exch get exec
X } {
X {{exec}stopped}
X MumbleFrotz
X ?iexec-handle-error
X } ifelse
X } def
X
X /dicttype { % dict => -
X dup /continuation known {
X dup /continue get exec
X } if
X } def
X
Xend % iexec-types
X
Xiexec-operators begin
X
X /exec load { % obj => -
X PushExec
X } def
X
X /if load { % bool proc => -
======== END OF cyber.shar.splitaf ========