Path: utzoo!utgpu!attcan!uunet!mcvax!prlb2!bernard From: bernard@prlb2.UUCP (Bernard Yves) Newsgroups: comp.windows.news Subject: NeWSillustrator (part 2) Keywords: ... Message-ID: <520@prlb2.UUCP> Date: 5 Jan 89 14:35:54 GMT Organization: Philips Research Laboratory, Brussels Lines: 1377 NeWSillustrator part 2 ---------------------------------------------------------------------------- /outline_proc {} def /Ne 0 def /g_edit_path{ %generic path edition %outline_proc => -; the outlining function %a path is in tmparray 0-Ntmp; %allows the user to edit %it by its moving points; /outline_proc exch store gsave Sx Sy Angle X Y spos /X2 0 store /Y2 0 store { %select point to move %equivalent to a getclick but with the good outlining function 0 0 {outline_proc} getanimated waitprocess aload pop /Y1 exch store /X1 exch store X2 X1 eq Y2 Y1 eq and {exit } %stop edition { /X2 X1 store /Y2 Y1 store X1 Y1 findpointofpath %=> -1 or N dup 0 ge %a point is selected {/Ne exch store (point selected -- move it) prmessage 0 0 {tmparray Ne [x y] put outline_proc} getanimated waitprocess pop } { (point not found) prmessage pop } ifelse } ifelse } loop grestore } def /findpointofpath{% X Y => N /N -1 store 0 1 Ntmp 1 sub {dup tmparray exch get aload pop %x y n x1 y1 3 index sub abs 3 lt exch %x y n b1 x1 4 index sub abs 3 lt %x y n b1 b2 and {/N exch store exit } {pop} ifelse } for pop pop N } def /outline_curve{ newpath 0 0 moveto /N 1 store /Xc 0 store /Yc 0 store tmparray 0 Ntmp getinterval {aload pop %x y N 3 eq {gsave Xc Yc moveto 2 copy /Yc exch store /Xc exch store curveto /N 1 store stroke grestore Xc Yc moveto} { 2 copy lineto /N N 1 add store} ifelse} forall } def /edit_curved_path{ {outline_curve stroke} g_edit_path } def /get_curved_path {%ask a path to the user; path terminated by double-clicking %last point; %path put in tmparray as [ [x1,y1],.... ] , Ntmp elements %first point -origin - in X0, Y0, all xi,yi relative to origin %get points until two points are equal (enter first point : ) prmessage getclick /Y0 exch store /X0 exch store %origin gsave (enter points 3 by 3 - enter twice the same point to end) prmessage X0 Y0 translate /X2 0 store /Y2 0 store /Ntmp 0 store /N 1 store %repeat { 0 0 { outline_curve X2 Y2 moveto x y lineto stroke} getanimated waitprocess aload pop /Y1 exch store /X1 exch store X2 X1 eq Y2 Y1 eq and {exit} {tmparray Ntmp [X1 Y1] put /Ntmp Ntmp 1 add store /X2 X1 store /Y2 Y1 store } ifelse } loop /Ntmp Ntmp Ntmp 3 mod sub store %Ntmp a multiple of 4 grestore (% curves path) [ Ntmp 3 div ] prmessage } def (Polyline \n) printdbg /Polyline DrawObject dictbegin /Npoint 0 def %nbre de points /Closed false def %if true -> polygon dictend classbegin /new { /new super send begin currentdict end } def /saveivar{ /saveivar super send OSfile ( % % ) [Npoint Closed] fprintf } def /loadivar{ /Closed exch store /Npoint exch store /loadivar super send } def /make_path {%the path coord relative to 0,0 are stored in an array in geom geom null ne { spos newpath 0 0 moveto geom {aload pop lineto} forall Closed {closepath} if } if } def /make_path_ps{ geom null ne { PSfile (spos newpath 0 0 moveto \n) [] fprintf geom {PSfile exch ( % % lineto \n) exch fprintf} forall Closed {PSfile ( closepath\n) [] fprintf} if } if } def /scale_geom { %sx sy => - mtrx0 currentmatrix pop gsave 0 0 0 /make_path self send %path mtrx0 setmatrix %path is scaled /N 0 store {pop pop} { %x y geom N get astore pop /N N 1 add store} {} {} pathforall grestore } def /i_get_geom { get_path %path introduced by user in tmparray; X0 Y0 tmparray 0 Ntmp getinterval %x y [array of [xi yi] ] on stack } def /edit_proc {edit_path} def /edit_geom {%interactive edition of geom (select point of line and move it -- click twice on same point to end) prmessage /oldcanvas currentcanvas store setoverlay /Ntmp Npoint store tmparray 0 geom putinterval /edit_proc self send oldcanvas setcanvas geom null ne {/erase self send} if tmparray 0 Ntmp getinterval /set_geom self send geom null ne { /make_bbox self send /display self send} if } def /set_geom { %[ [x1 y1] [x2 y2] ... ] => - dup length array /geom exch store geom copy length /Npoint exch store } def /save_geom{% OSfile ([ %polyg. geom\n) writestring geom {OSfile exch ( [ % % ] ) exch fprintf} forall OSfile ( ] %end of polyg. geom\n) writestring } def /clone_geom { %here the geom is an array of array geom type (arraytype) eq {/newarray geom length array store /N 0 store geom {2 array copy newarray exch N exch put /N N 1 add store} forall /geom newarray store} if /newarray 4 array store bbox newarray copy /bbox exch store } def classend def (Curve \n) printdbg /Curve Polyline dictbegin /iter 1 def dictend classbegin /new { /new super send begin currentdict end } def /make_path {%the path coord relative to 0,0 are stored in an array in geom geom null ne { spos % translate rotate scale newpath 0 0 moveto /iter 1 def geom { aload pop iter 3 eq {curveto /iter 1 store } {/iter iter 1 add store} ifelse } forall Closed {closepath} if } if } def /make_path_ps {%the path coord relative to 0,0 are stored in an array in geom geom null ne { PSfile (spos newpath 0 0 moveto\n) [] fprintf /iter 1 def geom { PSfile exch ( % % ) exch fprintf % aload pop iter 3 eq { PSfile ( curveto\n) [] fprintf /iter 1 store } {/iter iter 1 add store} ifelse } forall Closed {PSfile ( closepath\n) [] fprintf} if } if } def /scale_geom { %sx sy => - mtrx0 currentmatrix pop gsave 0 0 0 /make_path super send %path mtrx0 setmatrix %path is scaled /N 0 store {pop pop} { %x y geom N get astore pop /N N 1 add store} {} {} pathforall grestore } def /edit_proc {edit_curved_path} def /i_get_geom { get_curved_path %path introduced by user in tmparray; X0 Y0 tmparray 0 Ntmp getinterval %x y [array of [xi yi] ] on stack } def classend def /FontName /Times-Roman def /pointsize 30 def (Text\n) printdbg /TextObject DrawObject dictbegin /Fontname /Times-Roman def /Size 30 def /font null def /Sh 0 def %the height, width of the box enclosing the /Sw 0 def %string in global coord. sys. (non scaled and non rot.) dictend classbegin /new { /new super send begin currentdict end } def /init{ /init super send /Fontname FontName store /Size pointsize store /color 0 store %black } def /saveivar{ /saveivar super send OSfile (/% % % %) [Fontname Size Sh Sw] fprintf } def /loadivar{ /Sw exch store /Sh exch store /Size exch store /Fontname exch store /loadivar super send } def /save_geom{ OSfile ( \() writestring OSfile geom writestring OSfile (\) \n) writestring } def /make_font {% sets the font entry /font Fontname findfont Size scalefont store} def /set_font_and_size {% /fontname size => /Size exch def /Fontname exch def /make_font self send} def /changefont{ % change the font {/Fontname FontName store} /change_geom self send } def /changefontsize{% change font size {/Size pointsize store} /change_geom self send } def /make_path { geom null ne { spos Fontname findfont Size scalefont setfont newpath 0 0 moveto geom show } if } def /make_path_ps { geom null ne { PSfile (spos\n) [] fprintf PSfile ( /% findfont % scalefont setfont\n) [Fontname Size] fprintf PSfile (newpath 0 0 moveto (%) show\n) [geom] fprintf } if } def /is_in_obj { /is_in_box self send} def /dr {% linewidth linecolor color linejoin linecap linestyle => - only %color is important gsave pop pop pop setgray pop pop Sx Sy Angle X Y /make_path self send grestore } def /dr_ps{ PSfile (gsave pop pop pop setgray pop pop % % % % % \n) [Sx Sy Angle X Y] fprintf /make_path_ps self send PSfile (grestore\n) writestring } def /make_bbox{ %there seems to be problem with charpath and rotation; %therefore finds the box and draws it in the object coord. %system and extracts its bbox in the current coord. syst geom null ne { gsave mtrx0 currentmatrix pop Fontname findfont Size scalefont setfont 0 0 moveto geom stringbbox %here we have the box x,y,w,h 2 copy /Sh exch store /Sw exch store X Y translate Angle rotate Sx Sy scale 0 0 moveto rect pop pop mtrx0 setmatrix pathbbox bbox astore pop grestore} if } def /make_opath{ spos 0 0 moveto Sw Sh rect} def /scale_geom { %sx sy % max Size mul /Size exch store /Sy exch store /Sx exch store } def /i_get_geom {%the string is in textstring; /geom get_textstring store 0 0 {newpath Sx Sy Angle x y gsave /make_path self send grestore } getanimated waitprocess aload pop %x y textstring } def classend def (PostScriptImport\n) printdbg %the local bbox of the object is stored in the geom variable /alreadyimporteddict 50 dict def %for each imported file, will contain %a PostScript object for which the corresponding %drawproc has been correctly defined /PSFileCycle{ % filename => bool ; true if filename is an already % imported PS file false alreadyimporteddict { %key, value is an PS object %filename false key obj exch pop % obj /filename get %filename false filename2 2 index eq { %filename false pop true exit} if } forall exch pop } def %utilities /add_extension{% filename (.extension) => filename.extension exch %ext filename ( ) search %ext post match pre true { 4 -1 roll %post match pre ext 4 2 roll %pre ext post match pop pop append } { %ext pre exch append } ifelse } def /extract_fname{% /.../.../.../toto.xxx => toto.xxx { (/) search { % post match pre pop pop} {exit} ifelse } loop } def /make_wrappedfname{%filename => PWD/fname.wps (PWD) getenv (/) append exch extract_fname append (.wps) add_extension } def /achar 1 string def /linestring2 256 string def /make_procname{ % filename => - %from a filename make a postscript name %by repacing all / by a _ /N 0 store 0 1 linestring2 length 1 sub {linestring2 exch 32 put} for { achar 0 3 -1 roll put achar dup (/) eq {pop (_)} if %char or _ linestring2 N 3 -1 roll putinterval /N N 1 add store } forall linestring2 ( ) search pop %post match pre 3 1 roll pop pop cvn } def /linestring 256 string def /TmpFile null def /PS2file null def /errorstring 30 string def /copytofile{% filename file => bool ; true if error exch %file filename { (r) file /TmpFile exch store % file { dup % file file TmpFile linestring readline % file file subst bool {writestring % file dup (\n) writestring % file } {pop exit} ifelse } loop TmpFile closefile } stopped dup {get_errorstr} if } def /get_errorstr{%gets current errorname and puts it in errorstring $error begin errorname end errorstring cvs pop } def /fileerrorpr{% operation filename => - %print last file error message exch (file error : ) errorstring append exch append exch append prmessage } def /PostScript DrawObject dictbegin /drawproc nullproc def %the drawing code; any legal ps? /filename 100 string def %the imported file /privatedict null def /procname null def /savemtrx null def dictend classbegin /new { /new super send begin currentdict end } def /init{ /init super send % /geom 4 array store /privatedict 50 dict store %a private dict for drawproc def and store /savemtrx matrix store } def /clone_geom{ /clone_geom super send privatedict 50 dict copy /privatedict exch store } def /display{%drawing param are set; it is the responsability %of the drawing proc to reset them to its own values savemtrx currentmatrix pop gsave Sx Sy Angle X Y spos geom 0 get neg geom 1 get neg translate linewidth setlinewidth linecolor setgray linecap setlinecap linejoin setlinejoin linestyle setdashpat mark privatedict begin drawproc end cleartomark grestore savemtrx setmatrix } def /display_ps {%for each imported file a procedure / is %defined and called procname null eq {/procname filename make_procname store} if importfiledict procname known not {% the procedure is not yet defined in the ps file %procname procname self /drawproc get length 300 lt { PSfile (\n/%{\n) [ procname ] fprintf filename PSfile copytofile pop %procname PSfile (\n} def\n) writestring importfiledict procname 1 put %procname } if %if the proc is too long %do not create a proc, but write %the imported file each time it is needed } if PSfile (savemtrx currentmatrix pop gsave % % % % % spos % % translate\n) [Sx Sy Angle X Y geom 0 get neg geom 1 get neg] fprintf PSfile (% % % % % setdashpat setlinejoin setlinecap setgray setlinewidth\n) [linewidth linecolor linecap linejoin linestyle] fprintf self /drawproc get length 300 lt {PSfile (mark privatedict begin % end cleartomark grestore savemtrx setmatrix\n) [procname] fprintf } {PSfile (mark privatedict begin\n) writestring filename PSfile copytofile PSfile (end cleartomark grestore savemtrx setmatrix\n) writestring } ifelse } def /scale_geom{ Sy mul /Sy exch store Sx mul /Sx exch store } def /make_opath{%draws the local bbox spos % geom 0 get geom 1 get moveto 0 0 moveto geom 2 get geom 0 get sub geom 3 get geom 1 get sub rect } def /make_path{ /make_opath self send} def %will be used in is_in_obj; /erase{%erases the local bounding box gsave 1 setgray Sx Sy Angle X Y make_opath fill grestore } def /make_bbox{%computes the global bbox gsave mtrx0 currentmatrix pop Sx Sy Angle X Y /make_opath self send mtrx0 setmatrix pathbbox bbox astore pop grestore } def /load_drawproc{ % - => bool; true if ok; %if not already made, makes the wrapped file and loads it %the wrapped file is created in the user Home directory %with the same name as the user file and *.wps as extension /procname filename make_procname store alreadyimporteddict procname known %the dict entry contains the Postscript object %for which the corresponding drawproc has been defined {/drawproc {alreadyimporteddict procname get /drawproc get exec} def true } { /PS2file filename make_wrappedfname (w) file store PS2file (/drawproc{ \n) writestring filename PS2file copytofile %copies filename to the %end of PS2file {%error in copying file false } { PS2file (\n} def \n) writestring PS2file closefile (loading wrapped file ) filename make_wrappedfname append prmessage filename make_wrappedfname LoadFile dup {alreadyimporteddict procname self put} if } ifelse } ifelse } def /i_get_geom{ %reads the imported filename * and loads it %makes a 'wrapped' file *.wps %where the ps code is embedded : /drawproc{ } def %then loads it with LoadFile /filename get_ps_filename dup length string copy store (making wrapped file ) filename make_wrappedfname append prmessage /load_drawproc self send %true if ok; { (enter the bounding box : ) prmessage currentcanvas %the overlay canvas oldcanvas setcanvas %the win canvas {savemtrx currentmatrix pop gsave mark privatedict begin drawproc end cleartomark grestore savemtrx setmatrix} stopped {(error in executing PS file ) filename append prmessage setcanvas 0 0 null } { setcanvas %reset the overlay getwholerect waitprocess %box dup aload pop %box x1 y1 x2 y2 pop pop 3 -1 roll %x1 y1 box (PS file imported: ) filename append prmessage } ifelse } {( in loading ) filename fileerrorpr 0 0 null } ifelse }def /save_geom{ OSfile ( [ % % % % ] \n) geom fprintf} def /saveivar{ /saveivar super send OSfile ( \() writestring OSfile filename writestring OSfile (\) \n) writestring } def /loadivar{ /filename exch store mark /load_drawproc self send {} %ok {(error in importing) filename append prmessage)} ifelse cleartomark /loadivar super send } def classend def %building of an A4 size rectangle /a4rect /new DrawObject send def { /X 100 35 div 3 mul def /Y 100 35 div 3 mul def /geom [100 35 div 197 mul 100 35 div 282 mul] def /linecolor .85 def /linewidth 2 def /ingroup true def %so that it is not selectable by user; } a4rect send %============================================================================= %drawing area window definition %=========================================================================== /win framebuffer /new ScrollAndZoomWindow send def (main interaction routines\n) printdbg /selected_obj null def /old_selection null def /create_object {%class => obj {ClientCanvas} win send setcanvas /new exch send /selected_obj exch store /i_def_geom selected_obj send selected_obj begin geom end null ne {selected_obj AddObject} {/selected_obj null store} ifelse } def /create_polygon { {ClientCanvas} win send setcanvas /new Polyline send /selected_obj exch store selected_obj AddObject selected_obj begin /Closed true store end /i_def_geom selected_obj send } def /find_object_on_pt {%x y => obj | null %only objects which are not in a group can be found /Y0 exch store /X0 exch store /Xc null store /Yc null store ObjTable 0 Nobj getinterval { /Xc exch store Xc null ne {Xc begin ingroup end not {X0 Y0 /is_in_obj Xc send {/Yc Xc store exit} if} if} if} forall Yc } def /find_objects_in_box {% [x1 y1 x2 y2] => o1 o2.... on n /b1 exch store /N 0 def ObjTable 0 Nobj getinterval { /Xc exch store Xc null ne {Xc begin ingroup end not {Xc begin bbox end b1 box_in_box {Xc /N N 1 add store} if} if} if} forall N } def /select_object { {ClientCanvas} win send setcanvas gsave /oldcanvas currentcanvas store (select object by clicking on it : ) prmessage setoverlay getclick oldcanvas setcanvas find_object_on_pt grestore dup null ne {dup /erase exch send /selected_obj exch store pause /display selected_obj send selected_obj begin [tableindex] end (% is selected) exch prmessage /getclassname selected_obj send /Group ne {/update_control_panel selected_obj send} if } {pop (no object selected) prmessage} ifelse } def /i1 0 def /i2 0 def /swap_obj{ % o1 o2 => - ; swaps the 2 obj in ObjTable; dup begin /i2 tableindex store end exch dup begin /i1 tableindex store end %o2 o1 dup begin /tableindex i2 store end ObjTable exch i2 exch put dup begin /tableindex i1 store end ObjTable exch i1 exch put (% and % swapped) [i1 i2] prmessage } def /find_overlapping_obj{ % fromindex step toindex obj => first_over_obj %obj in X1, overlap in Xc /X1 exch store /Xc null store {ObjTable exch get dup /X2 exch store null ne {X2 begin ingroup end not {X1 begin bbox end X2 begin bbox end overlapping_box {/Xc X2 store exit} if } if } if } for Xc } def /move_down{ % obj => obj2 ; invert position of obj in ObjTable with % the next object behind it overlapping it dup begin tableindex end 1 sub -1 0 4 -1 roll find_overlapping_obj dup null ne {X1 Xc swap_obj} if } def /move_up{ % obj => obj2 ; invert position of obj in ObjTable with % the next object over it overlapping it obj2 dup begin tableindex end 1 add 1 Nobj 1 sub 4 -1 roll find_overlapping_obj dup null ne {X1 Xc swap_obj} if } def /apply_on_sel {% proc => - ; apply proc on selection if non null selected_obj null ne {{ClientCanvas} win send setcanvas exec } {pop (no object selected !) prmessage} ifelse } def /notifyselection true def /apply_on_sel2 {% proc => - ; apply proc on selection if non null selected_obj null ne notifyselection and {{ClientCanvas} win send setcanvas exec % (selection notified\n) print } {pop} ifelse } def /current_linecolor 0 def %black /current_linewidth 0 def %hair line /current_fill 0 def /current_linecap 0 def /current_linejoin 0 def /current_linestyle 0 def /current_radcorner 8 def /erase_flag true def /group_def_mode (by box) def /fontmenu [ FontDirectory { % include all fonts except /Cursor pop dup /Cursor ne { 25 string cvs dup length 3 le { pop } if } { pop } ifelse } forall ] [{/FontName currentkey store { /changefont selected_obj send} apply_on_sel2}] /new DefaultMenu send def /pointsizemenu [( 6 ) (8) (10) (12) (14) (16) (18) (24) (30) (32) (64)] [{/pointsize currentkey cvi store { /changefontsize selected_obj send} apply_on_sel2}] /new DefaultMenu send def /filemenu [ (save PS file) {generate_ps} (save Objects file) {generate_os} (load Objects file) {load_osfile} ] /new DefaultMenu send def /align_op{%align_proc => - selected_obj null ne {{ClientCanvas} win send setcanvas /getclassname selected_obj send /Group eq {/change_geom selected_obj send} if } {pop (no group object selected !) prmessage} ifelse } def /clipped_obj null def /clipping_obj null def /make_clip{%the current selection contains the clipped object %ask for the clipping obj and creates a ClippingGroup /clipped_obj selected_obj store clipped_obj begin /ingroup true store end select_object clipped_obj begin /ingroup false store end selected_obj null ne { /getclassname selected_obj send /Group ne /getclassname selected_obj send /TextObject ne and /getclassname selected_obj send /PostScript ne and { /clipping_obj selected_obj store /erase clipped_obj send /new ClippingGroup send /selected_obj exch store [clipping_obj clipped_obj] /set_geom selected_obj send /make_bbox selected_obj send /display selected_obj send selected_obj AddObject } { (error : the clipping obj can not be a group, a text or an importPS) prmessage /selected_obj clipped_obj store } ifelse } if } def /othermenu [ (edit line or curve) {{/edit_geom selected_obj send} apply_on_sel} (clip) {{make_clip} apply_on_sel} (align left) {{/align_left self send} align_op} (align bottom) {{/align_bottom self send} align_op} (align right) {{/align_right self send} align_op} (align top) {{/align_top self send} align_op} (center vertical) {{/center_vertical self send} align_op} (center horizontal) {{/center_horizontal self send} align_op} ] /new DefaultMenu send def /psfilename null def /get_ps_filename{ items /psfilename get /ItemValue get} def /notifypsfname{ /psfilename ItemValue store} def /PSfile null def /generate_ps { {ClientCanvas} win send setcanvas get_ps_filename PSFileCycle not { {get_ps_filename (w) file /PSfile exch store RepaintAll_ps PSfile closefile} stopped {get_errorstr ( in writing ) get_ps_filename fileerrorpr} {(PS file is written: ) get_ps_filename append prmessage} ifelse } {(can not write PS file: cycle,same name as an imported PS file ) get_ps_filename append prmessage } ifelse } def /osfilename null def /get_os_filename{ items /osfilename get /ItemValue get} def /notifyosfname{ /osfilename ItemValue store} def /OSfile null def /generate_os { {ClientCanvas} win send setcanvas {get_os_filename (w) file /OSfile exch store SaveAllObjects OSfile closefile} stopped {get_errorstr ( in writing ) get_os_filename fileerrorpr} {(Objects file is written: ) get_os_filename append prmessage} ifelse } def /load_osfile{ {ClientCanvas} win send setcanvas (loading...) prmessage get_os_filename LoadFile {(Object file loaded: ) get_os_filename append prmessage /PaintClient win send } {get_errorstr ( in loading ) get_os_filename fileerrorpr} ifelse } def (Window definition \n) printdbg { /PaintClient { ClientCanvas setcanvas 1 fillcanvas RepaintAll } def /FrameLabel (Drawing Area) def /ClientMenu [ (Redisplay) {/PaintClient ThisWindow send} (Select) {select_object} (Move) {{/drag_and_trans selected_obj send} apply_on_sel} (Rotate) {{/drag_and_rotate selected_obj send} apply_on_sel} (Scale) {{/drag_and_scale selected_obj send} apply_on_sel} (Copy) {{ /old_selection selected_obj store /selected_obj /clone selected_obj send store selected_obj AddObject /erase_flag false store /drag_and_trans selected_obj send /erase_flag true store } apply_on_sel} (Move Up) {{ selected_obj move_up dup null ne {/display exch send /display selected_obj send} {(no overlapping object over selection) prmessage} ifelse } apply_on_sel } (Move Down) {{ selected_obj move_down dup null ne {/display selected_obj send /display exch send} {(no overlapping object behind selection) prmessage} ifelse } apply_on_sel } (Delete) {{ /delete selected_obj send /selected_obj null store} apply_on_sel} (Destroy) {{ /destroy selected_obj send /selected_obj null store} apply_on_sel} (Other =>) othermenu (------) {} (Rect) { DrawObject create_object } (Line) { Polyline create_object } (Polygon) {Polyline create_object selected_obj begin /Closed true store end /display selected_obj send } (Curve) { Curve create_object } (RoundedRect) {RoundedRect create_object} (Oval) {Oval create_object} (Text) {TextObject create_object} (Group) {Group create_object} (Import PS) {PostScript create_object} (------) {} (Zoom In) {/ZoomIn win send} (Zoom Out) {/ZoomOut win send} (Font => ) fontmenu (FontSize => ) pointsizemenu (Files IO => ) filemenu ] /new DefaultMenu send def } win send %============================================================================ %control panel window definition %============================================================================ (Control Panel definition\n) printdbg systemdict /Item known not { (NeWS/liteitem.ps) run } if %systemdict /Item known not { (NeWS/liteitem.ps) LoadFile pop } if /notify? true def /notify { notify? {(Notify: Value=%) [ItemValue] /printf messages send} if } def /FillColor .75 def /prmessage { % sting => - print messages in Control Panel gsave /printf messages send grestore } def /notifylq {ItemValue 10 div setlinequality} def /notifylw {/current_linewidth ItemValue store { {current_linewidth /setlinewidth2 self send} /change_geom selected_obj send} apply_on_sel2 } def /notifylc {/current_linecolor ItemValue 100 div store { {current_linecolor /setlinecolor self send} /change_geom selected_obj send} apply_on_sel2 } def /notifyfc {/current_fill ItemValue 0 lt {-1} {ItemValue 100 div} ifelse store { {current_fill /setcolor self send} /change_geom selected_obj send} apply_on_sel2 } def /notifygroupdefmode {/group_def_mode ItemValue 0 eq (by box) (by enumeration) ifelse store } def /notifylcap{/current_linecap ItemValue store {{current_linecap /setlinecap2 self send} /change_geom selected_obj send} apply_on_sel2 } def /notifyljoin{/current_linejoin ItemValue store {{current_linejoin /setlinejoin2 self send} /change_geom selected_obj send} apply_on_sel2 } def /notifylstyle{/current_linestyle ItemValue store {{current_linestyle /setlinestyle self send} /change_geom selected_obj send} apply_on_sel2 } def /notifyradcorner {/current_radcorner ItemValue cvr dup 0 eq {pop 8} if store {{current_radcorner /setradcorner self send} /change_geom selected_obj send} apply_on_sel2 } def /textstring (enter string) def /notifytext{/textstring ItemValue store} def /gridon false def /gridsize 100 def /notifygridsize {/gridsize ItemValue cvr store} def /notifygridon {/gridon ItemValue 1 eq store } def /get_textstring{%gets the ItemValue of the text liteitem items /textstring get /ItemValue get dup /textstring exch store } def /draw_grid{% draws the grid gridon gridsize 0 gt and {gsave 0 setgray [2 5] 0 setdash 0 gridsize 1000 {dup 0 moveto 1000 lineto stroke} for 0 gridsize 1000 {dup 0 exch moveto 1000 exch lineto stroke} for grestore} if } def /putinControlPanel{%linewidth linecolor color linestyle linejoin linecap /notifyselection false store /oldcanvas currentcanvas store {ClientCanvas} controlpanel send setcanvas items begin linecap /ItemValue 3 -1 roll put /paint linecap send linejoin /ItemValue 3 -1 roll put /paint linejoin send linestyle /ItemValue 3 -1 roll put /paint linestyle send dup -1 ne {100 mul} if fillcolor /ItemValue 3 -1 roll put /paint fillcolor send 100 mul linecolor /ItemValue 3 -1 roll put /paint linecolor send linewidth /ItemValue 3 -1 roll put /paint linewidth send end oldcanvas setcanvas pause /notifyselection true store } def %Items creation /createitems { /items 15 dict dup begin /messages /panel_text () /Right {} can 700 0 /new MessageItem send dup begin /ItemFrame 1 def /ItemBorder 4 def end 20 20 /move 3 index send def /textstring (Text String:) (Text string) /Right /notifytext can 500 0 /new TextItem send 20 290 /move 3 index send def /osfilename (Objects file name:) (PWD) getenv % (/u3/bernard/NeWS/PrologNeWS/obj) /Right /notifyosfname can 500 0 /new TextItem send 20 260 /move 3 index send def /psfilename (PS file name:) (PWD) getenv %(/u3/bernard/NeWS/PrologNeWS/ps0) /Right /notifypsfname can 500 0 /new TextItem send 20 230 /move 3 index send def /gridsize (Grid Size:) (100) /Right /notifygridsize can 220 0 /new TextItem send 20 200 /move 3 index send def /gridbutton (Grid on:) [/panel_check_off /panel_check_on] /Right /notifygridon can 0 0 /new CycleItem send dup /LabelY -4 put 250 200 /move 3 index send def /linequality (line quality:) [0 10 10] /Right /notifylq can 220 20 /new SliderItem send 20 170 /move 3 index send def /linecap (line cap:) [(butt) (round) (square) ] /Right /notifylcap can 0 0 /new CycleItem send 250 140 /move 3 index send def /linejoin (line join:) [(miter) (round) (belevel) ] /Right /notifyljoin can 0 0 /new CycleItem send 355 170 /move 3 index send def /linestyle (line style:) [(plain) (dash1) (dash2) ] /Right /notifylstyle can 0 0 /new CycleItem send 250 170 /move 3 index send def /linewidth (line width:) [0 10 0] /Right /notifylw can 220 20 /new SliderItem send dup /ItemFrame 1 put 20 140 /move 3 index send def /linecolor (line color:) [0 100 0] /Right /notifylc can 220 20 /new SliderItem send dup /ItemFrame 1 put 20 110 /move 3 index send def /fillcolor (fill color:) [-1 100 -1] /Right /notifyfc can 220 20 /new SliderItem send dup /ItemFrame 1 put 20 80 /move 3 index send def /groupdef (Group Defined by :) [ ( box) ( enumeration) ] /Right /notifygroupdefmode can 220 0 /new CycleItem send 20 50 /move 3 index send def /radcorner (Rounded Corner Radius:) (8) /Right /notifyradcorner can 220 0 /new TextItem send 250 50 /move 3 index send def end def /messages items /messages get def } def /slideitem { % items fillcolor item => - gsave dup 4 1 roll % item items fillcolor item /moveinteractive exch send % item /bbox exch send % x y w h (Item: x=%, y=%, w=%, h=% Canvas: w=%, h=%) [ 6 2 roll win begin FrameWidth FrameHeight end ] /printf messages send grestore } def /MakeControlPanel { % Create and size a window. The size is chosen to accommodate the % items we are creating. Right before we map the window, we ask the % user to reshape the window. This is atypical, but gets the items % positioned the way we want them. /controlpanel framebuffer /new DefaultWindow send def % Create a window { /PaintClient {FillColor fillcanvas items paintitems} def /FrameLabel (Control Panel) def /IconImage /galaxy def /ClientMenu [ (White Background) {/FillColor 1 store /paintclient controlpanel send} (Light Background) {/FillColor .75 store /paintclient controlpanel send} (Medium Background) {/FillColor .50 store /paintclient controlpanel send} (Dark Background) {/FillColor .25 store /paintclient controlpanel send} (Black Background) {/FillColor 0 store /paintclient controlpanel send} (Flip Verbose) {/notify? notify? not store} ] /new DefaultMenu send def } controlpanel send % Install my stuff. 200 200 700 350 /reshape controlpanel send % Shape it. /can controlpanel /ClientCanvas get def % Get the window canvas % Create all the items. createitems % Create event manager to slide around the items. % Create a bunch of interests to move the items. % Note we actually create toe call-back proc to have the arguments we need. % The proc looks like: {items color "thisitem" slideitem}. % We could also have used the interest's clientdata dict. /slidemgr [ items { % key item exch pop dup /ItemCanvas get % item can MiddleMouseButton [items FillColor % item can name [ dict color 6 -1 roll /slideitem cvx] cvx % can name proc DownTransition % can name proc action 4 -1 roll eventmgrinterest % interest } forall ] forkeventmgr def % Now let the user specify the window's size and position. Then map % the window. (See above) Then activate the items. % /ptr /ptr_m framebuffer setstandardcursor /reshapefromuser controlpanel send % Reshape from user. /map controlpanel send % Map the window & install window event manager. % (Damage causes PaintClient to be called) /itemmgr items forkitems def } def MakeControlPanel 1 setlinequality a4rect AddObject %obj1 AddObject %obj2 AddObject %s1 AddObject /make_bbox a4rect send %/make_bbox obj1 send %/make_bbox obj2 send %/make_bbox s1 send /reshapefromuser win send /map win send 1000 1000 /Resize win send {/Scroll win send} {/Scroll win send} /SetNotifiers win send win /ClientCanvas get setcanvas win begin /overlaycan ClientCanvas createoverlay store end ---------------------------------------------------------------------------- Yves Bernard Philips Research Lab Brussels, 2 av. Van Becelaere 1170 Brussels, Belgium bernard@prlb2.uucp