systemdict /collapse known not { systemdict /collapse false put } if %---------------------------------------------- % class manager % /class_mgr growabledict begin /ParentDictArray nullarray def /class_mgr {/class_mgr where pop} def /superclass null def /superclasses nullarray def /classname /class_mgr def %---------------------------------------------- % class_shared % /class_shared dictbegin /superclass null def /superclasses nullarray def /classname /class_shared def /obsolete nullproc def /new { % -- instance //collapse {[superclass]} {superclasses} ifelse [currentdict] append dictbegin /ParentDictArray exch def dictend } def /compile { % -- ps_script length 0 ne { { currentprocess /ProcessName (Script Compiler) put currentprocess /ErrorDetailLevel 1 put {ps_script cvx exec} stopped { currentprocess /$error get } {null} ifelse } fork waitprocess dup null ne { /$error exch def } {pop} ifelse } if } def dictend def %---------------------------------------------- % class_class % /class_class dictbegin /superclass null def /superclasses nullarray def /classname /class_class def /obsolete nullproc def /new { % pdb-script ps-script -- shared-class null shared { % pdb ps null object null pop dup /ps_script get 3 index eq { dup /pdb_script get 4 index eq { exch pop exit } {pop} ifelse } {pop} ifelse } forall dup null eq { pop currentdict growabledict begin harden /superclass 1 index def /classname 1 index /classname get def dup /superclasses get [3 -1 roll] append /superclasses 1 index def /ParentDictArray ParentDictArray [//class_shared] append 3 -1 roll append def /ps_script exch def /pdb_script exch def currentdict end shared 1 index soften null put dup class_mgr /addclient ObsoleteService send /compile 1 index send readonly } {3 1 roll pop pop harden} ifelse } def %---------------------------------------------- % defining the super class % /superclass { % name -- find_class dup null ne { //collapse {dup {def} forall} if /superclass 1 index def dup /superclasses get [3 -1 roll] append /superclasses 1 index def /ParentDictArray ParentDictArray 3 -1 roll append def currentdict dictbegin {currentfile cvx exec} 1 index send dictend pop pop } {pop} ifelse } def %---------------------------------------------- % persistent variables % /persist { % var -- persistent 1 index arraycontains? {pop} { /persistent persistent [4 -1 roll] append def } ifelse } def /unpersist { % var -- [exch persistent { 2 copy eq {pop exit} {exch} ifelse } forall pop] /persistent exch def } def dictend def %---------------------------------------------- % finding classes % /class_paths [ (HOME) getenv (/class) append (HOME) getenv (/hn/ol) append (HOME) getenv (/hn/src) append ] def /find_class { % class-name -- class|null class_mgr 1 index known { class_mgr exch get harden } { (%.PS) [2 index] sprintf class_paths (r) filepathopen { %1 index DEBUG dictbegin /ParentDictArray [class_mgr //class_class] def {mark exch cvx exec cleartomark} currentdict send /classfile exch def /classname exch def /shared growabledict def currentdict /superclass known not { /superclass null def /superclasses nullarray def } if /ParentDictArray [class_mgr //class_class] def dictend readonly dup class_mgr /addclient ObsoleteService send class_mgr 1 index dup /classname get exch soften put } { pop /error ne { /error find_class } {null} ifelse } ifelse } ifelse } def %---------------------------------------------- % deleting classes % /HandleObsoleteTarget { % class -- %(class obsolete: % %) [2 index dup /classname get exch /shared known () (shared) ifelse] sprintf DEBUG dup /shared known { currentdict 1 index /classname get undef pop } { dup /superclass get dup null ne { /shared get exch undef } {pop pop} ifelse } ifelse } def %---------------------------------------------- % End of class_mgr % currentdict /class_shared undef currentdict /class_class undef currentdict end def %---------------------------------------------- % create objects % /newobject { % classname -- object|null /find_class class_mgr send dup null ne { //nullstring //nullstring /new 4 -1 roll send dup null ne { /new exch send } if } if } def % % Send -- robust send a message to an object. % /ctxget { % n -- null|thing currentprocess /hnctx 2 copy known { get dup length 3 -1 roll sub get } {pop pop pop null} ifelse } def /sender {2 ctxget} def /target {3 ctxget} def /message {4 ctxget} def /args {5 ctxget} def /Send { % args message target -- find_object dup null eq {pop pop pop} { self soften currentprocess /hnctx 2 copy known {get} {pop pop 4 array} ifelse currentprocess /OperandStack get currentprocess /hnctx 3 -1 roll put clear args aload pop message /deliver target send clear currentprocess /hnctx get aload pop currentprocess /hnctx 3 -1 roll put pop pop pop pop } ifelse } def % % error handling % /report_error { % errordict -- begin dbf (\n**** HyperNeWS error ****\n) writestring message null ne { message 12 { (\n) search { dbf exch writestring dbf exch writestring } {exit} ifelse } repeat pop } { dbf (command: %\n) [/command load] fprintf dbf (error: %\n) [/errorname load] fprintf } ifelse dbf (\n) writestring dbf flushfile end } def /handle_error { % -- $error /errorname get where { $error /errorname get cvx exec } {$error report_error} ifelse } def % % log message to the console % /log_message { % ... - ... target self eq { sender self eq { dbf (% -- %\() [namestr message] fprintf } { dbf (% to % -- %\() [ /namestr sender send namestr message ] fprintf } ifelse } { dbf (% via % to % -- %\() [ /namestr sender send /namestr target send namestr message ] fprintf } ifelse args { dbf exch 200 string cvs writestring dbf ( ) writestring } forall dbf (\)\n) writestring dbf flushfile } def % % ClassTrackingCanvas, a tnt canvas with external tracking properties % systemdict /track_first_event null put systemdict /track_event null put /track_start_event {systemdict /track_first_event 3 -1 roll put} def /trackx {track_event /XLocation get} def /tracky {track_event /YLocation get} def /trackdx {trackx track_first_event /XLocation get sub} def /trackdy {tracky track_first_event /YLocation get sub} def /track_is_timed {track_event /istimed 2 copy known {get} {pop pop false} ifelse} def /ClassTrackingCanvas ClassCanvas [] classbegin /Trackable? true def /track_time 0 def /track_lev 0 def % % subclasses responsibility % /onselect nullproc def /onadjust nullproc def % % send an event to the tracking process % /track_send { % event action -- 1 index begin /ClientData exch def /Canvas self def /Name /tRackEvent def end sendevent } def % % tracking service interface % /TrackStart { % event -- list true .1 blockinputqueue % determine multi click dup /TimeStampMS get track_time sub UserProfile /MultiClickThresh get le {track_lev} 0 ifelse 1 add /track_lev exch promote /track_time 1 index /TimeStampMS get promote { newprocessgroup currentprocess /ProcessName (HyperNeWS tracker) put currentprocess /track_evt 3 -1 roll put clear createevent dup begin /Name /tRackEvent def end expressinterest unblockinputqueue InteractionLock { self setcanvas currentprocess /track_state null put currentprocess /track_evt get /track_first_event 1 index store /Name get dup AdjustButton eq { pop onadjust } { MenuButton eq {onmenu} {onselect} ifelse } ifelse } monitor currentprocess /track_evt undef systemdict /track_first_event null put systemdict /track_event null put } fork soften /tracker exch promote pop /Default true } def /TrackStop { % event -- { currentprocess /track_mvd known /mouse_up /mouse_click ifelse exit } track_send /tracker unpromote } def /TrackCancel { % event -- {/mouse_cancel exit} track_send /tracker unpromote } def /TrackMotion { % event -- {currentprocess /track_mvd true put $track_proc} track_send } def classend def % % Track utillities % /mouseevent { % -- event currentprocess /track_evt 2 copy known {get} {pop pop createevent} ifelse } def /mouselevel { % -- multi-click-level mouseevent /Canvas get dup null ne { /track_lev 2 copy known {get} {pop pop 0} ifelse } {pop 0} ifelse } def % % low level track procedure % /trackable { % -- boolean currentprocess dup /track_evt known exch /track_state known and } def /track_state { % -- status trackable { currentprocess /track_state get null eq { 10 dict begin currentprocess /track_state undef /$track_proc { currentprocess /track_state track_event put /mouse_drag exit } def { awaitevent /track_event 1 index store /ClientData get exec } loop end } {/mouse_drag} ifelse } {/mouse_cancel} ifelse } def /track { % proc -- status trackable { 10 dict begin /$track_proc exch cvx def /track_event currentprocess /track_evt get store $track_proc currentprocess /track_state get dup null ne { /track_event exch store $track_proc } {pop} ifelse currentprocess /track_state undef { awaitevent /track_event 1 index store /ClientData get exec } loop end } {pop /mouse_cancel} ifelse } def /track_time_select { % proc -- $track_time 0 eq {track_event /istimed false put} if track_event /TimeStampMS get $track_time ge { /$track_time currenttimems $track_delay add store createevent begin /TimeStampMS $track_time def /Name /tRackEvent def /ClientData {currentprocess /track_mvd true put $track_proc} def /istimed true def currentdict end sendevent } if cvx exec } def /track_time { % threshms delayms proc -- status trackable { 10 dict begin /$track_proc [3 -1 roll //track_time_select /exec load] cvx def /$track_delay 3 -1 roll 10 max def /$track_time 0 def /track_event currentprocess /track_evt get store $track_proc /$track_delay exch 10 max store currentprocess /track_state undef { awaitevent /track_event 1 index store dup /istimed known { dup begin currentcursorlocation /YLocation exch def /XLocation exch def end } if /ClientData get exec } loop end } {pop pop pop /mouse_cancel} ifelse } def currentdict /track_time_select undef /track_timed { % threshms delayms proc -- status trackable { [/track_event cvx /istimed /known cvx [6 -1 roll cvx] cvx /if load] cvx track_time } {pop pop pop /mouse_cancel} ifelse } def /track_once { % proc -- status trackable { /track_event mouseevent store cvx exec currentprocess /track_evt undef currentprocess /track_state undef /mouse_up } {pop /mouse_cancel} ifelse } def /track_overlay { % proc -- status [/erasepage load 3 -1 roll cvx /exec load] cvx matrix currentmatrix currentcanvas dup createoverlay setcanvas 1 index setmatrix 3 -1 roll track 3 1 roll erasepage setcanvas setmatrix } def % % A HyperNeWS Menu % % NOTE: altough ClassMenuCanvas is a subclass of ClassTrackingCanvas it % does NOT use any of the tracking functionality. It could also be a subclass % of ClassCanvas. % ClassMenu pop % load ClassMenu /ClassMenuCanvas ClassTrackingCanvas [] classbegin /menuprocess null def /Menuable? true def /onmenu nullproc def /MenuStart { % posname event -- posname event menu? boolean { currentprocess /ProcessName (HyperNeWS menu handler) put currentprocess /track_evt 3 -1 roll put currentprocess /menuok true put clear {onmenu} stopped pop currentprocess /menuok undef currentprocess /track_evt undef } fork { pause dup /State get dup /breakpoint eq { pop /menuprocess 1 index promote 3 -1 roll pop dup /menuposname get 3 1 roll /menumenu get true exit } if /runnable ne {pop false exit} if } loop } def /MenuStop { % menu -- pop menuprocess null ne { menuprocess /State get /breakpoint eq { menuprocess continueprocess } if /menuprocess unpromote } if } def classend def % % An event manager that clears the graphics state % /ClassHNEventMgr ClassEventMgr [] classbegin /DefaultProcessName (HyperNeWS event Manager) def /ClearContext { /ClearContext super send countdictstack 1 sub {end} repeat grestoreall framebuffer setcanvas initgraphics } def classend def { systemdict /MenuTrackService known not { systemdict /MenuTrackService growabledict /Default [MenuButton] /new ClassTrackInterest send put [MenuTrackService] /addclients GlobalEventMgr send } if } pop /ClassHNCanvas ClassMenuCanvas [] classbegin { /activate { self /addclient MenuTrackService send /activate super send } def /deactivate { /deactivate super send self /removeclient MenuTrackService send } def } pop % % canvas utillities % /target null def /target_send { % method -- target dup null ne { dup /ParentDictArray known {send} {pop pop} ifelse } {pop pop} ifelse } def /onkey {/handle_key target_send} def /onfunction {/handle_function target_send} def /onselect {/handle_select_click target_send} def /onadjust {/handle_adjust_click target_send} def /onmenu {/handle_menu_click target_send} def /Paint {/handle_damage target_send} def /onenter {/handle_enter target_send} def /onexit {/handle_exit target_send} def /path { % x y w h -- pop pop pop pop } def /destroy { % -- /target unpromote /tracker unpromote /menuprocess unpromote /deactivate self send /destroy super send } def % % typing % /Keyable? true def /KeyStart { % event -- .. true onenter pop [/StandardKey /NumPadKey /MetaKey /ArrowKey] true } def /KeyStop { % event -- pop onexit } def /StandardKey {/Name get onkey} def /NumPadKey {/Name get onkey} def /ArrowKey {/Name get onfunction} def /FunctionKey {/Name get onfunction} def classend def /CursorFocus /setmode ClassFocus send % % canvas utillities % /nullcanvas framebuffer newcanvas def /new_canvas { % parent-canvas -- canvas /new //ClassHNCanvas send } def /reshape_canvas { % canvas -- 0 0 0 0 /reshape 6 -1 roll send } def /move_canvas { % x y canvas -- gsave dup /Parent get setcanvas /move exch send grestore } def /map_canvas { % canvas -- true /setdamageable 2 index send /new ClassHNEventMgr send /activate 2 index send dup /target self soften put /map exch send } def /unmap_canvas { % canvas -- /unmap 1 index send /deactivate exch send } def /move_canvas { % canvas x y canvas -- /move 4 -1 roll send } def /totop_canvas { % canvas -- /totop exch send } def /tobottom_canvas { % canvas -- /tobottom exch send } def currentdict /ClassHNCanvas undef currentdict /ClassTrackingCanvas undef /mtranslate { % matrixtype float float -- matrixtype 3 -1 roll matrix copy 3 1 roll 2 index 4 4 -1 roll put 1 index 5 3 -1 roll put } def /setxorop { % colortype colortype -- setcolor currentpixel exch setcolor currentpixel xor setpixel 6 setrasteropcode } def /rectinrect { % rectangle rectangle -- boolean 2 copy 0 get 2 index 1 get 3 -1 roll aload pop 6 -2 roll pointinrect? { exch 1 index 0 get 2 index 2 get add 2 index 1 get 4 -1 roll 3 get add 3 -1 roll aload pop 6 -2 roll pointinrect? } { pop pop false } ifelse } def /insetstroke { % float rectangle -- rectangle 1 index 2 mul 1 add [2 index 0 get 4 index add 3 index 1 get 6 -1 roll add 1 add 4 index 2 get 4 index sub 6 -1 roll 3 get 6 -1 roll sub] } def /truedicttype { % any -- name dup truetype dup /dicttype ne { exch pop } { pop dup /ParentDictArray known not { pop /dicttype } { /ParentDictArray get dup type /arraytype ne { pop /tnttype } { dup length dup 0 ne { 1 sub get /superclass known /hntype /tnttype ifelse } { pop pop /tnttype } ifelse } ifelse } ifelse } ifelse } def /cmp { % any any -- boolean 2 copy eq { pop pop true } { 1 index truedicttype 2 copy exch truedicttype ne { pop pop pop false } { cmp$SwiTch0 exch 2 copy known not { pop /$deFaUlT } if get exec } ifelse } ifelse } def /cmp$SwiTch0 3 dict dup begin /$deFaUlT { pop pop false } def /packedarraytype { exch dup length 3 -1 roll dup 3 1 roll length ne { pop pop false } { 1 index length { dup 1 sub exch 0 eq { pop pop pop true exit } if 2 index 1 index get 2 index 2 index get cmp not { pop pop pop false exit } if } loop } ifelse } def /arraytype currentdict /packedarraytype get def end def /lit_char { % int -- string dup lit_char$SwiTch1 exch 2 copy known not { pop /$deFaUlT } if get exec } def /lit_char$SwiTch1 8 dict dup begin /$deFaUlT { dup 32 lt true { dup 126 gt } ifelse { (\\000) dup 1 3 index -6 bitshift 3 and 48 add put dup 2 3 index -3 bitshift 7 and 48 add put dup 3 4 -1 roll 7 and 48 add } { ( ) dup 0 4 -1 roll } ifelse put } def 41 { pop (\\\)) } def 40 { pop (\\\() } def 92 { pop (\\\\) } def 12 { pop (\\f) } def 13 { pop (\\r) } def 9 { pop (\\t) } def 10 { pop (\\n) } def end def /name_ok_str 256 string def %begin postscript section ( ) 0 get 1 add 1 (~) 0 get { name_ok_str exch 1 put } for (\(\)\\<\\>\\[\\]\\{\\}\\/\\%\\) { name_ok_str exch 0 put } forall %end postscript section /name_ok { % name -- boolean cvns true exch { exch name_ok_str 3 -1 roll get 0 eq { false exch not exit } if } forall true if } def /stringpos_bin { % string float -- int 1 index length dup 0 eq { pop pop pop 0 } { dup 1 eq { pop exch stringwidth pop 2 div gt 1 0 } { 1 index 3 index 0 3 index 2 div cvi dup 5 1 roll getinterval dup 3 1 roll stringwidth pop dup 3 1 roll lt { pop exch pop exch pop 3 -1 roll pop exch stringpos_bin } { exch pop 1 index 6 -1 roll 3 index 6 -2 roll sub getinterval 4 -2 roll sub stringpos_bin add } } ifelse ifelse } ifelse } def /stringpos { % fonttype string float -- int currentfont 4 -1 roll setfont 3 -2 roll stringpos_bin exch setfont } def /GetInterval { % any * int int -- any * 2 index length 3 -1 roll 1 index min 3 1 roll 2 index sub min getinterval } def %begin postscript section systemdict /dbf known not { systemdict /dbf (/dev/console) (w) file put systemdict /DEBUG { % any -- dbf (DEBUG: ) writestring dbf exch 100 string cvs writestring dbf (\n) writestring dbf flushfile } put systemdict /STACK { 10 dict begin /tf currentprocess /Stdout get def currentprocess /Stdout dbf put dbf (STACK: ) writestring stack dbf flushfile currentprocess /Stdout tf put end } put } if %end postscript section %begin postscript section gsave framebuffer clippath pathbbox points2rect /screenheight exch def /screenwidth exch def grestore %end postscript section /dup_dict growabledict def /dup_cnt 0 def /mark_obj_saved { % any -- dup_dict exch dup_cnt dup /dup_cnt exch 1 add store put } def /obj_saved_before { % filetype any -- boolean dup_dict 1 index known { 1 index dup_dict 3 -1 roll get writeobject ( #g) writestring true } { pop pop false } ifelse } def /save_shared_class { % filetype shared_class -- 2 copy obj_saved_before not { dup mark_obj_saved 2 copy /pdb_script get save_obj 1 index 32 write 2 copy /ps_script get save_obj 1 index 32 write 1 index exch /superclass get /classname get save_obj ( SC) writestring } { pop pop } ifelse } def /save_obj { % filetype any -- dup truedicttype save_obj$SwiTch0 exch 2 copy known not { pop /$deFaUlT } if get exec } def /save_obj$SwiTch0 16 dict dup begin /$deFaUlT { pop (null) writestring } def /hntype { 2 copy obj_saved_before not { 1 index /class 2 index send save_shared_class 1 index ( BO\n) writestring dup mark_obj_saved dup /persistent exch send { exch 2 copy exch known { 2 index 2 index save_obj 2 index 32 write 2 index 1 index 4 -1 roll get save_obj 1 index ( def\n) writestring } { exch pop } ifelse } forall pop (EO) writestring } { pop pop } ifelse } def /dicttype { 2 copy obj_saved_before not { dup mark_obj_saved 2 copy maxlength writeobject 1 index ( Bd\n) writestring { 2 index 3 -1 roll save_obj 1 index 32 write 1 index exch save_obj dup ( def\n) writestring } forall ( Ed\n) writestring } { pop pop } ifelse } def /fonttype { dup /FontMatrix get exch 2 index 1 index /FontName get save_obj 2 index ( findfont ) writestring 1 index 0 get 2 index 3 get eq { 1 index 1 get 0 eq } false ifelse { 1 index 2 get 0 eq } false ifelse { 1 index 4 get 0 eq } false ifelse { 1 index 5 get 0 eq } false ifelse { 2 index 3 -1 roll 0 get save_obj 1 index ( scalefont ) } { 2 index 3 -1 roll save_obj 1 index ( makefont ) } ifelse writestring 1 index exch /PrinterMatched get save_obj ( printermatchfont) writestring } def /colortype { colorrgb 3 array astore 2 copy 0 get save_obj 1 index 32 write 2 copy 1 get save_obj 1 index 32 write 1 index exch 2 get save_obj ( rgbcolor) writestring } def /operatortype { 64 string cvs dup length 3 -2 roll 1 4 -1 roll 2 sub getinterval writestring } def /arraytype { dup length dup 0 ne { 6 eq { dup 0 get 1 eq } false ifelse { dup 1 get 0 eq } false ifelse { dup 2 get 0 eq } false ifelse { dup 3 get 1 eq } false ifelse { 2 copy 4 get save_obj 1 index 32 write 1 index exch 5 get save_obj ( MX) } { 2 copy xcheck ({) ([) ifelse writestring dup 0 exch { exch 3 index 3 -1 roll save_obj dup 1 add exch 4 lt { 2 index 32 write } { pop 0 2 index (\n) writestring } ifelse } forall pop xcheck (}\n) (]\n) ifelse } } { pop xcheck ({}) (//nullarray) } ifelse ifelse writestring } def /packedarraytype currentdict /arraytype get def /stringtype { dup length dup 60 gt { pop 1 index (\() writestring 0 exch { lit_char exch 2 index 2 index writestring exch length add dup 50 gt { pop dup (\\\n) writestring 0 } if } forall pop (\)) writestring } { 0 ne {writeobject} { pop (//nullstring) writestring } ifelse } ifelse } def /nametype { dup name_ok {writeobject} { 1 index exch cvns save_obj ( cvn) writestring } ifelse } def /marktype { pop ([) writestring } def /nulltype {writeobject} def /booleantype currentdict /nulltype get def /integertype currentdict /booleantype get def /realtype { exch 1 index cvi 2 index eq { exch cvi } {exch} ifelse writeobject } def /fixedtype currentdict /realtype get def end def /save_object { % filetype any -- 1 index (% HyperNeWS window \(c\)1990 Turing Institute\n) writestring 1 index (2.001 HNBegin\n) writestring /dup_cnt 0 store 1 index exch save_obj dup_dict cleanoutdict (\nHNEnd\n) writestring } def /logging false def /report_errors true def /visible true def /validated true def /dragframeonly true def /autoindent true def /justification /Left def /framelabel (Untitled) def /cv nullcanvas def /iconX 50 def /iconY 10 def %begin postscript section /logo (hn/sys/logo.ps) run def %end postscript section /textfont /LucidaSans findfont 12 scalefont false printermatchfont def /headerfont /LucidaSans-Bold findfont 12 scalefont false printermatchfont def /footerfont /LucidaSans-Bold findfont 10 scalefont false printermatchfont def /iconfont /LucidaSans findfont 10 scalefont false printermatchfont def /@icon null def /@layout null def /@current_layout null def /@first_layout null def /@window_layout null def /@focus null def /@owner null def /@freezer null def /@menu null def /@windowmenu null def /@iconmenu null def /@editmenu null def /@scrollhmenu null def /@scrollvmenu null def /editSELcolor 1 0 0 rgbcolor def /editCTXcolor 1 0.6 0.6 rgbcolor def %begin postscript section /selFGcolor {BG} def /selBGcolor {FG} def /BG0 { //ClassDrawable /BG0 get } def /BG { //ClassDrawable /BG get } def /BG2 { //ClassDrawable /BG2 get } def /BG3 { //ClassDrawable /BG3 get } def /FG { //ClassDrawable /FG get } def /2DFG {//ClassDrawable /2DFG get} def /2DBG {//ClassDrawable /2DBG get} def %end postscript section /scrollautorepeat true def %begin postscript section UserProfile begin /ScrollDelay 50 ?def /ScrollThresh 100 ?def end /scrollthreshold { //UserProfile /ScrollThresh get } def /scrolllinedelay { //UserProfile /ScrollDelay get } def /scrollpagedelay { //UserProfile /ScrollDelay get } def %end postscript section