don@TUMTUM.CS.UMD.EDU (Don Hopkins) (11/23/89)
======== START OF cyber.shar.splitae ========
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 } case
X /PinX LabelX LabelWidth add 2 sub store
X } def
X
X /adjust-geometry {
X /ItemLabel nice-item-label store
X LabelSize /LabelHeight exch def /LabelWidth exch def
X AdjustItemSize
X CalcObj&LabelXY
X } def
X
X /nice-item-label {
X Collection Index get
X smart-type
X (% \267) sprintf
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Display
X
X /PaintItem {
X LayoutLock {
X ItemRadius label-bbox rrectpath
X ItemFillColor setcolor fill
X ItemFrame 0 gt {
X ItemFrame ItemRadius label-bbox rrectframe
X ItemBorderColor setcolor eofill
X } if
X ItemRadius object-bbox rrectpath
X ItemFillColor setcolor fill
X ItemFrame 0 gt {
X ItemFrame ItemRadius object-bbox rrectframe
X ItemBorderColor setcolor eofill
X } if
X ShowLabel
X paint-struct
X } monitor
X } def
X
X /paint-struct {
X %{
X gsave
X ensure-DL
X ItemTextColor setcolor
X ObjectX ObjectY ObjectHeight add translate
X DL draw-struct
X grestore
X %} fork waitprocess pop
X } def
X
X /damage-view {
X gsave
X %ItemParent setcanvas bbox rectpath extenddamage
X paint
X grestore
X } def
X
X % distillery display stubs
X /_fill {fill} def
X /_eofill {eofill} def
X /_stroke {stroke} def
X /_show {show} def
X /_newpath {newpath} def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Accessers
X
X /Collection {
X ItemObject 0 get cvlit
X } def
X
X /Index {
X ItemObject 1 get cvlit
X } def
X
X /array? { % obj => bool
X type dup /arraytype eq exch /packedarraytype eq or
X } def
X
X /array-or-string-dict 5 dict def
X array-or-string-dict begin
X /arraytype dup def
X /packedarraytype dup def
X /stringtype dup def
X end % array-or-string-dict
X
X /array-or-string? { % obj => bool
X type //array-or-string-dict exch known
X } def
X
X currentdict /array-or-string-dict undef
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Structure stuff
X
X /do-search {
X /it self store
X DL begin Icon? end {
X /obs [ DL ] store
X /ob DL store
X } {
X gsave
X ObjectX ObjectY ObjectHeight add translate
X DL
X CurrentEvent begin XLocation YLocation end
X search-struct
X /obs exch store
X obs length 0 eq { null } {
X obs dup length 1 sub get
X } ifelse
X /ob exch store
X grestore
X } ifelse
X } def
X
X% Return the path down the display list to the substructure enclosing (x,y).
X /search-struct { % dict x y => [ dl1 dl2 ... dln ]
X { % keep return stack from overflowing
X 10 dict begin
X /ssy exch def /ssx exch def
X [ exch
X { do-search-struct
X % unsucessful search
X exit
X } loop % catch possible exit
X dup true eq { pop } if
X ]
X end
X } fork % dict x y process
X 4 1 roll pop pop pop
X waitprocess
X } def
X
X% This keeps overflowing the fucking execution stack in NeWS 1.1!
X /do-search-struct { % dl => dl dl' dl'' dl''' ...
X begin
X%gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore
X%pause pause
X%gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore
X ssx X ge {
X ssy Y ge {
X ssx X W add le {
X ssy Y H add le {
X currentdict end % dl
X dup /Controls get % dl controls
X dup null eq { pop } {
X { do-search-struct } forall % dl .. dn mark | dl
X dup true eq { exit } if % exit if something found
X } ifelse % dl
X dup /Branches get % dl branches
X dup null eq { pop } {
X { do-search-struct } forall % dl ... dn mark | dl
X dup true eq { exit } if % exit if something found
X } ifelse
X % We were found, but none of our children, leave true on
X % top of stack to unwind search.
X true exit
X } if
X } if
X } if
X } if
X end
X } def
X
X /do-search-struct { % dl => dl dl' dl'' dl''' ...
X begin
X%gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore
X%pause pause
X%gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore
X ssx X ge {
X ssy Y ge {
X ssx X W add le {
X ssy Y H add le {
X currentdict end % dl
X dup /Controls get % dl controls
X dup null eq { pop } {
X { do-search-struct } forall % dl .. dn mark | dl
X dup true eq { exit } if % exit if something found
X } ifelse % dl
X dup /Branches get % dl branches
X dup null eq { pop } {
X { do-search-struct } forall % dl ... dn mark | dl
X dup true eq { exit } if % exit if something found
X } ifelse
X % We were found, but none of our children, leave true on
X % top of stack to unwind search.
X true exit
X } if
X } if
X } if
X } if
X end
X } def
X
X /close-struct {
X DL /Icon? undef
X ob /L 0 put
X ob /Branches null put
X ob /Controls null put
X Silent? not { redo-layout } if
X } def
X
X% TODO: Open up special editors on different object types.
X% Numberic keypad
X% Boolean toggle
X% Color sliders
X% Font finder
X% Canvas view
X% Visual graphics state editors
X% String editor
X% CyberSpace projection
X
X% Event's XLocation YLocation should be relative to the event's Canvas, or
X% framebuffer if null.
X
X /use-parent-obj {
X obs length 1 gt {
X /obs obs 0 1 index length 1 sub getinterval store
X /ob obs dup length 1 sub get store
X } if
X } def
X
X /change-parent-obj { % func
X use-parent-obj change-obj
X } def
X
X /make-button { % dl => dl
X dup /label-proc /button-label put
X dup /display-proc /display-button put
X } def
X
X /make-edit-button { % dl => dl
X make-button
X dup /click-proc /click-edit put
X } def
X
X /make-magic-button { % dl => dl
X make-button
X dup /click-proc /click-magic put
X } def
X
X /struct-editors 50 dict def
X struct-editors begin
X
X% ------------------------------------------------------------------------
X
X /step {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X % Make fresh copies so user can change scalars
X /++ {Step add} def
X currentdict /++ cvx 0 grow-struct
X make-edit-button
X /-- {Step sub} def
X currentdict /-- cvx 0 grow-struct
X make-edit-button
X /Step 1 def
X currentdict /Step cvx 0 grow-struct
X end
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
X /shift {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X % Make fresh copies so user can change scalars
X (**) {Shift mul} def
X currentdict (**) cvn cvx 0 grow-struct
X make-edit-button
X (//) {Shift div} def
X currentdict (//) cvn cvx 0 grow-struct
X make-edit-button
X /Shift 10 def
X currentdict /Shift cvx 0 grow-struct
X end
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
X /digit {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X Controls null ne { Controls aload pop } if
X
X % Make fresh copies so user can change scalars
X
X 0 1 9 {
X dup [ /floor load 10 /mul load 5 index /add load ] cvx def
X currentdict exch 0 grow-struct
X make-edit-button
X } for
X
X /Rubout [ 10 /div load /floor load ] cvx def
X currentdict /Rubout 0 grow-struct
X make-edit-button
X
X /Clear [ /pop load 0 ] cvx def
X currentdict /Clear 0 grow-struct
X make-edit-button
X
X /+- /neg load def
X currentdict /+- cvx 0 grow-struct
X make-edit-button
X end
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
X /boolean {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X Controls null ne { Control aload pop } if
X /True true def
X currentdict /True 0 grow-struct
X make-edit-button
X /False false def
X currentdict /False 0 grow-struct
X make-edit-button
X /Not /not load def
X currentdict /Not 0 grow-struct
X make-edit-button
X /Random [/random cvx .5 /lt cvx] cvx def
X currentdict /Random 0 grow-struct
X make-edit-button
X end
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
X /element {
X open-obj-branches
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
X /filter {
X Branches null eq {
X /Branches
X C I 1 grow-struct
X 1 index get def
X } if
X
X /Controls [
X % XXX: Will this work?
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X
X /Recompute {
X ob begin
X /Obj /C load /I load get def
X end
X ContainerRef 0 ob /Obj get put
X ob /Branches [
X Container array-or-string? {
X IndexRef 0 0 put
X } if
X Container {
X ObjectRef exch 0 exch put
X Container array-or-string? {
X IndexRef 0 2 copy get 1 add put
X } {
X IndexRef exch 0 exch put
X } ifelse
X mark false
X /Filter load cvx { exec } errored { cleartomark } {
X dup type /booleantype ne { pop false } if
X { cleartomark Container Index 0 grow-struct }
X { cleartomark } ifelse
X } ifelse
X } forall
X ] Order put
X ObjectRef 0 null put
X ContainerRef 0 null put
X IndexRef 0 null put
X Silent? not { /redo-layout null self exch pop send } if
X } def
X currentdict /Recompute 0 grow-struct
X make-magic-button
X
X /ObjectRef [ null ] def
X /Object ObjectRef cvx def
X /ContainerRef [ null ] def
X /Container ContainerRef cvx def
X /IndexRef [ null ] def
X /Index IndexRef cvx def
X
X % Filters may call: Container Index Object
X /Filter % - => interesting?
X false
X def
X currentdict /Filter 0 grow-struct
X
X /Keys 100 dict def
X currentdict /Keys 1 grow-struct
X
X /Order [
X /Obj load array-or-string? /by-value /by-name ifelse
X /quicksort cvx
X ] cvx def
X currentdict /Order 0 grow-struct
X
X% /View null def
X% currentdict /View 0 grow-struct
X% counttomark 1 sub /ViewIndex exch def
X
X ] currentdict end 3 1 roll def
X
X begin Recompute end
X } def
X
X /scroller {
X Branches null eq {
X /Branches
X C I 1 grow-struct
X 1 index get def
X } if
X
X% currentdict /AllBranches known not {
X /AllBranches Branches def
X% } if
X
X /Controls [
X % XXX: Will this work?
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X
X /Recompute {
X /Offset
X Offset
X ob /Obj get length 1 sub min
X 0 max
X def
X ob /Branches
X ob /AllBranches get Offset 1 index length 1 index sub Size min
X getinterval
X put
X /Scroll
X (% : %..% of %, %) [
X ob /Str get
X Offset
X Offset ob /Branches get length add 1 sub
X ob /AllBranches get length
X 2 index 1 index div
X 100 mul round 5 string cvs (%) append
X ] sprintf
X def
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
X /Scroll (nothingness) def
X currentdict /Scroll 0 grow-struct
X
X% /Top {
X% /Offset 0 def
X% Recompute
X% } def
X% currentdict /Top 0 grow-struct
X% dup /click-proc /click-magic put
X%
X% /Bottom {
X% /Offset ob /Obj get length Size sub def
X% Recompute
X% } def
X% currentdict /Bottom 0 grow-struct
X% dup /click-proc /click-magic put
X
X /Back {
X /Offset Offset Size sub def
X Recompute
X } def
X currentdict /Back 0 grow-struct
X make-magic-button
X
X /Next {
X /Offset Offset Size add def
X Recompute
X } def
X currentdict /Next 0 grow-struct
X make-magic-button
X
X /Offset 0 def
X% currentdict /Offset 0 grow-struct
X
X /Size 10 def
X currentdict /Size 0 grow-struct
X
X Controls null ne {
X Controls aload pop
X } if
X
X ] currentdict end 3 1 roll def
X
X begin Recompute end
X } def
X
X /user {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X /User {} def
X currentdict /User 0 grow-struct
X make-edit-button
X end
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
X % Pop open pointers to instances of this name on the dictionary stack.
X /definitions {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X mark
X obs aload pop
X { dup mark eq {
X pop
X /getdictstack dialog-item send
X exit
X } {
X dup /ClassEditor known {
X begin cleartomark /C load end % ClassEditorDict
X /ClassDicts get
X /getdictstack dialog-item send append
X exit
X } {
X pop
X } ifelse
X } ifelse
X } loop
X % Remove redundant dictionaries
X 100 dict begin
X dup {null def} forall
X [ exch { % dict
X currentdict 1 index known {
X currentdict 1 index undef % dict
X } {
X pop %
X } ifelse
X } forall
X ]
X end
X
X { dup ob /Obj get known {
X ob /Obj get 0 grow-struct
X dup /label-proc /reference-label put
X } { pop } ifelse
X } forall
X ] dup length 0 eq { pop pop } { def } ifelse
X Silent? not { /redo-layout null self exch pop send } if
X } def
X
XXNeWS? {
X /class {
X ob /C get ob /I get get dup /ParentDictArray known not {pop} {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin % ClassEditorDict
X /Obj ob /C get ob /I get get def
X /Instance? Obj /ClassName known not def
X /Class Obj Instance? { /ParentDictArray get } if def
X /ClassDicts [ Class /ParentDictArray get aload pop
X Class Instance? { Obj } if ] def
X /MethodDict 1000 dict def
X /ClassVarDict 1000 dict def
X
X /Name dup Obj send def
X currentdict /Name 0 grow-struct
X
X ClassDicts {
X { Class /InstanceVars get 2 index known not {
X dup xcheck 1 index array? and {
X MethodDict 2 index dup put
X } {
X ClassVarDict 2 index dup put
X } ifelse
X } if
X pop pop
X } forall
X pause pause
X } forall
X
X currentdict /ClassDicts 0 grow-struct
X
X Instance? not {
X /SubClasses dup Class send def
X currentdict /SubClasses 0 grow-struct
X pause pause
X } if
X
X /InstanceVars [
X Class /InstanceVars get { pop (%) sprintf } forall
X ] {gt} quicksort [ exch { cvn } forall ] def
X currentdict /InstanceVars 0 grow-struct
X dup /ClassEditor true put
X pause pause
X
X /ClassVars [
X ClassVarDict { pop 80 string cvs } forall
X ] {gt} quicksort [ exch { cvn } forall ] def
X currentdict /ClassVars 0 grow-struct
X dup /ClassEditor true put
X pause pause
X
X /Methods [
X MethodDict { pop 80 string cvs } forall
X ] {gt} quicksort [ exch { cvn } forall ] def
X currentdict /Methods 0 grow-struct
X dup /ClassEditor true put
X pause pause
X
X /Obj null def
X /Class null def
X /MethodDict null def
X /ClassVarDict null def
X end % ClassEditorDict
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } ifelse
X } def
X} {
X /class {
X ob /C get ob /I get get dup /ParentDict known not {pop} {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 20 dict begin
X /Obj ob /C get ob /I get get def
X /Instance? Obj /ClassName known not def
X /Class Obj Instance? { /ParentDict get } if def
X /ClassDicts [ Obj /ParentDictArray get aload pop Obj ] def
X /MethodDict 1000 dict def
X /ClassVarDict 1000 dict def
X ClassDicts {
X { Class /InstanceVarDict get 2 index known not {
X dup xcheck 1 index array? and {
X MethodDict 2 index dup put
X } {
X ClassVarDict 2 index dup put
X } ifelse
X } if
X pop pop
X } forall
X pause pause
X } forall
X
X currentdict /ClassDicts 0 grow-struct
X
X Instance? not {
X /SubClasses [
X /SubClasses Class send { (%) sprintf } forall
X ] {gt} quicksort [
X exch {
X cvn dup where { exch get } if
X } forall
X ] def
X currentdict /SubClasses 0 grow-struct
X pause pause
X } if
X
X /InstanceVars [
X Class /InstanceVarDict get { pop (%) sprintf } forall
X ] {gt} quicksort [ exch { cvn } forall ] def
X currentdict /InstanceVars 0 grow-struct
X dup /ClassEditor true put
X pause pause
X
X /ClassVars [
X ClassVarDict { pop 80 string cvs } forall
X ] {gt} quicksort [ exch { cvn } forall ] def
X currentdict /ClassVars 0 grow-struct
X dup /ClassEditor true put
X pause pause
X
X /Methods [
X MethodDict { pop 80 string cvs } forall
X ] {gt} quicksort [ exch { cvn } forall ] def
X currentdict /Methods 0 grow-struct
X dup /ClassEditor true put
X pause pause
X
X /Obj null def
X /Class null def
X /MethodDict null def
X /ClassVarDict null def
X end
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } ifelse
X } def
X} ifelse
X
X /canvas {
X ob /C get ob /I get get type /canvastype ne {pop} {
X /Controls [
X Controls null ne {
X Controls aload pop
X } if
X 10 dict begin
X
X /CanvasBBoxView ob /C get ob /I get get def
X currentdict /CanvasBBoxView 0 grow-struct
X dup begin
X /layout-proc /layout-canvasbbox def
X /display-proc /display-canvasbbox def
X /erase-proc /erase-nothing def
X /click-proc /click-dragcanvas def
X /transfer-proc /transfer-reparent def
X end
X
X% This needs to be fixed to work under X11/NeWS.
X% But it uses too much space anyway... Needs to be its own type of editor.
X% /CanvasImageView ob /C get ob /I get get def
X% currentdict /CanvasImageView 0 grow-struct
X% dup begin
X% /layout-proc /layout-canvasimage def
X% /display-proc /display-canvasimage def
X% /erase-proc /erase-nothing def
X% /click-proc /click-dragimage def
X% /transfer-proc /transfer-reparent def
X% end
X%
X% /ViewX 0 def
X% /ViewY 0 def
X%
X% CanvasImageView canvas-rect % x y w h
X% 4 2 roll pop pop % w h
X% BigHeight min exch BigWidth min exch
X%
X% /ViewHeight exch def
X% /ViewWidth exch def
X% currentdict /ViewWidth 0 grow-struct
X% currentdict /ViewHeight 0 grow-struct
X
X /Children [
X ob /C get ob /I get get /TopChild get {
X dup null eq { pop exit } if
X dup /CanvasBelow get
X } loop
X ] def
X currentdict /Children 0 grow-struct
X end
X ] def
X Silent? not { /redo-layout null self exch pop send } if
X } ifelse
X } def
X
X% ------------------------------------------------------------------------
X
X end % struct-editors
X
X /open-editor { % name => -
X struct-editors 1 index known not { pop nhh } {
X gsave
X DL /Icon? undef
X ItemCanvas setcanvas
X ObjectX ObjectY ObjectHeight add translate
X ob begin
X struct-editors exch get exec
X end
X grestore
X } ifelse
X } def
X
X /open-struct-editor { % - => -
X gsave
X DL /Icon? undef
X ItemCanvas setcanvas
X ObjectX ObjectY ObjectHeight add translate
X ob begin
X C I get dup type dup struct-editors exch known not { pop pop } {
X struct-editors exch get exec
X } ifelse
X end
X% Silent? not { redo-layout } if
X grestore
X } def
X
X /open-struct { % levels => -
X gsave
X DL /Icon? undef
X ItemCanvas setcanvas
X ObjectX ObjectY ObjectHeight add translate
X ob begin
X grow-substruct
X end
X Silent? not { redo-layout } if
X grestore
X } def
X
X % (dl on dictstack)
X /replace-struct { % obj => -
X % Oh, lordy, lordy, lordy!
X mark exch C I 3 -1 roll
X { put } errored { cleartomark } {
X cleartomark
X C I L grow-struct
X begin
X /Branches Branches
X% /Controls Controls
X /C dup load /I dup load % /L L
X /Obj dup load /Str Str
X /X X /Y Y /W W /H H
X /Font Font
X end
X def def def def def def def def def def def % def
X } ifelse
X } def
X
X % DL on dict stack
X /grow-substruct { % l => -
X /L exch def
X /Branches
X C I L grow-struct
X 1 index get def
X } def
X
X /composite-type-dict 30 dict def
X composite-type-dict begin
X { /arraytype /dicttype /canvastype /processtype /eventtype /fonttype
X /stringtype % use special string editor
X% X11/NeWS:
X /packedarraytype /colormapentrytype /environmenttype
X /colormaptype % X11/NeWS pre-fcs bug causes panic when we open these!
X /visualtype /cursortype
X } { true def } forall
X end % composite-type-dict
X
X /composite? { % obj => bool
X type //composite-type-dict exch known
X } def
X
X /forbidden-dict 50 dict def
X forbidden-dict begin
X /Interests null def
X /Process null def
X /BuildChar null def
X /Encoding null def
X /WidthArray null def
X /ParentDictArray null def
X /ParentDict null def
X /TopCanvas null def
X /BottomCanvas null def
X /TopChild null def
X /CanvasAbove null def
X /CanvasBelow null def
X /Parent null def
X end % forbidden-dict
X
X /forbidden? {
X forbidden-dict exch known Filter? and
X } def
X
X % Collection Index Levels => dict
X /grow-struct {
X /xcurs /xcurs_m ItemCanvas setstandardcursor
X LayoutLock {
X /hourg /hourg_m ItemCanvas setstandardcursor
X do-grow-struct
X } monitor
X /xhair /xhair_m ItemCanvas setstandardcursor
X } def
X
X /object-label { % - => str
X /Obj load
X% short-name
X currentdict DL eq {
X short-name
X } {
X smart-name
X I short-name ( : ) append exch append
X } ifelse
X } def
X
X /button-label {
X Branches null eq {
X I 80 string cvs
X % Insert spaces to make button easier to press, and so round
X % caps don't overlap label.
X ( % ) sprintf
X } {
X object-label
X } ifelse
X } def
X
X /reference-label { % - => str
X /C load smart-name ( ) append
X /I load short-name append ( : ) append
X /Obj load smart-name append
X } def
X
X /do-grow-struct { % Container Index Levels => DL
X pause
X 32 dict begin
X /L exch def
X cvlit /I exch def cvlit /C exch def
X /Obj null def
X /Str make-label def % updates /Obj
X /X 0 def
X /Y 0 def
X /W 0 def
X /H 0 def
X /StrY 0 def
X /TipX null def
X /TipY null def
X L 0 gt {
X I forbidden? not {
X /Obj load dup type /stringtype ne {
X composite?
X } {pop false} ifelse
X } false ifelse
X } false ifelse {
X open-obj-branches
X currentdict /Controls known not {
X /Controls null def
X } if
X } {
X /Branches null def
X /Controls null def
X } ifelse
X currentdict end
X } def
X
X /open-obj-branches {
X /Obj load dup array-or-string? {
X /Branches exch [ exch
X { pop /Obj load counttomark 1 sub L 1 sub do-grow-struct } forall
X ] def
X } {
X /Branches exch [ exch
X { pop /Obj load exch L 1 sub do-grow-struct } forall
X ] Sort? {SortBy quicksort} if def
X } ifelse
X } def
X
X % /SortBy default:
X /by-name {
X /Str get exch /Str get lt
X } def
X
X /by-value {
X /Str get cvr exch /Str get cvr lt
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Layout
X
X /perform-layout {
X /xcurs /xcurs_m ItemCanvas setstandardcursor
X LayoutLock {
X {
X /hourg /hourg_m ItemCanvas setstandardcursor
X /ItemLabel nice-item-label store
X init-format DL do-layout
X /ObjectHeight DL /H get store
X adjust-geometry
X } fork waitprocess pop
X } monitor
X /xhair /xhair_m ItemCanvas setstandardcursor
X } def
X
X /init-format {
X /Point StartPoint def
X /x 0 def
X /y 0 def
X /ObjectWidth 0 def
X /ObjectHeight 0 def
X } def
X
X% /LineHeight {
X% Font fontheight 1 add
X% } def
X
X /do-layout { % dict => -
X begin
X /layout-proc load cvx exec
X end
X pause
X } def
X
X% /old-layout-struct { % - => -
X% /Str make-label def
X% /Obj load xcheck Point SmallPointSize gt and {
X% /Font ItemXFont Point scalefontquant def
X% } {
X% /Font Point SmallPointSize le
X% ItemSFont ItemFont ifelse Point scalefontquant def
X% } ifelse
X% Font setfont
X% /X x def
X% /Y y def
X% /W Str stringwidth pop LineGap add def
X% Branches null eq { % Icon? or
X% /H LineHeight def
X% } {
X% /x x W add store
X% Point
X% /Point Point Shrink mul store
X% Branches {
X% do-layout
X% } forall
X% /Point exch store
X% /x x W sub store
X% 0 0 % w h
X% Branches {
X% begin
X% exch W max
X% exch H add
X% end
X% } forall % W H
X% LineHeight max 1 max /H exch def
X% /TipX X W add LineGap sub def
X% /TipY Y H 2 div sub def
X% W add /W exch def
X% } ifelse
X% /Y Y H sub def
X% /StrY Y Font fontdescent add H LineHeight sub 2 div add def
X% /y Y store
X% /ObjectWidth ObjectWidth x W add LineGap sub max store
X% } def
X
X % layout-proc
X /layout-struct { % - => -
X /Str make-label def
X /Obj load xcheck Point SmallPointSize gt and {
X /Font ItemXFont Point scalefontquant def
X /LineHeight Font fontheight .5 add 1 max def
X } {
X /Font
X Point SmallPointSize le ItemSFont ItemFont ifelse
X Point scalefontquant def
X /LineHeight Font fontheight .5 add 1 max def
X } ifelse
X Font setfont
X /X x def
X /Y y def
X /W Str stringwidth pop Pad dup add add def
X /StrX X Pad add def
X Branches null eq { % Icon? or
X /H LineHeight def
X /Y Y H sub def
X /StrY Y Font fontdescent add H LineHeight sub 2 div add def
X /y Y store
X } {
X OpenToRight? {
X /x x W add Pad add LineGap add store
X /y y Pad sub store
X } {
X /x x SubStructureIndent add Pad add LineGap add store
X /y y LineHeight sub Pad sub store
X } ifelse
X Point
X /Point Point Shrink mul store
X Branches
X /do-layout load
X forall
X /Point exch store
X OpenToRight? {
X /x x W sub Pad sub LineGap sub store
X } {
X /x x SubStructureIndent sub Pad sub LineGap sub store
X } ifelse
X
X 0 % w
X Branches {
X /W get max
X } forall % W
X Branches length 0 eq {
X 0 % W H
X /TipY Y H 2 div sub def
X } {
X Branches 0 get begin Y H add end % TopY
X Branches dup length 1 sub get /Y get % TopY BottomY
X 2 copy add 2 div % TopY BottomY TipY
X /TipY exch def % TopY BottomY
X sub % W H
X } ifelse
X
X OpenToRight? { % W H
X LineHeight max 0 max Pad dup add add /H exch def
X% LineHeight max 0 max /H exch def
X /TipX X W add Pad add def
X W add Pad add LineGap add
X /W exch def
X /Y Y H sub Pad sub def
X /StrY
X Y Font fontdescent add H Pad sub LineHeight sub 2 div add Pad add
X def
X /y Y store
X } { % W H
X 1 max LineHeight add Pad dup add add /H exch def
X /TipX x SubStructureIndent add Pad add def
X SubStructureIndent add Pad add LineGap add W max Pad add
X /W exch def
X /Y Y H sub def
X /StrY
X Y Font fontdescent add H LineHeight sub add
X def
X /y Y store
X } ifelse
X } ifelse
X
X Controls null ne {
X /x x SubStructureIndent add store
X% /x x LineGap 2 div add store
X /y y Pad sub store % XXX?
X Point
X /Point Point Shrink mul store
X Controls
X /do-layout load
X forall
X /Point exch store
X% /x x LineGap 2 div sub store
X /x x SubStructureIndent sub store
X
X 0 % w
X Controls {
X /W get max
X } forall % W
X
X Controls length 0 eq {
X 0 % W H
X } {
X Controls 0 get begin Y H add end % TopY
X Controls dup length 1 sub get /Y get % TopY BottomY
X sub % W H
X } ifelse
X
X /Y Y 2 index sub Pad dup add sub def
X% /H exch H add def /W exch LineGap 2 div add W max def
X /H exch H add Pad dup add add def
X /W exch SubStructureIndent add Pad add W max def
X /y Y store
X } if
X
X /ObjectWidth ObjectWidth x W add max store
X } def
X
X /canvas-rect { % can => w h
X gsave
X setcanvas
X clippath pathbbox points2rect
X grestore
X } def
X
X % layout-proc
X /layout-canvasbbox {
X /Str make-label def
X /Font ItemFont Point scalefontquant def
X C I get dup type /canvastype ne { pop 1 1 } {
X % size of parent or of self if null parent
X dup /Parent get dup null ne { exch } if
X pop canvas-rect % x y w h
X 4 2 roll pop pop % w h
X } ifelse
X /ParentH exch def /ParentW exch def
X /LineHeight Point 5 mul 1 max def
X /H LineHeight Pad dup add add def % why the extra pad???
X /W LineHeight ParentH div ParentW mul Pad dup add add def
X /X x def
X /Y y H sub def
X /y Y store
X /ObjectWidth ObjectWidth x W add max store
X } def
X
X % layout-proc
X /layout-canvasimage {
X /Str make-label def
X /Font ItemFont Point scalefontquant def
X% C I get dup type /canvastype ne { pop 1 1 } {
X% % size of parent or of self if null parent
X% dup /Parent get dup null ne { exch } if
X% pop canvas-rect % x y w h
X% 4 2 roll pop pop % w h
X% } ifelse
X /LineHeight Point 5 mul 1 max def
X /H C /ViewHeight get Pad dup add add def
X /W C /ViewWidth get Pad dup add add def
X /X x def
X /Y y H sub def
X /y Y store
X /ObjectWidth ObjectWidth x W add max store
X } def
X
X /transfer-reparent {
X % if it's a canvas, and we're a canvas, reparent it into our canvas.
X % XXX: TODO!
X } def
X
X /draw-struct { % dict => -
X pause
X begin
X Icon? {
X gsave
X Font setfont
X 0 Font fontdescent IconH sub
X 2 copy moveto
X Str _show
X translate
X -2 ItemRadius
X Str stringbbox points2rect
X insetrrect rrectpath
X 0 setlinewidth
X 0 setgray
X _stroke
X grestore
X } {
X gsave
X % get default if not defined (don't use parent's)
X currentdict /display-proc known {
X /display-proc load
X } {
X self /display-proc get
X } ifelse
X cvx exec
X grestore
X } ifelse
X end
X } def
X
X% The arcto's trigger a pathforall bug with still.ps ...
X % display-proc
X /bad-display-button {
X _newpath
X X Y 1 add moveto
X X W add Y 1 add % x1 y1
X 2 copy H 2 div add % x1 y1 x2 y2
X Pad arcto pop pop pop pop %
X X W add Y H add % x1 y1
X X Y H add % x1 y1 x2 y2
X Pad arcto pop pop pop pop
X X Y H add lineto
X _stroke
X display-tree-struct
X } def
X
X % display-proc
X /display-button {
X _newpath
X X Y 1 add moveto
X% X Y moveto
X W Pad sub 0 rlineto
X Pad Pad rlineto
X% 0 H Pad dup add sub rlineto
X 0 H Pad dup add sub 1 sub rlineto
X Pad neg Pad rlineto
X Pad W sub 0 rlineto
X _stroke
X display-tree-struct
X } def
X
X /display-tree-struct {
X show-obj
X Branches null ne {
X show-structure-lines
X show-insides
X } if
X Controls null ne {
X show-control-lines
X show-controls
X } if
X } def
X
X /display-canvasbbox {
X X Pad add Y Pad add translate
X W Pad dup add sub ParentW div
X H Pad dup add sub ParentH div scale
X _newpath
X 0 0 ParentW ParentH rectpath
X .5 setgray _fill
X C I get % can
X dup type /canvastype eq { dup /Parent get null eq } true ifelse {
X pop
X } {
X gsave
X dup /Parent get setcanvas
X dup getcanvaslocation
X grestore
X translate
X canvas-rect % x y w h
X rectpath %
X 0 setgray
X _fill
X } ifelse
X } def
X
X /display-canvasimage {
X X Y translate
X _newpath
X 0 0 W H rectpath
X gsave .5 setgray _fill grestore
X 0 setgray _stroke
X Pad Pad translate
X 0 0 W Pad dup add sub H Pad dup add sub rectpath
X clip
X _newpath
X C I get % can
X dup type /canvastype eq { dup /Parent get null eq } true ifelse {
X pop
X } {
X gsave
X dup canvas-rect % x y w h
X C /ViewX get neg C /ViewY get neg translate
X scale % x y
X pop pop %
X imagecanvas
X grestore
X } ifelse
X } def
X
X /show-obj {
X Font setfont
X StrX StrY moveto
X Str _show
X } def
X
X % erase-proc
X /erase-nothing { } def
X
X % erase-proc
X /erase-label {
X gsave
X Font setfont
X StrX StrY translate
X Str stringbbox points2rect % x y w h
X exch Pad add exch % fudge the width
X rectpath
X% X Y W H rectpath
X 1 setgray fill
X grestore
X } def
X
X /erase-lines {
X Branches null ne {
X Branches length 0 ne {
X gsave
X newpath
X TipX 1 sub Y Branches 0 get /X get TipX sub 2 add H rectpath
X 1 setgray fill
X grestore
X } if
X } if
X } def
X
X /old-change-label { % str => -
X gsave
X Font setfont
X Str stringwidth pop
X exch /Str exch def
X Str stringwidth pop
X exch sub
X dup 0 eq Branches null eq or {
X pop show-obj
X } {
X erase-lines
X /TipX exch TipX add def
X TipX
X Branches 0 get /X get Pad 4 mul sub TipX lt {
X /TipX TipX LineGap add def
X /redo-layout null self exch pop send
X } {
X show-structure-lines
X show-obj
X } ifelse
X } ifelse
X grestore
X } def
X
X /change-label { % str => -
X OpenToRight? { old-change-label } {
X /Str exch def
X show-obj
X } ifelse
X } def
X
X% /show-structure-lines {
X% TipX TipY
X% Branches length 0 eq {
X% 2 copy moveto Pad dup rlineto
X% moveto Pad dup neg rlineto
X% _stroke
X% } {
X% Branches 0 get % first
X% begin
X% 2 copy moveto
X% X Pad sub Y H add lineto
X% Pad 5 mul 0 rlineto
X% _stroke
X% end
X% ShowFan? {
X% Branches 0 1 index length 1 sub getinterval {
X% begin
X% 2 copy moveto
X% X Pad sub Y lineto
X% Pad 2 mul 0 rlineto
X% _stroke
X% end
X% } forall
X% } if
X% Branches dup length 1 sub get begin
X% moveto
X% X Pad sub Y lineto
X% Pad 5 mul 0 rlineto
X% _stroke
X% end
X% } ifelse
X% OpenToRight? not {
X% TipX TipY moveto
X% Pad neg 0 rlineto
X% TipX Pad sub StrY Font fontdescent sub lineto
X% _stroke
X% } if
X% } def
X%
X /show-structure-lines {
X Branches length 0 eq {
X TipX TipY moveto Pad 0 rlineto
X _stroke
X } {
X C I get dup type /arraytype ne { pop } {
X xcheck {
X % draw { }
X% TODO: Make braces!
X Branches 0 get begin Y H add end % TopY
X Branches dup length 1 sub get /Y get % TopY BottomY
X sub 2 div % FanHeight
X TipX LineGap add % FanHeight x
X TipY 2 index add % FanHeight x y
X moveto % FanHeight
X LineGap neg 1 index -2 div rlineto
X LineGap 4 div % FanHeight dx
X 1 index -4 div % FanHeight dx dy
X rlineto % FanHeight
X
X TipX LineGap add % FanHeight x
X TipY 2 index sub % FanHeight x y
X moveto % FanHeight
X LineGap neg 1 index 2 div rlineto
X LineGap 4 div % FanHeight dx
X 1 index 4 div % FanHeight dx dy
X rlineto % FanHeight
X pop %
X _stroke
X } {
X % draw [ ]
X TipX LineGap add % x
X Branches 0 get begin Y H add end % x y
X moveto %
X LineGap neg 0 rlineto
X TipX % x
X Branches dup length 1 sub get /Y get % x y
X lineto %
X LineGap 0 rlineto
X _stroke
X } ifelse
X } ifelse
X TipX TipY % x y
X Branches 0 get begin
X 2 copy moveto
X X Y H add lineto
X Pad 5 mul 0 rlineto
X _stroke
X end
X ShowFan? {
X Branches 0 1 index length 1 sub getinterval {
X begin
X 2 copy moveto
X X Y lineto
X Pad 2 mul 0 rlineto
X _stroke
X end
X } forall
X } if
X Branches dup length 1 sub get begin
X moveto %
X X Y lineto
X Pad 5 mul 0 rlineto
X _stroke
X end
X } ifelse
X TipX TipY moveto
X Pad neg 0 rlineto
X OpenToRight? not {
X TipX Pad sub StrY Font fontdescent sub lineto
X } if
X _stroke
X } def
X
X /show-insides {
X Branches {
X draw-struct
X } forall
X } def
X
X /show-control-lines {
X Controls null ne {
X Controls length 0 ne {
X Controls dup length 1 sub get begin
X X dup
X Y moveto
X end
X StrY Font fontdescent sub lineto
X 0 setgray
X _stroke
X } if
X } if
X } def
X
X /show-controls {
X Controls {
X draw-struct
X } forall
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Printing
X
X /write-DL {
X DL print-struct
X } def
X
X /print-struct {
X { LayoutLock {
X
X gsave
X ItemCanvas setcanvas
X erasepage
X% ObjectX ObjectY ObjectHeight add translate
X StillDict begin
X 10 dict begin
X /_usefont? true def
X /_out? true def
X /_output_tx -30 def
X /_output_ty -30 def
X /_output_sx 1 def
X /_output_sy 1 def
X _stillbegin
X
X% ItemRadius label-bbox rrectpath
X label-bbox rectpath
X ItemFillColor setcolor _fill
X ItemFrame 0 gt {
X% ItemFrame ItemRadius label-bbox rrectframe
X ItemFrame label-bbox rectframe
X ItemBorderColor setcolor _eofill
X } if
X% ItemRadius object-bbox rrectpath
X object-bbox rectpath
X ItemFillColor setcolor _fill
X ItemFrame 0 gt {
X% ItemFrame ItemRadius object-bbox rrectframe
X ItemFrame object-bbox rectframe
X ItemBorderColor setcolor _eofill
X } if
X
X% ShowLabel:
X ItemLabel ItemTextColor LabelX LabelY ItemLabelFont
X gsave
X setfont translate setcolor
X 0 0 moveto
X % Assuming a string Thing...
X 0 currentfont fontdescent rmoveto _show
X grestore
X
X ItemTextColor setcolor
X ObjectX ObjectY ObjectHeight add translate
X
X 0 setlinewidth
X DL draw-struct
X _stillend
X end % 10 dict
X end % StillDict
X grestore
X
X } monitor
X
X } fork waitprocess pop
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Stack stuff
X
X /execute-it { % obj => -
X /exec-and-update dialog-item send
X } def
X
X /TellStack { % message => -
X createevent begin
X /Name exch def
X /ClientData Index def
X /Action StackI def
X /Canvas ItemParent def
X currentdict end sendevent
X } def
X
X /pack {
X StackI null ne {
X /PackStack items StackI get send
X } if
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Snap dragging
X
X /pinned? { % y h => bool
X location pop PinX add 3 1 roll % x y h
X 6 exch % x y w h
X pin-rect rectsoverlap
X } def
X
X % items backgroundcolor => - (interactively move item)
X /moveinteractive {
X ItemBegin
X 10 dict begin
X /GA_constraint 0 def
X /GA_value /calc_GA_value load def
X currentcursorlocation
X /DY exch def /DX exch def
X ItemCanvas /Transparent get {
X fillcanvas % items
X /bbox self send % items x y w h
X true dragcanvas currentcanvas mapcanvas
X
X % paint all items overlapping old item bbox & newly moved item
X % the mark ugly is just to avoid a local var dict; mainly
X % because of the self call above.
X mark 6 -1 roll { % x y w h mark <k> item
X counttomark 2 eq {exch pop} if % x y w h mark item
X exch pop % x y w h item
X 5 copy % x y w h item x y w h item
X /bbox exch send rectsoverlap 1 index self eq or
X {/paint exch send} {pop} ifelse
X mark % x y w h mark
X } forall
X 5 {pop} repeat
X } {
X currentcanvas mapcanvas false dragcanvas
X% true dragcanvas currentcanvas mapcanvas
X pop pop
X } ifelse
X end
X ItemEnd
X } def
X
X /SnapIn {
X ThisI StackI ne {
X StackI null ne {
X /PopMe TellStack
X } if
X /StackI ThisI store
X /PushMe TellStack
X } if
X } def
X
X /SnapOut {
X StackI null ne StackI Index ne and {
X /PopMe TellStack
X /StackI null store
X } if
X } def
X
X /snaps-here? { % - => bool
X ThisI null eq ThisI Index eq or {false} {
X /pin-rect dialog-item send
X label-rect
X rectsoverlap dup {
X SnapIn
X } {
X SnapOut
X } ifelse
X } ifelse
X } def
X
X /calc_GA_value {
X StackI Index eq {
X currentcursorlocation pop % cx
X } {
X StackI null eq {
X snaps-here? {
X location
X pop DX add % ix
X } {
X currentcursorlocation pop % cx
X } ifelse
X } {
X location TabY add TabHeight
X /pinned? items StackI get send not {
X SnapOut
X pop currentcursorlocation pop % cx
X } { % ix
X { location pop PinX add } items StackI get send % ItemX PinX
X PinX sub % ItemX ItemGoal
X exch 1 index exch sub % ItemGoal ItemDelta
X currentcursorlocation pop % ItemGoal ItemDelta CurX'
X 2 index exch sub % ItemGoal ItemDelta CurDelta
X DX add dup abs TabWidth gt {
X SnapOut
X pop pop pop currentcursorlocation pop DX sub
X } {
X 1 index abs 1 index abs gt {exch} if % ItemGoal Close Far
X pop % ItemGoal Close
X% .2 mul sub
X sub
X } ifelse
X DX add
X } ifelse
X } ifelse
X } ifelse
X } def
X
X /NextPos { % - => x y
X location % x y
X label-bbox % X Y x y w h
X exch pop add % X Y x y+h
X 3 -1 roll add % X x Y+y+h
X exch 3 -1 roll add exch % X+x Y+y+h
X exch PinX add exch
X } def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Storage managment
X
X /Free {
X SnapOut
X ItemCanvas /Retained false put
X unmap
X /DL null store
X% /ItemObject [[null] 0] store
X ItemLock {
X /free-items [
X free-items aload pop Index
X ] store
X } monitor
X } def
X
X /init-attributes {
X { /ObjectWidth /DL /Shrink
X /layout-proc /click-proc /transfer-proc /display-proc /erase-proc
X /Point /OpenToRight? /ShowFan?}
X { InstanceVarDict 1 index get store } forall
X /ObjectLoc /Right store
X self /StartPoint undef
X adjust-geometry
X } def
X
X % obj => -
X /Reuse {
X Collection Index 3 -1 roll put
X ItemCanvas /Retained true put
X ItemCanvas canvastotop
X init-attributes
X %ensure-DL
X %redo-layout
X } def
X
X /destroy {
X ItemCanvas /Retained false put
X unmap
X ItemEventMgr null ne {
X ItemEventMgr killprocess
X } if
X } def
X
Xclassend def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Pallets of useful functions
X
X% Pallets are meant to be pushed onto the stack, opened up, and used
X% like control panels by clicking on the functions. Double click the
X% point button, or set the click-action to click-exec, and clicking
X% the Adjust button. (After a few revolutions, the pallets will
X% automatically have click-exec actions, and the functions will look
X% like buttons. (By virtue of a general purpose view-saving facility.))
X
X/Pallets 100 dict def
X
XPallets begin
X
X /Debug dictbegin
X
X /break-exit { dbgexit dstack } def
X /break-kill { dbgkill dstack } def
X /break-list /dbglistbreaks load def
X /break-enter { dbgenter dstack } def
X /break-cont { dbgcontinue dstack } def
X /break-copy&cont { dbgcopystack dbgcontinue dstack } def
X
X /clear /clear load def
X /enter-it { selected-object enter } def
X /exit /exit load def
X
X
X /fix-typo { % undefined (select correct spelling) => -
X userdict begin
X dup cvlit [ selected-object (%) sprintf cvn cvx ] cvx def
X end
X exec
X } def
X
X /push-dictstack { currentprocess /DictionaryStack get } def
X /push-execstack {DbgImplicitBreak DbgGetExecStack} def
X /push-process { DbgImplicitBreak } def
X
X /show-dictstack { dstack } def
X /show-execstack /dbgwhere load def
X
X dictend def
X
X /Window 20 dict begin
X /make-a-window! {
X /win
X framebuffer /new DefaultWindow send
X def
X { newprocessgroup
X /reshapefromuser win send
X /map win send
X } fork waitprocess pop
X /can /ClientCanvas win send def
X (%% The new window is called "win".\n) print
X (%% Its ClientCanvas is called "can".\n) print
X (%% Setting the currentcanvas to "can", ) print currentcanvas ==
X can setcanvas
X } def
X dictend def
X
X /Menu dictbegin
X /dict-select {
X selected-object dup type /dicttype ne { pop } {
X [ exch
X {
X 1 index type /nametype eq {
X exch
X 40 string cvs
X exch
X } if
X [ exch [ exch ] 0 /get load /select-object cvx ] cvx
X } forall
X ] /new DefaultMenu send
X dup /MenuButton AdjustButton put
X dup /AdjustButton MenuButton put
X gsave
X framebuffer setcanvas
X currentcursorlocation /showat 4 -1 roll send
X grestore
X } ifelse
X } def
X dictend def
X
Xend % Pallets
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% StructItem Menu definitions
X
X/nhh {
X gsave
X framebuffer setcanvas
X currentcursorlocation
X [ (Nothing)(Happens)(Here!) ] popmsg pop
X grestore
X} def
X
XXNeWS? {
X /MakePointSizeThings { % - => ...things...
X {1 3 5 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 28 30 32 34}
X {
X [ exch dup 3 string cvs exch
X { dup SmallPointSize le ItemSFont ItemFont ifelse } StructItem send
X exch scalefontquant ]
X } forall
X } def
X} {
X /MakePointSizeThings { % - => ...things...
X {1 2 4 6 8 10 12 14 16 18 20 22 24 28 32} {
X [ exch dup 3 string cvs exch
X { dup SmallPointSize le ItemSFont ItemFont ifelse } StructItem send
X exch scalefontquant ]
X } forall
X } def
X} ifelse
X
X/TabLocationMenu [
X (LeftBelow) (LeftAbove) (AboveLeft) (AboveRight)
X (RightAbove) (RightBelow) (BelowRight) (BelowLeft)
X] [
X { currentkey cvn
X {/ObjectLoc exch def location 10 10 reshape damage-view}
X it send }
X] /new CyberMenu send store
XTabLocationMenu /PieInitialAngle 360 16 div put
X
X/TabClickMenu [
X (click-transfer) (click-type)
X (click-exec) (click-magic) (click-push)
X (click-step) (click-select) (click-edit)
X] [
X {currentkey cvn {/click-proc exch def} it send}
X] /new CyberMenu send def
X
X/ClickMenu [
X (click-transfer) (click-type)
X (click-exec) (click-magic) (click-push)
X (click-step) (click-select) (click-edit)
X] [
X {ob /click-proc currentkey cvn dup /null eq {pop undef} {put} ifelse}
X] /new CyberMenu send def
X
X/TabViewMenu [
X [ MakePointSizeThings ] % point size
X [ (true) (false) ] % fan
X [ (0) (1) (2) (3) (4) (5) (6) (7) (8) ] % open
X [ (/Below) (/Right) ] % direction
X [ 10 5 200 { 100 div 10 string cvs } for ] % shrink
X nullarray % ---
X nullarray % ---
X nullarray % click...
X] [
X (point size)
X {getmenuarg 0 get cvx exec {/StartPoint exch def redo-layout} it send}
X (fan) { getmenuarg cvx exec {/ShowFan? exch def paint}
X it send }
X (open) { getmenuarg cvi
X { DL null eq { pop } {
X /ob DL store
X open-obj
X } ifelse
X } it send }
X (direction) { getmenuarg cvx exec /set-open-direction it send}
X (shrink) { getmenuarg cvx exec
X 1000 mul floor 1000 div % X11/NeWS .9499 bug
X {/Shrink exch def redo-layout}
X it send }
X (---) {}
X (---) {}
X (click...) TabClickMenu
X] /new PulloutCyberMenu send def
XTabViewMenu /LabelMinRadius 35 put
X%TabViewMenu /PieInitialAngle 135 put
X
X/ViewMenu [
X [ MakePointSizeThings (/Default) ] % point size
X [ (true) (false) (/Default) ] % fan
X [ (0) (1) (2) (3) (4) (5) (6) (7) (8) ] % open
X [ (/Below) (/Right) (/Default) ] % direction
X [ 10 5 200 { 100 div 10 string cvs } for (/Default) ] % shrink
X nullarray % ---
X nullarray % ---
X nullarray % click...
X] [
X (point size) {getmenuarg 0 get cvx exec /pointsize-obj it send}
X (fan) {getmenuarg cvx exec {set-show-fan paint} it send}
X (open) {getmenuarg cvi /open-obj it send}
X (direction) {getmenuarg cvx exec {set-open-direction redo-layout}
X it send}
X (shrink) { getmenuarg cvx exec
X /shrink-obj it send}
X (---) { }
X (---) { }
X (click...) ClickMenu
X] /new PulloutCyberMenu send def
XViewMenu /LabelMinRadius 35 put
X%ViewMenu /PieInitialAngle 135 put
X
X/TabMenu [
X (Layout) {/redo-layout it send}
X (Tab...) TabLocationMenu
X (Zap) {/Free it send}
X (Paint) {/paint it send}
X (Print) {/write-DL it send}
X (View...) TabViewMenu
X] /new CyberMenu send store
X
X/ConvertMenu [
X (tokein) { /tokein-obj it send }
X (executable) { /cvx-obj it send }
X (name) { /cvn-obj it send }
X (string) { /cvs-obj it send }
X (tokeout) { /tokeout-obj it send }
X (literal) { /cvlit-obj it send }
X (integer) { /cvi-obj it send }
X (real) { /cvr-obj it send }
X] /new CyberMenu send def
X
X/SelectMenu [
X (Pointer) { ob /C get ob /I get kbd-select-pointer }
X (Index) { ob /I get kbd-select-object }
X (Object) { ob /C get ob /I get get kbd-select-object }
X (Container) { ob /C get kbd-select-object }
X] /new CyberMenu send def
X
X/OpenMenu [
X nullarray
X [ (1) (2) (3) (4) ]
X [ (1) (2) (3) (4) ]
X nullarray
X] [
X (---) {}
X (right) {getmenuarg cvi /open-right-obj it send}
X (below) {getmenuarg cvi /open-below-obj it send}
X (close) {0 /open-obj it send}
X] /new PulloutCyberMenu send def
X
X/GutsMenu [
X (it: item) { it kbd-select-object }
X (DL: item's DL) { /DL it send kbd-select-object }
X (userdict) { userdict kbd-select-object }
X (ob: DL object) { ob kbd-select-object }
X (obs: DL path) { obs kbd-select-object }
X] /new CyberMenu send def
X
X/EtcMenu [
X (molecule) { /molecule-obj it send }
X (select...) SelectMenu
X% (reference) { /reference-obj it send }
X (load) { /load-obj it send }
X (guts...) GutsMenu
X] /new CyberMenu send def
X
X/TypeFont /Screen findfont 12 scalefontquant def
X
X/StructMenu [
X nullarray
X [ [ { [ ob /Obj get type 30 string cvs
X 0 1 index length 4 sub getinterval % chop "type"
X TypeFont
X ] exch pop dup type exec
X }
X ]
X ]
X nullarray nullarray nullarray nullarray nullarray nullarray
X] [ % Note: depends on fixed getmenuarg
X (push) {/push-obj it send}
X (type...) /FigureTypeAction cvx
X% (load) {/load-obj it send}
X (open...) OpenMenu
X (etc...) EtcMenu
X (exec) {/exec-obj it send}
X (convert...) ConvertMenu
X (paste) {/paste-obj it send}
X (view...) ViewMenu
X]
X/new PulloutCyberMenu send def
X{ /LabelMinRadius 25 def
X /FigureTypeAction {
X ob /Obj get type TypeActionDict 1 index known {
X TypeActionDict exch get cvx exec
X } {
X% pop { /nhh it send }
X OtherMenu
X } ifelse
X } def
X} StructMenu send
X
X/PalletMenu
X [ Pallets { pop 100 string cvs } forall ] {lt} quicksort
X [ { currentkey cvn { Pallets exch get push-it } dialog-item send } ]
X /new CyberMenu send
Xdef
X
X/CommandMenu [
X (wet) {}
X (paint) {}
X] /new CyberMenu send def
X
X/BreakMenu [
X (userdict) { { clear countdictstack 2 sub { end } repeat
X userdict /CyberUserdict dbgbreak } fork pop }
X (stack) { { clear dialog-item
X /CyberStack /dbgbreak dialog-item send } fork pop }
X (window) { { clear win
X /CyberWindow /dbgbreak win send } fork pop }
X (struct) { { clear items 0 get
X /CyberStruct /dbgbreak 2 index send } fork pop }
X] /new CyberMenu send def
X
X/DialogMenu [
X nullarray
X [ MakePointSizeThings ]
X [(7) (11) (13) (15)]
X nullarray
X nullarray
X nullarray
X] [
X (dbgbreak...) BreakMenu
X (object size) {StructItem /StartPoint getmenuarg 0 get cvi put}
X (text size) {null getmenuarg cvi /changefont dialog-text send}
X (pack stack) {/PackStack it send}
X (reboot process) {/kbd-reboot dialog-item send}
X (reset input) {/kbd-reset it send}
X% (credits) { /display-credits win send }
X] /new PulloutCyberMenu send def
X
X/SelectionMenu [
X (push) {{Collection Index get push-it} it send}
X (load) {{Collection Index get load-it} it send}
X (exec) {{Collection Index get exec-it} it send}
X% (convert...) /ConvertMenu StructItem send
X (convert...) ConvertMenu
X] /new CyberMenu send def
X
X/BackgroundMenu [
X (Pallets...) PalletMenu
X (Framebuffer) { /push-framebuffer-children dialog-item send }
X (Canvases) { /push-selected-canvases dialog-item send }
X (Windows) { /push-windows dialog-item send }
X (Commands...) CommandMenu
X (Processes) { /push-processes dialog-item send }
X (Stack...) DialogMenu
X (Object) { /push-object dialog-item send }
X] /new CyberMenu send def
X
X/Types {
X nulltype integertype realtype booleantype colortype marktype
X operatortype nametype stringtype shapetype monitortype
X graphicsstatetype cursortype filetype arraytype dicttype
X fonttype canvastype processtype eventtype
X% X11/NeWS:
X savetype packedarraytype colormapentrytype environmenttype
X colormaptype pathtype visualtype vmtype
X} def
X
X/TypeActionDict 50 dict def
XTypeActionDict begin
X /integertype /IntegerMenu def
X /realtype /RealMenu def
X /booleantype /BooleanMenu def
X /colortype /ColorMenu def
X /nametype /NameMenu def
X /stringtype /StringMenu def
X /graphicsstatetype /GraphicsstateMenu def
X /arraytype /ArrayMenu def
X /dicttype /DictMenu def
X /fonttype /FontMenu def
X /canvastype /CanvasMenu def
X /processtype /ProcessMenu def
X /eventtype /EventMenu def
X% /filetype /FileMenu def
X% /shapetype /ShapeMenu def
X% /cursortype /CursorMenu def
X% /monitortype /MonitorMenu def
X% /operatortype /OperatorMenu def
X% /nulltype /NullMenu def
X% /marktype /MarkMenu def
X% X11/NeWS:
X% /savetype /SaveMenu def
X /packedarraytype /ArrayMenu def
X% /colormapentrytype /ColormapentryMenu def
X% /environmenttype /EnvironmentMenu def
X% /colormaptype /ColormapMenu def
X% /pathtype /PathMenu def
X% /visualtype /VisualMenu def
Xend % TypeActionDict
X
X% =======================================================================
X% Type menus
X
X/IntegerMenu [
X (step editor) {/step /open-editor it send}
X (shift editor) {/shift /open-editor it send}
X (digit editor) {/digit /open-editor it send}
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X/RealMenu IntegerMenu def
X% /RealMenu [
X% (step editor) {/step /open-editor it send}
X% (shift editor) {/shift /open-editor it send}
X% (digit editor) {/digit /open-editor it send}
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X
X/BooleanMenu [
X (true) {true /modify-obj it send}
X (false) {false /modify-obj it send}
X (not) {{not} /transform-obj it send}
X (boolean editor) {/boolean /open-editor it send}
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X/ColorMenu [
X (user editor) {/user /open-editor it send}
X% put color pie menu here!
X] /new CyberMenu send def
X
X/NameMenu [
X (definitions editor) {/definitions /open-editor it send}
X (user editor) {/user /open-editor it send}
X% pop up menu of definitions?
X] /new CyberMenu send def
X
X/GraphicsstateMenu [
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X/JuggleArrayMenu [
X (pop) { /pop-array-obj it send } % to selection
X % rotate array member or subinterval to top
X (top) { /top-array-obj it send }
X % splice array member or unsplice subinterval
X (splice) { /splice-array-obj it send }
X % rotate array member or subinterval to bottom
X (bottom) { /bottom-array-obj it send }
X (push) { /push-array-obj it send } % selected object
X (append) { /append-to-array-obj it send } % selected array
X % selected array member or subinterval
X (delete) { /delete-array-obj it send }
X (prepend) { /prepend-to-array-obj it send } % selected array
X] /new CyberMenu send def
X
X/ArrayMenu [
X (juggle...) JuggleArrayMenu
X (element editor) {/element /open-editor it send}
X (scroller) {/scroller /open-editor it send}
X (filter editor) {/filter /open-editor it send}
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X/StringMenu ArrayMenu def
X% /StringMenu [
X% (array...) ArrayMenu
X% (prepend) {nhh} % selected string
X% (append) {nhh} % selected string
X% (token) {nhh} % selected string
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X
X/DictMenu [
X (def) { /def-in-dict-obj it send } % selected object
X (undef) { /undef-in-dict-obj it send } % selected key (or pointer index)
X (begin) { /begin-obj it send }
X (enter) { /enter-obj it send }
X (dbgbreak) { /break-obj it send }
X (scroller) {/scroller /open-editor it send}
X (filter editor) {/filter /open-editor it send}
X (user editor) {/user /open-editor it send}
X (class editor) {/class /open-editor it send}
X] /new CyberMenu send def
X
X/FontMenu [
X (class editor) {/class /open-editor it send}
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X/CanvasStateMenu [
X (top) {ob /C get ob /I get get canvastotop}
X (map) {ob /C get ob /I get get /Mapped true put}
X (retain) {ob /C get ob /I get get /Retained true put}
X (unmap) {ob /C get ob /I get get /Mapped false put}
X (bottom) {ob /C get ob /I get get canvastobottom}
X (opaque) {ob /C get ob /I get get /Transparent false put}
X (unretain) {ob /C get ob /I get get /Retained false put}
X (transparent) {ob /C get ob /I get get /Transparent true put}
X] /new CyberMenu send def
X
X/CanvasMenu [
X (state...) CanvasStateMenu
X% (manager) {nhh} % select /Interests 0 /Process
X% (bbox) {nhh} % select [x y w h]
X% (setcanvas) {nhh} % changes proc's gstate
X% (zap) {nhh} % unretain & unmap whole tree
X (class editor) {/class /open-editor it send}
X (canvas editor) {/canvas /open-editor it send}
X (scroller) {/canvas /open-editor it send}
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X/ProcessMenu [
X% XXX: Implement these!!!
X% (kill) {nhh}
X% (kill group) {nhh}
X% (suspend) {nhh}
X% (resume) {nhh}
X% (wait) {nhh} % select return value
X% (userdict) {nhh} % select userdict
X (class editor) {/class /open-editor it send}
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X/EventMenu [
X% XXX: Implement these!!!
X% (express) {nhh} % Does this make any sense in this context?
X% (revoke) {nhh}
X% (sendevent) {nhh}
X (class editor) {/class /open-editor it send}
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X% /FileMenu [
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X%
X% /ShapeMenu [
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X%
X% /CursorMenu [
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X%
X% /MonitorMenu [
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X%
X% /OperatorMenu [
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X%
X% /NullMenu [
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X%
X% /MarkMenu [
X% (user editor) {/user /open-editor it send}
X% ] /new CyberMenu send def
X
X/OtherMenu [
X (user editor) {/user /open-editor it send}
X] /new CyberMenu send def
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% TextStructItem class definition
X
X/TextStructItem StructItem
Xdictbegin
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Instance variables
X
X /I null def
X /MyStack null def
X /MyProcess null def
X /Scroller null def
X /ScrollerWidth 18 def
X /Notifier null def
X /NotifierHeight 24 def
X /SubItemGap 2 def
X /SubItemMgr null def
X /DeferedUpdateEvent null def
X /UpdateDelay .5 60 div def
X /PinHeight 0 def
X /DropShadow 6 def
Xdictend
Xclassbegin
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Class Variables
X
X%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
X% Methods
X
X /new {
X /new super send begin
X /MyStack [] def
X /ItemLabel (Stack \267) def
X currentdict end
X } def
X
X /push-selected-canvases {
X gsave
X fboverlay setcanvas
X 0 0 { moveto 20 20 rmoveto
X -40 -40 rlineto
X 40 0 rmoveto
X -40 40 rlineto
X } getanimated waitprocess aload pop
X find_canvas
X push-it
X grestore
X } def
X
X /push-windows {
X 10 dict begin
X /d 200 dict def
X [d]
X { currentprocess
X /ParentDict where { pop self } { currentdict } ifelse
X put
X } cvlit
X append cvx
X RootUserDict begin
X AllWin
X end % RootUserDict
X 10 { pause } repeat % Is this enough, or will 1 pause do it, or what?
X d push-it
X end % localdict
X } def
X
X XNeWS? {
X /push-processes {
X getprocesses push-it
X } def
X } {
X /push-processes {
X % How should we simulate this bugger in NeWS 1.1?
X % getprocesses push-it
X (You need NeWS/X!) push-it
X } def
X } ifelse
X
X /push-object {
X Object push-it % XXX: push opened object editor
X } def
X
X /push-framebuffer-children {
X framebuffer push-it % XXX: push opened canvas hierarchy editor
X } def
X
X /kbd-reset {
X /dialog-buf () store
X /dialog-string () store
X { psh-socket bytesavailable string readstring pop
X } errored
X {(\n%% Reset!\n) print} execute-it
X } def
X
X /shut-down {
X { psh-socket (\ndbgstop\nquit\n) writestring
X psh-socket flushfile
X } errored pop
X null null /DropDead TellMyProcess
X 1 60 div sleep
X } def
X
X /kbd-reboot {
X {
X /dialog-buf () store
X /dialog-string () store
X [ () (%% Reboot!) () ] false /writeatcaret dialog-text send
X shut-down
X psh-socket null ne {
X psh-socket status { psh-socket closefile } if
X } if
X /psh-socket null store
X % I don't know why I have to do this, but it sure helps... (i hope)
X items {
X% { LayoutLock monitorlocked { /LayoutLock createmonitor def } if
X { /LayoutLock createmonitor def
X } exch send
X } forall
X ensure-DL
X% { EventMgr null ne { EventMgr killprocess } if
X% /EventMgr Interests forkeventmgr store
X% KeyboardEventMgr null ne { KeyboardEventMgr killprocess } if
X% /KeyboardEventMgr { KeyboardHandler } fork store
X% } dialog-text send
X start-event-mgrs
X } fork pop
X } def
X
X /use-selected-process {
X selected-object dup type /processtype eq {
X set-process
X } if
X } def
X
X /ObjectSize { % - => w h
X % XXX bletch:
X ObjectWidth 0 eq ObjectHeight 0 eq or {
X /ObjectWidth
X ItemBorder dup add ItemWidth 1 index sub % w
X ScrollerWidth dup add SubItemGap add max
X store
X /ObjectHeight
X ItemHeight exch sub % w h
X ScrollerWidth NotifierHeight add SubItemGap add max
X store
X } if
X ObjectWidth ObjectHeight
X } def
X
X /adjust-geometry {
X LabelSize /LabelHeight exch def /LabelWidth exch def
======== END OF cyber.shar.splitae ========