/* --- Copyright University of Sussex 1997. All rights reserved. ---------- > File: $poplocal/local/auto//showdisplay.p > Purpose: > Author: Chris J. Thornton, Apr 3 1997 > Documentation: HELP * SHOWDISPLAY > Related Files: */ uses popxlib; uses xt_widget; include xpt_coretypes; include xpt_xtypes; vars pop_package = [showdisplay showpalette showgraph shownet showdendro showfields showsurface showactivations]; global vars sd_output_file = sysfileok('~/temp.out'), sd_main_display_name = 'MAIN DISPLAY ' sys_>< (if systranslate('HOST_NAME') ->> it do ' (' sys_>< it sys_><')' else nullstring endif), sd_current_display_name = sd_main_display_name, sd_display_name = sd_current_display_name, /* for compatibility */ sd_pen_colour = "black", sd_double_buffering = false, sd_incremental = false, /* flag controlling initial screen refresh */ sd_primitives = [line box string stringin circle arc arrow space blanks], sd_display_types = [screen ved X fig troff latex], sd_display_size = newproperty([ [X [0 0 280 280]] [fig [20 40 370 390]] [troff [0 0 250 400]] [latex [0 0 300 300]] [ved [0 0 %min(70, vedlinemax - 3), min(35, vedwindowlength - 3) %]] ],16,[0 0 100 100],true), sd_drawing_area = newassoc([]), /* can be used to set margin offsets */ sd_allow_screen_display_stretching = true, sd_allow_colour = true, sd_allow_arrows = true, sd_allow_line_styles = true, sd_allow_curved_ved_lines = false, sd_allow_filling = true, sd_hard_frame = true, /* ensures dimensions scaled proportionately */ sd_display, sd_displays = newmapping([],8,false,true), sd_default_display_type = "screen", /* either X or ved as appropriate */ sd_display_type = sd_default_display_type, sd_display_screen = systranslate('DISPLAY'), sd_default_font_size = 10, sd_default_line_size = 1, sd_trap = identfn, sd_init = identfn, sd_veddefaults = vedveddefaults, sd_colours, /* see end of file for list */ sd_colour_codes, /* mapping from colours to numbers */ sd_assigned_colours = newassoc([]), sd_RGB_value, sd_max_colour_code, sd_max_filling_level = 21, /* compatible with fig */ sd_primitive_pdr, /* can't be a lconstant for some reason - bug ?? */ sd_create = syscreate, /* needed by some client programs */ sd_widget_geometry, sd_wrapperstrings = newproperty([ [fig [['#FIG 2.1' '80 2'][]]] [troff [['.PS' '.ps \\n(.s-2' '.nf'] [/*'.ps'*/ '.PE' '.sp 1v']]] [latex [[%'\\batchmode \\documentstyle{article} \\setlength{\\unitlength}{0.0175in} \\begin{document}', '\\begin{center} \\begin{picture}(' sys_><',' sys_><')'%] ['\\end{picture} \\end{center}' '\\end{ document }']] ] ],16,[[][]],true), sd_RGB_value = [ [black {0 0 0}] [blue {0 0 1}] [green {0 1 0}] [cyan {0 1 1}] [red {1 0 0}] [magenta {1 0 1}] [yellow {1 1 0}] [white {1 1 1}] [gainsboro {0.85 0.85 0.85}] [LightSkyBlue {0.75 0.88 1}] [DeepSkyBlue {0.5 0.75 1}] [violet {0.88 0.63 1}] [BlueViolet {0.63 0.38 1}] [aquamarine {0.63 1 0.88}] [DarkTurquoise {0.25 0.88 0.88}] [LightPink {1 0.75 0.88}] [MediumOrchid {0.75 0.5 0.88}] [RoyalBlue {0.25 0.5 0.88}] [GreenYellow {0.88 1 0.75}] [gray {0.75 0.75 0.75}] [DeepPink {1 0.5 0.75}] [DarkViolet {0.5 0.38 0.75}] [MediumSpringGreen {0.5 1 0.63}] [NavajoWhite {1 0.88 0.63}] [MediumAquamarine {0.38 0.75 0.63}] [DarkSalmon {0.88 0.63 0.63}] [PaleVioletRed {0.75 0.25 0.63}] [YellowGreen {0.75 0.88 0.5}] [DarkSeaGreen {0.5 0.5 0.35}] [ForestGreen {0.13 0.5 0.5}] [IndianRed {0.88 0.38 0.38}] [MediumSeaGreen {0.5 0.88 0.25}] [orange {1 0.75 0.25}] [brown {0.63 0.25 0.25}] [SeaGreen {0.38 0.63 0.0}] ], sd_colours = [ /* order of first 32 roughly respects fig-format colour numbers */ black blue green cyan red magenta yellow white blue4 blue3 blue2 LightSkyBlue green4 MediumSeaGreen LimeGreen cyan4 cyan3 turquoise red4 maroon chocolate magenta4 magenta3 plum SaddleBrown firebrick IndianRed salmon LightCoral pink MistyRose gold DeepPink HotPink LightPink tan wheat brown LavenderBlush LightPink VioletRed azure DarkSeaGreen DeepSkyBlue LightSlateGray RoyalBlue LightSlateBlue SteelBlue gray PaleGreen snow GhostWhite WhiteSmoke gainsboro FloralWhite OldLace linen AntiqueWhite PapayaWhip BlanchedAlmond bisque PeachPuff NavajoWhite moccasin cornsilk ivory LemonChiffon seashell honeydew MintCream AliceBlue lavender DarkSlateGray DimGray SlateGray LightGrey MidnightBlue navy NavyBlue CornflowerBlue DarkSlateBlue SlateBlue MediumSlateBlue MediumBlue DodgerBlue SkyBlue LightSteelBlue LightBlue PowderBlue PaleTurquoise DarkTurquoise MediumTurquoise LightCyan CadetBlue MediumAquamarine aquamarine DarkGreen DarkOliveGreen SeaGreen LightSeaGreen SpringGreen LawnGreen chartreuse MediumSpringGreen YellowGreen ForestGreen OliveDrab DarkKhaki khaki PaleGoldenrod LightGoldenrodYellow LightYellow LightGoldenrod goldenrod DarkGoldenrod RosyBrown sienna peru burlywood beige SandyBrown DarkSalmon LightSalmon orange DarkOrange coral tomato OrangeRed PaleVioletRed MediumVioletRed violet orchid MediumOrchid DarkOrchid DarkViolet BlueViolet MediumPurple thistle ], sd_dark_colours = [black blue green cyan red magenta yellow LightSkyBlue DeepSkyBlue violet BlueViolet aquamarine DarkTurquoise LightPink MediumOrchid RoyalBlue GreenYellow gray DeepPink DarkViolet MediumSpringGreen NavajoWhite MediumAquamarine DarkSalmon PaleVioletRed YellowGreen DarkSeaGreen ForestGreen IndianRed MediumSeaGreen orange brown SeaGreen], sd_RGB_value = newassoc(sd_RGB_value), sd_max_colour_code = length(sd_colours), sd_colour_codes = newproperty([%for it from 1 to sd_max_colour_code do [^(sd_colours(it)) ^it] endfor%], 512,false,true), ; /* Setup menu of configuration variables */ vars sd_ms_vars = [ {sd_allow_colour ^true ^false greys} sd_double_buffering sd_allow_line_styles sd_allow_screen_display_stretching sd_allow_filling sd_allow_arrows sd_default_line_size sd_hard_frame sd_default_font_size {sd_default_display_type ^^sd_display_types} {sd_pen_colour ^^sd_colours} ]; /* Compatibility */ syssynonym("sd_Xwidget_geometry", "sd_widget_geometry"); syssynonym("sd_display_dimensions", "sd_display_size"); /* Stop vars declarations of Xpw pdrs */ vars XpwFillRectangle, temp_XpwClearArea, XpwClearArea, XpwCopyFrom, XpwDrawRectangle, XpwSetFont XpwDrawArc XpwFillArc XpwDrawLine XpwDrawString XpwSetColor, XpwDrawImage, XpwFreeColor, ; defclass display { sd_name, sd_type, sd_file, sd_commands, sd_udxc, /* user-to-display-frame x coefficient */ sd_udyc, /* user-to-display-frame y coefficient */ sd_uxmin, sd_uymin, sd_uxmax, sd_uymax, sd_uxlen, sd_uylen, sd_dxmin, sd_dymin, sd_dymax, sd_dxmax, sd_dxlen, sd_dylen, sd_dxpixels, sd_dypixels, sd_dcos, sd_dsin, sd_dxcentre, sd_dycentre, sd_widget, sd_invisible_widget, sd_shell, sd_font, sd_font_size, sd_foreground, sd_background, }; define /* lconstant */ new_display; consdisplay(repeat 31 times false endrepeat) enddefine; vars /* lvars */ last_commands = false, max_troff_y_coord = 0, special_case, boolean_spec, line_size_spec, depth_spec, line_style_spec, colour_spec, border_spec, rotation_spec = 0, colour_shade_spec, primitive_map, fig_colour_code, fig_fill_level, fig_line_style, fig_dash_gap, fig_line_size, fig_font_size, fig_last_line_segment = initv(7), ; /* forward references */ vars /* lconstant */ drawlatexline, ptyc, drawlatexlineat, draw_weight, draw_arrow, apply_primitive_pdr, showdisplay, sd_free_color, sd_set_color, ; define /* lconstant */ 7 x >!< y; lvars x y; dlocal pop_pr_quotes = false; x >< y; enddefine; define /* lconstant */ get_fig_colour_code(wd) -> code; lvars wd, c, code = false; if isinteger(sd_colour_codes(wd) ->> c) and c < 32 then c-1 -> code; /* fig codes range from 0 to 7 */ endif; enddefine; /* -- Convert coord/length in user frame to coord/length in display frame */ /* Derive display coord */ define /* lconstant */ xdc(x); lvars x; (sd_dxmin(sd_display)+((x-sd_uxmin(sd_display))*sd_udxc(sd_display))) enddefine; define /* lconstant */ ydc(y); lvars y; (sd_dymin(sd_display)+((y-sd_uymin(sd_display))*sd_udyc(sd_display))) enddefine; /* Derive user coord */ define /* lconstant */ xuc(x); lvars x; (((x-sd_dxmin(sd_display))/sd_udxc(sd_display))+sd_uxmin(sd_display)) enddefine; define /* lconstant */ yuc(y); lvars y; (((y-sd_dymin(sd_display))/sd_udyc(sd_display))+sd_uymin(sd_display)) enddefine; define /* lconstant */ rotate_coords(x,y,xc,yc,d) -> (X, Y); lvars x y d, xc, yc, X, Y, SIN COS, d; sin(d) -> SIN; cos(d) -> COS; if d == 0 then x -> X; y -> Y; return endif; ((x-xc) * COS) + ((y-yc) * SIN) + xc -> X; - ((x-xc) * SIN) + ((y-yc) * COS) + yc -> Y; enddefine; /* Compute display coords with user offsets, rotations etc. */ define lvars dc(x,y) -> v; lvars a = rotation_spec, x y, xoffset = 0, yoffset = 0, d, c; lconstant v = {0 0}; if isvector(x) then x(1) elseif islist(x) then x(1) + x(2) else x endif -> x; if isvector(y) then y(1) elseif islist(y) then y(1) + y(2) else y endif -> y; xdc(x) -> x; ydc(y) -> y; if isprocedure(xoffset) then xoffset(x,y) -> x else x + xoffset -> x endif; if isprocedure(yoffset) then yoffset(x,y) -> y else y + yoffset -> y endif; x -> v(1); y -> v(2); if a /== 0 then /* handle axis shifts - remember y coordinate must be inverted */ cos(a) -> sd_dcos(sd_display); sin(a) -> sd_dsin(sd_display); sd_dymax(sd_display) - y -> y; sd_dymax(sd_display) - ((((y-sd_dycentre(sd_display)) * sd_dcos(sd_display)) - ((x-sd_dxcentre(sd_display)) * sd_dsin(sd_display))) + sd_dycentre(sd_display)) -> v(2); (((x-sd_dxcentre(sd_display)) * sd_dcos(sd_display)) + ((y-sd_dycentre(sd_display)) * sd_dsin(sd_display))) + sd_dxcentre(sd_display) -> v(1); endif; enddefine; /* display coord identity function - used to stop double conversions */ define dcid(x,y) -> v; lvars x y; lconstant v = {0 0}; x -> v(1); y -> v(2); enddefine; /* Derive display length */ define /* lconstant */ xdl(l); lvars l; l*sd_udxc(sd_display) enddefine; define /* lconstant */ ydl(l); lvars l; l*sd_udyc(sd_display) enddefine; /* Troff lengths need post-processing to make them auto-scaling ... */ define /* lconstant */ tn(c); /* assumes c is result of xdl or ydl */ lvars c; if iscaller(ptyc) do max(c, max_troff_y_coord) -> max_troff_y_coord; endif; '\\n(.su*' >!!<'u'; enddefine; /* -- Convert user-frame points to display frame points */ /* Handle prescaled troff coord */ define /* lconstant */ ptyc(c); lvars c; '.nr T ' >! v; lvars x y v; dc(x,y) -> v; /* ptyc(v(2)) -> v(2) */; enddefine; define /* lconstant */ lp(x,y) -> v; lvars x y v; dc(x,y) -> v; sd_dymax(sd_display) - v(2) -> v(2); enddefine; define /* lconstant */ fp(x,y) -> v; lvars x y v; dc(x,y) -> v; round(v(1)) -> v(1); round(v(2)) -> v(2); enddefine; define /* lconstant */ xp(x,y) -> v; lvars x y v; dc(x,y) -> v; intof(v(1)) -> v(1); intof(v(2)) -> v(2); enddefine; define /* lconstant */ vp(x,y) -> v; lvars x y v; dc(x,y) -> v; round(max(1,v(1))) -> v(1); round(max(1,v(2))) -> v(2); enddefine; /* -- Deriving the user/display frame mapping ------- */ define sd_set_display_dimensions(type, dims); lvars type dims; dims -> sd_display_size(type); if type == "latex" then [%'\\batchmode \\documentstyle{article} \\setlength{ \\unitlength}{0.0175in} \\begin{document}', '\\begin{center} \\begin{picture}(' >!< (dims(3)) >!<',' >!< (dims(4)) >!<')'%] -> sd_wrapperstrings("latex")(1); endif; enddefine; define ved_sdp; /* command to check/reset the display size for a given display type */ lvars args = valof("sysparse_string")(vedargument), n = length(args), type; if n == 0 then vederror('Display type?'); endif; consword(args(1)) -> type; if n == 1 then sd_display_size(type); elseif n == 3 then sd_set_display_dimensions(type, [0 0] <> tl(args)); elseif n == 5 then sd_set_display_dimensions(type, tl(args)); else vederror('Bad display dimensions'); endif; enddefine; define /* lconstant */ get_dimensions(widget) -> (dxmax,dymax); lvars dxmax = XptVal widget (XtN width :XptDimension), dymax = XptVal widget (XtN height :XptDimension); enddefine; define set_drawing_frame(type); lvars dxmin, dymin, dxmax, dymax, area, type, shell; if type == "X" and (sd_shell(sd_display) ->> shell) then 0 ->> dxmin -> dymin; get_dimensions(shell) -> (dxmax, dymax); /* this stuff awaiting double-buffering success... dxmax - 2 -> dxmax; /* take off something for border */ dymax - 2 -> dymax; if dxmax /= sd_dxmax(sd_display) or dymax /= sd_dymax(sd_display) then dxmax -> XptVal (sd_widget(sd_display)) (XtN width :XptDimension); dymax -> XptVal (sd_widget(sd_display)) (XtN height :XptDimension); dxmax -> XptVal (sd_invisible_widget(sd_display)) (XtN width :XptDimension); dymax -> XptVal (sd_invisible_widget(sd_display)) (XtN height :XptDimension); endif; */ else explode(sd_display_size(type)) -> (dxmin, dymin, dxmax, dymax); endif; if (sd_drawing_area(type) ->> area) then dxmin + (destpair(area) -> area) -> dxmin; dymin + (destpair(area) -> area) -> dymin; dxmax + (destpair(area) -> area) -> dxmax; dymax + (destpair(area) -> area) -> dymax; endif; (dxmin, dymin, dxmax, dymax) -> (sd_dxmin(sd_display), sd_dymin(sd_display), sd_dxmax(sd_display), sd_dymax(sd_display)); dymax - dymin -> sd_dylen(sd_display); dxmax - dxmin -> sd_dxlen(sd_display); enddefine; define /* lconstant */ max_and_min(i,com,xmin,ymin,xmax,ymax) -> xmin -> ymin -> xmax -> ymax; lvars xmax, ymax, xmin, ymin, com, i, n = length(com); if n fi_>= (i fi_+ 1) and isnumber(com(i)) and isnumber(com(i fi_+ 1)) then max(xmax, com(i)) -> xmax; max(ymax, com(i fi_+ 1)) -> ymax; min(xmin, com(i)) -> xmin; min(ymin, com(i fi_+ 1)) -> ymin; endif; enddefine; define /* lconstant */ set_user_frame(drawcomms); lvars drawcomms, i, j, xmax=0,ymax=0, command, xmin = 999999, ymin = 999999, max_dim; for i from 1 to length(drawcomms) do drawcomms(i) -> command; max_and_min(2,command,xmin,ymin,xmax,ymax)->xmin->ymin->xmax->ymax; max_and_min(4,command,xmin,ymin,xmax,ymax)->xmin->ymin->xmax->ymax; endfor; if sd_hard_frame then max(xmax-xmin,ymax-ymin) -> max_dim; xmin + max_dim -> xmax; ymin + max_dim -> ymax; endif; (xmin,ymin,xmax,ymax) -> (sd_uxmin(sd_display),sd_uymin(sd_display),sd_uxmax(sd_display),sd_uymax(sd_display)); max(0.1, xmax - xmin) -> sd_uxlen(sd_display); max(0.1, ymax - ymin) -> sd_uylen(sd_display); enddefine; define /* lconstant */ set_user_to_display_conversions; sd_dxlen(sd_display) / sd_uxlen(sd_display) -> sd_udxc(sd_display); sd_dylen(sd_display) / sd_uylen(sd_display) -> sd_udyc(sd_display); if rotation_spec /== 0 do cos(rotation_spec) -> sd_dcos(sd_display); sin(rotation_spec) -> sd_dsin(sd_display); endif; sd_dxmin(sd_display) + ((sd_dxmin(sd_display)+sd_dxlen(sd_display)) / 2) -> sd_dxcentre(sd_display); sd_dymin(sd_display) + (sd_dymax(sd_display) / 2) -> sd_dycentre(sd_display); enddefine; define /* lconstant */ set_coordinate_frames(drawcomms); lvars drawcomms; set_user_frame(drawcomms); set_drawing_frame(sd_display_type); set_user_to_display_conversions(); enddefine; /* -- Screen displays ------------------------------------- */ define active sd_current_widget; sd_widget(sd_display); enddefine; define updaterof active sd_current_widget; -> sd_displays(sd_current_display_name)(1); enddefine; define sd_widget_display(widget); lvars name display; appproperty(sd_displays, procedure(name, display); if sd_widget(display) == widget then exitfrom(display, sd_widget_display) endif; endprocedure); false; enddefine; /* Compatibility var */ vars active sd_Xwidget; syssynonym("sd_Xwidget", "sd_current_widget"); /* mapping back from X display coords to user coords */ define sd_X2U_coords(x,y) -> (x,y); lvars x y; unless isnumber(y) do sd_displays(y) -> sd_display; x -> y; -> x; endunless; round(xuc(x)) -> x; round(yuc(y)) -> y; enddefine; /* mapping back from U coords to X display coords */ define sd_U2X_coords(x,y) -> (x,y); lvars x y; unless isnumber(y) do sd_displays(y) -> sd_display; x -> y; -> x; endunless; round(xdc(x)) -> x; round(ydc(y)) -> y; enddefine; define /* lconstant */ set_X_font(widget, font) -> result; lvars widget, font, result = false, i, n; if isnumber(font) then font -> sd_font_size(sd_display); '-adobe-courier-medium-r-*-*-*-'>!<(round(font*10))>!<'-*-*-*-*-*-*' -> font; else false -> sd_font_size(sd_display); endif; define lconstant generalize(font); lvars font, x, done = false; for i from 1 to length(font) do if font(i) == `-` then ` ` -> font(i) endif; endfor; sysparse_string(font, false) -> font; consstring( #| for x in font do if not(done) and x /= '*' then `*` ->> done else explode(x) endif; endfor |#) -> font; if done then font else false endif; enddefine; if sd_font(sd_display) /= font then while not(XpwSetFont(widget, font) ->> result) and (generalize(font) ->> font) do endwhile; if font then font -> sd_font(sd_display);endif; endif; enddefine; define /* lconstant */ stringof(s); lvars s; dlocal pop_pr_quotes = false; if isstring(s) then s else s >< nullstring endif; enddefine; define /* lconstant */ set_X_colour(widget, colour) -> result; lvars widget colour, c, result = false, col, cw = colour; unless (sd_foreground(sd_display) ->> c) == colour do /* XpwFreeColor DOES NOT WORK YET if (isstring(c) or isword(c)) and c(1) == `#` do XpwFreeColor(widget, stringof(c)); endif; /* free up prev RGB colour */ */ if sd_assigned_colours(colour) /== "nomore" then XpwSetColor(widget, stringof(colour)) -> result; if not(result) and fast_lmember(colour, sd_colours) then newproperty(datalist(sd_assigned_colours),16,"nomore",true) -> sd_assigned_colours; else result -> sd_assigned_colours(colour); endif; colour -> sd_foreground(sd_display); endif; endunless; enddefine; define sd_colour_of_pixel(pixel_value) -> colour; lvars colour = false, pixel_value; appproperty(sd_assigned_colours, procedure(col, n); if n == pixel_value then col -> colour; endif; endprocedure); enddefine; exload_batch uses Xpw, Xm; uses xtApplicationShellWidget, xmBulletinBoardWidget, xpwGraphicWidget; uses xt_widget, XpwPixmap; endexload_batch; include xpt_coretypes; define /* lconstant */ copy_image(g1, g2); lvars g1, g2, (w, h)= XptVal g1(XtN width:XptDimension, XtN height:XptDimension); XpwPutImage(g2, XpwGetImage(g1, 0, 0, w, h, false, false), 0, 0, 0, 0, w, h); enddefine; define set_X_display_widgets; lvars shell, form, widget1, l = sd_display_size("X"), h = l(4), w = l(3), args; dlocal pop_pr_quotes = false; XptDefaultSetup(); XtAppCreateShell( 'buffer', 'Buffer', xtApplicationShellWidget, XptDefaultDisplay, [{width ^w}{height ^h}] ) ->> shell -> sd_shell(sd_display); XtCreateManagedWidget( 'buffer_form', xmBulletinBoardWidget, shell, [{width ^(w+10)}{height ^(h+10)}] ) -> form;; XtCreateManagedWidget( 'frame1', xpwGraphicWidget, form, [{width ^w}{height ^h}], ) ->> widget1 -> sd_widget(sd_display); XtCreateManagedWidget( 'frame2', xpwGraphicWidget, form, [{width ^w}{height ^h}{mappedWhenManaged ^false}] ) -> sd_invisible_widget(sd_display); XtRealizeWidget(shell); enddefine; define set_X_display_widgets; lvars l = sd_display_size("X"); XptNewWindow(sd_main_display_name, {%l(3),l(4)%},[],xpwGraphicWidget) ->> sd_shell(sd_display) ->> sd_widget(sd_display) -> sd_invisible_widget(sd_display); enddefine; vars /* lvars */ xpwgraphic = false; define set_display(comms); lvars comms, l, widget, area; sd_displays(sd_current_display_name) -> sd_display; if sd_incremental then unless sd_display do mishap('Trying to incrementally update a non-existent display', []); endunless; else if not(sd_display) then new_display() ->> sd_display -> sd_displays(sd_current_display_name); sd_current_display_name -> sd_name(sd_display); sd_display_type -> sd_type(sd_display); sd_output_file -> sd_file(sd_display); endif; set_coordinate_frames(comms); if sd_display_type == "X" then if not(sd_widget(sd_display) ->> widget) then if isundef(XpwFillRectangle) and not(popunderx) do vedputmessage('Loading X interface'); popval([uses popxlib; ]); endif; set_X_display_widgets(); sd_widget(sd_display) -> widget; endif; set_X_colour(widget, if sd_allow_colour do sd_pen_colour else "black" endif) ->; valof("XpwClearWindow")(widget); valof("XpwClearWindow")(sd_invisible_widget(sd_display)); endif; endif; enddefine; define ved_sds; /* Set the font size for screen displays */ lvars size args = valof("sysparse_string")(vedargument); dlocal sd_display_type = "X"; if args == [] do vedputmessage(sd_default_font_size >!< nullstring); elseif (args matches [?size]) and set_X_font(sd_widget(sd_display),size) then vedputmessage('Set font size for display to ' >! sd_default_font_size endif; else vederror('Can\'t set display to sd_default_font_size ' >! x; XptVal widget (XtN height :XptDimension) -> y; 5 -> XptVal widget (XtN lineWidth :XptDimension); if col == "random" then random(256)-1 -> XptVal widget (XtN foreground); elseif col == "white" and (0 ->> col) or col == "black" and (1 ->> col) then col -> XptVal widget (XtN foreground); elseif isinteger(col) and col >= 0 and col <= 255 then col -> XptVal widget (XtN foreground); elseif isword(col) then set_X_colour(widget, col) ->; else mishap('Illegal colour value', [^col]) endif; if style == "random" then oneof([horizontal rotational square diagonal]) -> style; endif; if style == "horizontal" then for i from 0 to x do repeat n times XpwDrawLine(widget,i,0,i,y); if col == "random" do random(256)-1 -> XptVal widget (XtN foreground); endif; endrepeat; endfor; elseif style == "diagonal" then for i from 0 to x do repeat n times XpwDrawLine(widget,i-(x div 2),i + (y div 2),i + (x div 2),i - (y div 2)); if col == "random" do random(256)-1 -> XptVal widget (XtN foreground); endif; endrepeat; endfor; elseif style == "rotational" then round(x / 2) -> xc; round(y / 2) -> yc; for d from 0 to 360 do rotate_coords(-100,yc,xc,yc,d) -> (x,y); repeat n times XpwDrawLine(widget,xc,yc,round(x),round(y)); if col == "random" do random(256)-1 -> XptVal widget (XtN foreground); endif; endrepeat; endfor; elseif style == "square" then round(x / 2) -> xc; round(y / 2) -> yc; for d from 0 to xc do XpwDrawRectangle(widget,xc-d,yc-d,d*2,d*2); if col == "random" do random(256)-1 -> XptVal widget (XtN foreground); endif; endfor; elseif style == "circle" then round(x / 2) -> xc; round(y / 2) -> yc; for d from 0 by 2 to xc*1.5 do XpwDrawArc(widget,xc-d,yc-d,d*2,d*2,11520,-23040); if col == "random" do random(256)-1 -> XptVal widget (XtN foreground); endif; endfor; endif; enddefine; /* -- Workaround for XpwClearArea --------------- */ define temp_XpwClearArea(w, x,y, width, height); lvars w,x,y,width,height; procedure; dlocal %XptValue(w, XtN foreground)% = XptValue(w, XtN background); XpwFillRectangle(w, x,y,width,height); endprocedure(); enddefine; /* define X_cleararea(widget,x1,y1,xd,yd); lvars v = xp(x1,y1), x1 = v(1), y1 = v(2), n = xd, bitvec = consbitvector(repeat n*n times 0 endrepeat, n*n); XpwDrawImage(sd_widget(sd_display),n,n,x1,y1, bitvec); enddefine; X_cleararea -> temp_XpwClearArea; */ /* -- Colour utilities ---------------------------- */ define sd_colour_darkness(colour); lvars colour, vec = sd_RGB_value(colour); if isvector(vec) then /* RGB */ 1 - ((vec(1)+vec(2)+vec(3)) / 3) else 0.5 endif; enddefine; define /* lconstant */ hex_val(v, n); lvars base = 16, i = 0, j, v = round(v), r, d, n; lconstant vec = initv(6); fill(repeat 6 times `0 endrepeat, vec) ->; until v = 0 do v fi_// base -> v -> r; if r < 10 then r + 48 else r + 55 endif -> fast_subscrv(i fi_+ 1 ->> i, vec); enduntil; for j from n by -1 to 1 do vec(j) endfor; enddefine; /* Only use 16 col values while XpwFreeColor problem is investigated! */ define sd_convert_RGB_spec(vec) -> spec; lvars r, g, b, v; explode(vec) -> (r,g,b); round(r * 15) -> r; round(g * 15) -> g; round(b * 15) -> b; consstring( #| `#`, hex_val(r,1) ->> v; v; v; hex_val(g,1) ->> v; v; v; hex_val(b,1) ->> v; v; v; |#) -> spec; enddefine; define sd_make_RGB_spec(colour, shade) -> spec; lvars colour, shade, spec, vec, r, g, b; unless (sd_RGB_value(colour) ->> vec) do mishap('Cannot generate RGB spec for colour', [^colour]) endunless; if isvector(vec) then destvector(vec) -> (r,g,b,); if isnumber(shade) then unless shade >= -1 and shade <= 1 do mishap('Invalid colour/shade specification', [^colour ^shade]) endunless; shade * -1 -> shade; if shade > 0 then /* increase colour vals - lighten colour */ r + ((1-r)*shade) -> r; g + ((1-g)*shade) -> g; b + ((1-b)*shade) -> b; else /* decrease colour vals - darken colour */ r + (r*shade) -> r; g + (g*shade) -> g; b + (b*shade) -> b; endif; endif; sd_convert_RGB_spec({^r ^g ^b}) -> spec; endif; enddefine; define /* lconstant */ vedinsertstringat(x,y,s); dlocal vedline, vedcolumn, vvedlinesize, vedstatic = true; lvars s, v = vp(x,y), x = v(1), y = v(2); vedjumpto(y,x); vedinsertstring(s); enddefine; /* --- Circles ------------------------------------- x and y are the coords of the top-left corner of the frame into which the circle exactly fits. size is the distance from top to bottom (or left to right) of the frame. x1,y1,x2,y2 are normally the coords of the top-left and bottom-right corners (but not in drawfigcircle). xcn and ycn are the coords of the centre point. Note that diameters and radii have to be recomputed from scaled coordinates. */ define /* lconstant */ drawlatexcircle(x1,y1,x2,y2); lvars, v = lp(x1,y1), x1 = v(1), y1 = v(2), v = lp(x2,y2), x2 = v(1), y2 = v(2), diameter, radius, xcn, ycn; abs(x2-x1) -> diameter; diameter/2 -> radius; x1 + radius -> xcn; y1 + radius -> ycn; '\\put(' >!!<',' >!!<'){\\circle{' >!<(diameter) >!<'}}' enddefine; define /* lconstant */ drawtroffcircle(x1,y1,x2,y2); lvars v = dc(x1,y1), x1 = v(1), y1 = v(2), v = dc(x2,y2), x2 = v(1), y2 = v(2), size = abs(x2-x1); ptyc(y1+(size/2)); '\\h\'' >!!<'\'' >!<'\\D\'c' >!!<'\'' enddefine; define /* lconstant */ drawvedcircle(x1,y1,x2,y2); lvars x1,y1,x2,y2, xc = (x1 + ((x2-x1)/2)), yc = (y1 + ((y2-y1)/2)); lconstant white_code = 8; sd_primitive_pdr("box")(x1,y1,x2,y2); enddefine; define /* lconstant */ drawfigarc(x1,y1,x2,y2,s_angle,i_angle); lvars v = fp(x1,y1), x1 = v(1), y1 = v(2), v = fp(x2,y2), x2 = v(1), y2 = v(2), xr = (abs(x2-x1) div 2), yr = (abs(y2-y1) div 2), xc = x1+xr, yc = y1+yr, x2,y2,x3,y3, s_angle, i_angle; false -> fig_last_line_segment(1); round(s_angle) fi_* 64 -> s_angle; round(i_angle) fi_* 64 -> i_angle; rotate_coords(xc+xr,yc+yr,xc,yc,s_angle) -> (x1,y1); rotate_coords(xc+xr,yc+yr,xc,yc,s_angle+(i_angle div 2)) -> (x2,y2); rotate_coords(xc+xr,yc+yr,xc,yc,s_angle+i_angle) -> (x3,y3); '5 1 '>!!!!!!!!<' 0 '>!!<' 0.000 1 0 0 ' >!!<' ' >!!<' ' >!!!!!!!!!!! fig_last_line_segment(1); '1 2 '>!!<' '>!!<' ' >!!!< depth_spec>!<' 0 '>!!<' 0.000 1 0.000 ' >!!<' ' >!!<' ' >!!<' ' >!!<' ' >!!<' ' >!!<' ' >!!<' ' >! s_angle; round(i_angle) fi_* 64 -> i_angle; if border_spec == [] then XpwDrawArc(sd_widget(sd_display), x1,y1, xd, yd, s_angle, i_angle); else XpwFillArc(sd_widget(sd_display), x1,y1, xd, yd, s_angle, i_angle); endif; enddefine; define /* lconstant */ drawXcircle(x1,y1,x2,y2); lvars x1,y1,x2,y2; drawXarc(x1,y1,x2,y2,0,-360); enddefine; /* --- Arrows --------------------------------------- */ define /* lconstant */ arrow_wings(x1,y1,x2,y2) -> left_wing -> right_wing; lvars wing_len = 5, arrow_thinness = 2, x1 y1 x2 y2 left_wing right_wing, xd = x1-x2, yd = y1-y2, td = abs(xd) + abs(yd), xc = 1, yc = 1, c; if td /= 0 do abs(xd)/td -> xc; abs(yd)/td -> yc; endif; /* if line_size_spec do line_size_spec -> c; wing_len * c -> wing_len endif; */ x2 + (sign(xd) * xc * wing_len) -> x1; y2 + (sign(yd) * yc * wing_len) -> y1; [% x2, y2, round(x1+((y2-y1)/arrow_thinness)), round(y1-((x2-x1)/arrow_thinness)) %] -> left_wing; [% x2, y2, round(x1-((y2-y1)/arrow_thinness)), round(y1+((x2-x1)/arrow_thinness)) %] -> right_wing; enddefine; define /* lconstant */ draw_arrow(x1,y1,x2,y2); lvars x1,y1,x2,y2; if sd_allow_arrows do "arrow" -> special_case; endif; sd_primitive_pdr("line")(x1,y1,x2,y2); enddefine; /* --- Lines --------------------------------------- */ define /* lconstant */ exceeded_limit(s,c,l); lvars s c l; sign(s) = 1 and c >= l or sign(s) = -1 and c <= l enddefine; define /* lconstant */ makelatexlines(x1,y1,x2,y2,xs,ys); lvars c = 0.25,,x1,y1,x2,y2,olx=x1,oly=y1,x=x1,y=y1,rx=round(x1),ry=round(y1),lx=x1,ly=y1,orx=rx,ory=ry,xs,ys,rxs=round(xs),rys=round(ys),finished = false; until finished do x + (xs * c) -> x; y + (ys * c) -> y; rx + (rxs * c) -> rx; ry + (rys * c) -> ry; orx + (rxs * c) -> orx; ory + (rys * c) -> ory; if ((exceeded_limit(xs,orx,x2) or exceeded_limit(ys,ory,y2)) and (true ->> finished)) or ((abs(rx-x) > 3 or abs(ry-y) > 3) /* too far off real line*/) then if finished then if lx /== x1 do ->; ->; /* take previous two lines off stack */ endif; olx -> lx; oly-> ly; orx -> rx; ory -> ry; x2 -> x; y2 -> y; else until exceeded_limit(xs,x,rx) and exceeded_limit(ys,y,ry) do x + (xs * 0.1) -> x; y + (ys * 0.1) -> y; enduntil; lx -> olx; rx -> orx; ly -> oly; ry -> ory; endif; drawlatexlineat(lx,ly,rx,ry); drawlatexlineat(rx,ry,x,y); x ->> lx -> rx; y ->> ly -> ry; endif; enduntil; enddefine; define /* lconstant */ makelatexdots(x1,y1,x2,y2,xs,ys); lvars ys, xs, c = 0.1,,x1,y1,x2,y2,x=x1,y=y1; repeat drawlatexlineat(x,y,x,y+0.25); x + (xs * c) -> x; y + (ys * c) -> y; quitif(exceeded_limit(xs,x,x2) or exceeded_limit(ys,y,y2)); endrepeat; enddefine; define /* lconstant */ drawlatexlineat(x1,y1,x2, y2); lvars x1, y1, x2, y2, xs, oxs, ys, oys, rxs, rys, l, lx = abs(x1-x2), ly = abs(y1-y2), x y, d; dlocal pop_pr_places = 6; if x2-x1=0 then 0 ->> xs -> oxs; intof(sign(y2-y1)) ->> ys -> oys; elseif y2-y1=0 then intof(sign(x2-x1)) ->> xs -> oxs; 0 ->> ys -> oys; else min(abs(x2-x1),abs(y2-y1)) -> d; (abs(x2-x1) / d) * sign(x2-x1) -> xs; (abs(y2-y1) / d) * sign(y2-y1) -> ys; while max(abs(xs), abs(ys)) > 6 do xs*0.5->xs, ys*0.5 -> ys endwhile; if abs(xs-(round(xs)->>rxs)) < 0.0001 and abs(ys-(round(ys)->>rys)) < 0.0001 or iscaller(makelatexlines) do xs -> oxs; ys -> oys; rxs -> xs; rys -> ys; else makelatexlines(x1,y1,x2,y2,xs,ys); return; endif; endif; if xs /= 0 then lx -> l else ly -> l endif; if xs = 0 then intof(sign(ys)) -> ys; elseif ys = 0 then intof(sign(xs)) -> xs; endif; if xs /= 0 and ys /= 0 and lx + ly < 5 then makelatexdots(x1,y1,x2,y2,oxs,oys); return endif; '\\put(' >!!<',' >!!<'){\\line(' >!!<',' >!!<'){' >!!<'}}' enddefine; define /* lconstant */ drawlatexline(x1,y1,x2, y2); lvars pdr, v = lp(x1,y1), x1 = v(1), y1 = v(2), v = lp(x2,y2), x2 = v(1), y2 = v(2); drawlatexlineat(x1,y1,x2,y2); enddefine; define /* lconstant */ drawtroffline(x1,y1,x2,y2); lvars pdr, v = dc(x1,y1), x1 = v(1), y1 = v(2), v = dc(x2,y2), x2 = v(1), y2 = v(2); ptyc(y1); '\\h\'' >!!<'\'' >!<'\\D\'l' >!!<' ' >!< tn(y2-y1) >!<'\''; enddefine; define /* lconstant */ drawXline(x1,y1,x2,y2); lvars style, v = xp(x1,y1), x1 = v(1), y1 = v(2), v = xp(x2,y2), x2 = v(1), y2 = v(2), right, left; XpwDrawLine(sd_widget(sd_display), x1,y1,x2,y2); if special_case == "arrow" and sd_allow_arrows do arrow_wings(x1,y1,x2,y2) -> left -> right; XpwDrawLine(sd_widget(sd_display), explode(left)); XpwDrawLine(sd_widget(sd_display), explode(right)); endif; enddefine; define /* lconstant */ drawfigline(x1,y1,x2,y2); lvars v = fp(x1,y1), x, y, xs, ys, x1 = v(1), y1 = v(2), v = fp(x2,y2), x2 = v(1), y2 = v(2), arrow = false, left, right; if ispair(fig_last_line_segment(1) ->> xs) and hd(xs) = x1 and ispair(fig_last_line_segment(2) ->> ys) and hd(ys) = y1 and fig_last_line_segment(3) = fig_line_style and fig_last_line_segment(4) == fig_line_size and fig_last_line_segment(5) == fig_colour_code and fig_last_line_segment(6) == depth_spec and fig_last_line_segment(7) = fig_dash_gap then erase(); /* erase last line command and replace it with extension */ conspair(x2, xs) -> xs; conspair(y2, ys) -> ys; '2 1 ' >!!!<' ' >!!!!<' 0 0 ' >!!<'0 ' >!<'0 0'>!< '\n ' >!< consstring( #| for x,y in xs,ys do explode(x >!<' '>!!<' ') endfor |#) >!< ' 9999 9999'; else '2 1 ' >!!!<' ' >!!!!<' 0 0 ' >!!<'0 ' >!<'0 0'>!< '\n ' >!!<' ' >!!<' ' >!!<' ' >!!<' 9999 9999'; [%x2,x1%] -> xs; [%y2,y1%] -> ys; endif; fill(xs,ys,fig_line_style,fig_line_size,fig_colour_code,depth_spec, fig_dash_gap,fig_last_line_segment) ->; if special_case == "arrow" and sd_allow_arrows then arrow_wings(x1,y1,x2,y2) -> left -> right; explode(left) -> (x1,y1,x2,y2); '2 1 ' >!!!<' ' >!!!!<' 0 0 ' >!!<'0 ' >!<'0 0'>!< '\n ' >!!<' ' >!!<' ' >!!<' ' >!!<' 9999 9999'; explode(right) -> (x1,y1,x2,y2); '2 1 ' >!!!<' ' >!!!!<' 0 0 ' >!!<'0 ' >!<'0 0'>!< '\n ' >!!<' ' >!!<' ' >!!<' ' >!!<' 9999 9999'; endif; enddefine; define /* lconstant */ drawvedline(x1,y1,x2,y2); lvars s, x, y,v, x1, y1, x2, y2, d, ystep, wiggley_threshold = 0.6; dlocal %dc%; if x1 = x2 then '|' elseif y1 = y2 then '-' else false endif -> s; dc(x1,y1) -> v; explode(v) -> y1 -> x1; dc(x2,y2) -> v; explode(v) -> y2 -> x2; /* stop coords from being converted twice */ dcid -> dc; if s and not(sd_allow_curved_ved_lines) then max(x1,x2); min(x1,x2) -> x1 -> x2; max(y1,y2); min(y1,y2) -> y1 -> y2; /* shorten lines */ if x1=x2 and y2-y1 > 1 then y1+1->y1; y2-1->y2 endif; if y1=y2 and x2-x1 > 1 then x1+1->x1; x2-1->x2 endif; for x from x1 to x2 do for y from y1 to y2 do vedinsertstringat(x,y,s) endfor; endfor; else /* dcid -> dc; */ y1 -> y; (y2-y1)*0.1 -> ystep; for x from x1 by ((x2-x1)*0.1) to x2 do y + ystep -> y; if abs(x - round(x)) < wiggley_threshold and abs(y - round(y)) < wiggley_threshold do sd_primitive_pdr("string")(x,y, '.'); endif; if (x1 >= x2 and x <= x2 or x1 <= x2 and x >= x2) and (y1 >= y2 and y <= y2 or y1 <= y2 and y >= y2) then quitloop endif; endfor; endif; enddefine; /* --- Curves (undocumented feature) -------------------------------------- */ /* define /* lconstant */ drawtroffcurve(coords); vars l, x1 = coords(1)(1), y1 = coords(1)(2), x2, y2, s; tyc(y1); '\\h\'' >!< txc(x1) >!< '\'\\D\'~'; for l in tn(coords) do l --> [?x2 ?y2]; tn(xc(x2)-xc(x1)) >!<'u ' >!!<'u'; x2 -> x1; y2 -> y1; endfor; -> s; s >!< '\''; enddefine; */ /* --- Boxes --------------------------------------- */ uses bitvectors; define /* lconstant */ drawbox(x1,y1,x2,y2); dlocal dc = dcid; lvars x1 y1 x2 y2; sd_primitive_pdr("line")(x1,y1,x2,y1); sd_primitive_pdr("line")(x1,y1,x1,y2); sd_primitive_pdr("line")(x2,y1,x2,y2); sd_primitive_pdr("line")(x1,y2,x2,y2); enddefine; define /* lconstant */ drawfilledXbox(x1,y1,x2,y2,a); lvars x1,y1,x2,y2, a, v = xp(x1,y1), x1 = v(1), y1 = v(2), v = xp(x2,y2), x2 = v(1), y2 = v(2), s = abs(y1-y2), yc = y1 + ((y2-y1) / 2), xc = x1 + ((x2-x1) / 2), x,y, widget = sd_widget(sd_display), ; rotate_coords(x1,yc,xc,yc,a) -> (x1,y1); rotate_coords(x2,yc,xc,yc,a) -> (x2,y2); round(s) -> XptVal widget (XtN lineWidth :XptDimension); XpwDrawLine(widget,round(x1),round(y1),round(x2),round(y2)); enddefine; define /* lconstant */ drawunfilledXbox(x1,y1,x2,y2); lvars x, y, v = xp(x1,y1), x1 = v(1), y1 = v(2), v = xp(x2,y2), x2 = v(1), y2 = v(2), xd = (abs(x2-x1)), yd = (abs(y2-y1)), c; if special_case == "clear" then XpwClearArea(sd_widget(sd_display),x1,y1,xd,yd+1); elseif border_spec == [] then XpwDrawRectangle(sd_widget(sd_display),x1,y1,xd,yd); else ;;;XpwFillRectangle(sd_widget(sd_display),x1,y1,xd,yd); endif; enddefine; define drawXbox(x1,y1,x2,y2); dlocal rotation_spec; lvars a = rotation_spec; if border_spec == [] then drawunfilledXbox(x1,y1,x2,y2); else 0 -> rotation_spec; drawfilledXbox(x1,y1,x2,y2,a); endif; enddefine; define /* lconstant */ drawfigbox(x1, y1, x2,y2); lvars v = fp(x1,y1), x1 = v(1), y1 = v(2), v = fp(x2,y2), x2 = v(1), y2 = v(2); false -> fig_last_line_segment(1); '2 2 '>!!!!!!!!<' 0 ' >!!< ' 0.000 0 0 0' >!< '\n ' >!!!!!!!!!!< space >!!!!!!!< x1 >!!!<' 9999 9999' enddefine; define /* lconstant */ drawlatexbox(x1,y1,x2,y2); lvars y2, y1, y, x1, x2, width = abs(x2-x1) * sd_udxc(sd_display), v = lp(x1,y1), lx1= v(1), ly1 = v(2), v = lp(x2,y2), lx2 = v(1), ly2 = v(2); if colour_shade_spec and colour_shade_spec = 1 then for y from ly1 to ly2 do '\\put(' >!!<',' >!<(sd_dymax(sd_display)- y) >!<'){\\line(1,0){' >!!<'}}'; endfor; else '\\put(' >!!<',' >!!<'){\\framebox(' >!!<',' >!!<')[l]{}}'; endif; enddefine; define /* lconstant */ drawtroffbox(x1,y1,x2,y2); lvars y2, x2, y1, x1, y, x = tn(xdl(x2-x1)), v = tp(x1,y1), tx1= v(1), ty1 = v(2), v = tp(x2,y2), tx2 = v(1), ty2 = v(2); if isnumber(colour_shade_spec) and colour_shade_spec = 1 then for y from ty1 to ty2 do ptyc(y); '\\h\'' >!!<' \\D\'l' >!!<' 0i\'' endfor; else ty1; cons_with consstring {% explode('\\h\'' >!!<' ' >!< '\\D\'l' >!!<' 0i\'' >!< '\\D\'l 0i ' >!!<'\'' >!< '\\D\'l' >!!<' 0i\'' >!< '\\D\'l 0i ' >!!<'\'') %} endif; enddefine; define /* lconstant */ drawvedbox(x1,y1,x2,y2); lvars y, v = vp(x1,y1), x1= v(1), y1 = v(2), v = vp(x2,y2), x2 = v(1), y2 = v(2); if colour_shade_spec and colour_shade_spec = 1 then for y from y1 to y2 do sd_primitive_pdr("line")(x1,y,x2,y) endfor; else drawbox(x1,y1,x2,y2); endif; enddefine; /* --- Strings ------------------------------------- */ define /* lconstant */ drawXstring(x,y,s); lvars s, x, y, v = xp(x,y), x = v(1), y = v(2); XpwDrawString(sd_widget(sd_display),x,y,s); enddefine; define /* lconstant */ drawXstringin(x1,y1,x2,y2,s); lvars v = xp(x1,y1), x1 = v(1), y1 = v(2), v = xp(x2,y2), x2 = v(1), y2 = v(2), s, xd = abs(x2 - x1), yd = abs(y1-y2), n = length(s), widget = sd_widget(sd_display), m; round(xd/n) * 1.5 -> m; set_X_font(widget, m) -> ; XpwDrawString(sd_widget(sd_display),fi_min(x1,x2),fi_max(y1,y2),s); enddefine; define /* lconstant */ drawfigstring(x,y,s); lvars v = fp(x,y), x = v(1), y = v(2), s, font_num = 14 /* courier-bold*/, y_size, x_size = round(length(s) * 6.5); false -> fig_last_line_segment(1); fig_font_size -> y_size; if not(skipchar(32,1,s)) then return /* fig doesn't like empty strings */ endif; '4 0 ' >!!<' ' >!!<' 0 ' >!!!!<' 0.000 4 ' >!!<' ' >!!< ' ' >!!<' ' >!<(y+3) >!<' ' >!!<(consstring(1,1)); enddefine; define /* lconstant */ drawfigstringin(x1,y1,x2,y2,s); lvars s, v = fp(x1,y1), x1 = v(1), y1 = v(2), v = fp(x2,y2), x2 = v(1), y2 = v(2), y_size = abs(y1-y2), x_size = abs(x1-x2), xd = abs(x2 - x1); dlocal dc = dcid; round(xd/length(s)) * 1.5 -> fig_line_size; /* fixes font size */ drawfigstring(fi_min(x1,x2),fi_max(y1,y2), s); enddefine; define /* lconstant */ drawvedstring(x,y,s); dlocal vedline, vedcolumn, vvedlinesize, vedstatic = true, vedbreak = false; lvars s, v = vp(x,y), x = v(1), y = v(2); vedjumpto(y,x); vedinsertstring(s); enddefine; define drawtroffstring(x,y,str); lvars str, x y, i, v = tp(x,y), tx = v(1), ty = v(2); ty; '\\h\'' >!!<' ' >! str endfor endif; explode(lp(x,y)) -> y -> x; '\\put(' >!!<',' >!!<'){' >!!<'}' enddefine; /* --- Spaces --------------------------------------- */ define /* lconstant */ draw_space(x1,y1,x2,y2); lvars x, y, v = xp(x1,y1), x1 = v(1), y1 = v(2), v = xp(x2,y2), x2 = v(1), y2 = v(2), xd = round(abs(x2-x1)), yd = round(abs(y2-y1)); if sd_display_type = "X" then XpwClearArea(sd_widget(sd_display),x1,y1,xd,yd); else /* a pretty stupid thing to try and do ... */ endif; enddefine; define /* lconstant */ draw_blanks(x,y,n); lvars c = round(sqrt(sd_default_font_size) + 1), v = xp(x,y), x = v(1)-2, y = v(2)-(6+c), xd = n*(5+c), yd = 8+c; if sd_display_type == "X" then XpwClearArea(sd_widget(sd_display), x, y, xd, yd); endif; enddefine; /* -- Quitting ved display file -------------------- */ define /* lconstant */ quitveddisplay(); lvars file; [% for file in vedbufferlist do unless vedbuffername(file) = sd_output_file do file endunless endfor %] -> vedbufferlist; enddefine; /* -- Top level procedures ------------------------------- */ define /* lconstant */ is_display_type(x); lvars x; member(x, sd_display_types); enddefine; define /* lconstant */ write_display_buffer(buffer, file); lvars dev = sd_create(file,1,"line"), buffer i s, file; sysseek(dev, 0 ,2); /* jump to end of file */ fast_for i from 1 to length(buffer) do fast_subscrv(i, buffer) >!< '\n' -> s; syswrite(dev,s, datalength(s)); endfor; syswrite(dev,'\n',1); sysclose(dev); enddefine; define sd_primitive_pdr(primitive) -> pdr; lvars l primitive pdr, map; unless (primitive_map(sd_display_type) ->> map) and (map(primitive) ->> pdr) do [^sd_display_type ^primitive ^pdr ^(primitive_map(sd_display_type)(primitive))] ==> mishap('Unknown drawing primitive for showdisplay', [^primitive]); endunless; enddefine; define set_defaults; false -> special_case; if sd_display_type=="X" then 0 -> XptVal (sd_widget(sd_display))(XtN lineStyle); sd_default_line_size -> XptVal (sd_widget(sd_display)) (XtN lineWidth); unless sd_font_size(sd_display) == sd_default_font_size do set_X_font(sd_widget(sd_display), sd_default_font_size) ->; endunless; set_X_colour(sd_widget(sd_display), sd_pen_colour) ->; elseif sd_display_type == "fig" then '0 ' -> fig_line_style; '0.000 ' -> fig_dash_gap; 21 -> fig_fill_level; /* means obj is filled with relevant colour */ get_fig_colour_code(sd_pen_colour) -> fig_colour_code; 1 -> fig_line_size; 10 -> fig_font_size; endif; enddefine; define /* lconstant */ handle_optional_specs(primitive); lvars primitive, style, size, code, spec, widget; if colour_spec then if isvector(colour_spec) then if isword(colour_spec(1)) then /* colour with shade val */ colour_spec(2) -> colour_shade_spec; colour_spec(1) -> colour_spec; else sd_convert_RGB_spec(colour_spec) -> colour_spec; endif; endif; if sd_display_type == "X" then if not(sd_allow_colour) then /* simulate colour with colour shade */ unless colour_shade_spec do sd_colour_darkness(colour_spec)-1 -> colour_shade_spec; endunless; "gainsboro" -> colour_spec; /* gray */ endif; if colour_shade_spec and (sd_make_RGB_spec(colour_spec, colour_shade_spec) ->> spec) then spec -> colour_spec; endif; if colour_spec then set_X_colour(sd_widget(sd_display), colour_spec) ->; endif; elseif sd_display_type == "fig" then if sd_allow_colour and (get_fig_colour_code(colour_spec) ->> code) do code -> fig_colour_code; elseif (sd_colour_codes(colour_spec) ->> code) then /* choose a fill level to simulate colour */ 1 + (code mod 19) -> fig_fill_level; get_fig_colour_code("black" ->> colour_spec) -> fig_colour_code; endif; if colour_shade_spec then /* use fill-level to simulate shade */ round(1 + (((colour_shade_spec + 1) / 2) * 20)) -> fig_fill_level; endif; endif; endif; if border_spec == [] then if sd_display_type == "fig" then 0 -> fig_fill_level; else /* nothing - X pdrs handle this spec themselves */ endif; endif; if line_size_spec then if sd_display_type == "fig" do line_size_spec ->> fig_line_size -> fig_font_size; elseif sd_widget(sd_display) ->> widget then if primitive == "string" then set_X_font(sd_widget(sd_display), line_size_spec) ->; else line_size_spec -> XptVal widget (XtN lineWidth); endif; endif; endif; if line_style_spec and sd_allow_line_styles then length(line_style_spec) -> style; /* could be more sophisticated ?? */ if sd_display_type == "X" then if primitive == "string" then set_X_font(sd_widget(sd_display), line_style_spec) ->; else min(2, style) -> XptVal (sd_widget(sd_display)) (XtN lineStyle); endif; elseif sd_display_type == "fig" then (style mod 3) >!< space -> fig_line_style; '-1 ' -> fig_dash_gap; ((style - 1) div 2) + 1 -> size; if fig_line_style = '1 ' then (size * 2) + 2 >!< '.000 ' -> fig_dash_gap; elseif fig_line_style = '2 ' then (size * 2) >!< '.000 ' -> fig_dash_gap; endif; endif; endif; enddefine; define /* lconstant */ apply_primitive_pdr(pdr, args); lvars args, arg, i, n = pdnargs(pdr), m = length(args), optional_args = [], type, code, primitive; /* remember first arg is primitive name */ args(1) -> primitive; {% for i from n+2 to m do fast_subscrv(i, args) endfor %} -> optional_args; {% for i from 2 to n+1 do fast_subscrv(i, args) endfor %} -> args; false ->> colour_shade_spec ->> border_spec ->> line_style_spec ->> line_size_spec ->> colour_spec -> boolean_spec; 0 ->> depth_spec -> rotation_spec; for i to length(optional_args) do fast_subscrv(i, optional_args) -> arg; if isstring(arg) do arg -> line_style_spec; elseif isinteger(arg) and arg fi_> 0 then arg -> line_size_spec; elseif isinteger(arg) and arg fi_<= 0 then abs(arg) -> depth_spec; elseif isword(arg) do arg -> colour_spec; elseif isvector(arg) then /* explicit RGB spec */ arg -> colour_spec; elseif isboolean(arg) do arg -> boolean_spec; elseif islist(arg) do arg -> border_spec; elseif (isdecimal(arg) or isratio(arg)) then if arg <= 0 do -((arg * 2) + 1) -> colour_shade_spec; elseif arg > 0 then arg -> rotation_spec; endif; endif; endfor; set_defaults(); handle_optional_specs(primitive); if sd_display_type == "fig" and fig_colour_code == 7 then /* white */ return endif; apply(explode(args), pdr); enddefine; define /* lconstant */ drawdisplay(drawcomms); lvars i, drawcomms, primitive, args, n, comm, finished = false, pdr; if islist(drawcomms) then for comm in drawcomms do comm(1) -> primitive; until isprocedure(sd_primitive_pdr(primitive) ->> pdr) do warning('Couldnt get pdr for primitive', [^sd_display_type ^primitive]); enduntil; apply_primitive_pdr(pdr, comm); ;;;syssleep(100); endfor; elseif isvector(drawcomms) then for i from 1 to length(drawcomms) do fast_subscrv(i, drawcomms) -> comm; comm(1) -> primitive; /* if issubstring_lim('draw_',1,1,false,primitive) then warning('Old style showdisplay primitive', [^(drawcomms(i))]); consword(substring(6,length(primitive)-5,primitive)) -> primitive; endif; */ apply_primitive_pdr(sd_primitive_pdr(primitive), comm); endfor; endif; enddefine; define /* lconstant */ explode_val(l); if length(l) > 0 and l(1) = "popval" then popval(tn(l)) else explode(l) endif; enddefine; /* Set up mapping from display-types and primitives to pdrs (have to do it after all forward refs have been resolved) */ vars /* lvars */ primitive display_type id map, primitive_map = newassoc([]); for display_type in sd_display_types do nextif(display_type == "screen"); for primitive in sd_primitives do if (sys_current_ident("draw" <> display_type <> primitive) ->> id) or (sys_current_ident("draw_" <> primitive) ->> id) do unless (primitive_map(display_type) ->> map) do newassoc([]) ->> primitive_map(display_type) -> map; endunless; idval(id) -> map(primitive); endif; endfor; endfor; vars sd_primitive_map = primitive_map; define /* lconstant */ process_optional_args -> args; lvars args = [], arg; repeat -> arg; if isboolean(arg) then (arg ->> sd_incremental) :: args -> args; elseif fast_lmember(arg, sd_display_types) then (arg ->> sd_display_type) :: args -> args; elseif isstring(arg) then (arg ->> sd_current_display_name ->> sd_output_file) :: args -> args; else /* not an optional sd arg - stop and jump out */ arg; quitloop; endif; endrepeat; if sd_display_type == "screen" then if sd_display_screen do "X" else "ved" endif -> sd_display_type; endif; enddefine; define sd_process_optional_args; process_optional_args() ->; enddefine; define sd_pop_optional_args -> args; lvars args; dlocal sd_incremental, sd_display_type, sd_output_file; process_optional_args() -> args; enddefine; /* compatibility */ define sd_get_args; sd_pop_optional_args(); enddefine; define global showdisplay; lvars comms, oldwindow = vedstartwindow, buffer, y, len display, oldchanged = vedchanged, owner, widget; dlocal sd_current_display_name, sd_output_file, sd_display_type, sd_incremental, 0 %,(0 -> max_troff_y_coord)%, vednotabs = false, vedstatic, vedinitfile vedautowrite = false, vedstartwindow = vedwindowlength, pop_pr_ratios = false; sd_process_optional_args(); -> comms; set_display(comms); if islist(comms) or isvector(comms) then comms -> last_commands; if not(sd_incremental) do comms -> sd_commands(sd_display) endif; drawdisplay(%comms%) -> comms; endif; if sd_display_type == "X" then if not(sd_double_buffering) then comms(); else (sd_widget(sd_display), sd_invisible_widget(sd_display)) -> (sd_invisible_widget(sd_display), sd_widget(sd_display)); comms(); (sd_widget(sd_display), sd_invisible_widget(sd_display)) -> (sd_invisible_widget(sd_display), sd_widget(sd_display)); copy_image(sd_invisible_widget(sd_display), sd_widget(sd_display)); endif; elseif sd_display_type /= "ved" then vedputmessage('Constructing display...'); { % explode_val(sd_wrapperstrings(sd_display_type)(1)) % ^(comms()) %if sd_display_type == "troff" do /* kludge to get right scaling */ '.nr T \\n(.su*' >!!<'u\n.sp |\\nOu+\\nTuu\n.sp 0.35i\n.ps'; endif; explode_val(sd_wrapperstrings(sd_display_type)(2)); % } -> buffer; write_display_buffer(buffer, sd_output_file); vedputmessage('Display written to: ' >! vedinitfile; if vedcurrent = sd_output_file then sd_init(); oldwindow -> vedstartwindow; sd_incremental == true -> vedediting; unless sd_incremental do vedscreenclear(); ved_clear(); procedure; dlocal vedediting = true; vedputmessage('Constructing display...') endprocedure(); endunless; comms(); vedjumpto(round(sd_dymax(sd_display)+5),1); true -> vedstatic; vedjumpto(1, 1); true -> vedediting; endif; vedinitfile() endprocedure(% vedinitfile %) -> vedinitfile; if sd_incremental and sd_output_file = vedcurrent then vedinitfile(); else if vedediting then vedsaveglobals(vedcurrentfile) endif; quitveddisplay(); sysdelete(sd_output_file) ->; vededitor(sd_veddefaults, sd_output_file); endif; false -> vedchanged; endif; sd_trap(); sd_default_display_type -> sd_display_type; /* has to be done here - sd_get_args can be called many times on the way in */ enddefine; /* -- Colour allocation/deallocation --------------- */ /* THIS CRASHES POPLUG under X11R6 compile_mode: pop11 +strict; ;;; FOR XptBoolean TYPE include xpt_coretypes; XptLoadProcedures 'fixed_color_allocation' lvars XFreeColors, XAllocNamedColor ; ;;; AS NEEDED BY XAllocNamedColor l_typespec XColor { pixel :ulong, red :ushort, green :ushort, blue :ushort, flags :byte, pad :byte }; ;;; MAPPING BETWEEN STRINGS AND PIXEL VALUES lconstant pixel_val=newmapping([], 255, false, false); /* * Set the foreground of the specified widget to the colour * named in the string, returning the pixel number of the * allocated colour. * Returns -false- if the colour couldn't be allocated */ define sd_set_color(widget, string) -> pixel; lvars widget, string, pixel=false; lconstant ;;; ACTUAL COLOUR ALLOCATED screen_c_ptr = initexptr_mem(SIZEOFTYPE(:XColor)), ;;; EXACT SPECIFICATION OF COLOUR exact_c_ptr = initexptr_mem(SIZEOFTYPE(:XColor)) ; ;;; UNLESS WE'VE GOT THE COLOUR BEFORE... unless string.pixel_val ->> pixel then ;;; TRY AND FETCH THE COLOR... exacc (5):XptBoolean raw_XAllocNamedColor( widget.XtDisplay, XptVal widget(XtN colormap), string, screen_c_ptr, exact_c_ptr ) -> pixel; ;;; ...AND CACHE THE PIXEL IF WE SUCEED if pixel then exacc :XColor screen_c_ptr.pixel ->> pixel -> string.pixel_val endif; endunless; ;;; SET THE FOREGROUND IF POSSIBLE if pixel then pixel -> XptVal widget(XtN foreground); endif; enddefine; /* * Free colours allocated with -sd_set_color- */ define sd_free_color(widget, string); lvars widget, string; lconstant pixels_ptr = initexptr_mem(SIZEOFTYPE(:ulong)); if string.pixel_val then string.pixel_val -> exacc :ulong pixels_ptr; exacc (5) raw_XFreeColors( widget.XtDisplay, XptVal widget(XtN colormap), pixels_ptr, 1, 0, ); false -> pixel_val(string); endif; enddefine; compile_mode: pop11 +normal; */