english version "1.0" identify "wxyz" # Copyright (c) 1998-1999 by Wayne C. Gramlich. # All rights reserved. # # Permission to use, copy, modify, distribute, and sell this software # for any purpose is hereby granted without fee provided that the above # copyright notice and this permission are retained. The author makes # no representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. module swit_canvas #: This module implments a SWIT canvas of items. import address character format integer logical out_stream string swit swit_color swit_clone swit_frame swit_group swit_item swit_restore swit_tcl_command swit_types swit_widget system table unsigned vector #: {canvas} procedures: procedure background_get@canvas takes canvas canvas returns color #: This procedure will return the background color of {canvas}. return canvas.widget.background procedure background_set@canvas takes canvas canvas color color returns_nothing #: This procedure will set the backgound color of {canvas} to {color}. canvas.widget.background := color procedure canvas_binding_create@canvas routine_types procedure call_back takes item, string, integer, integer returns_nothing takes canvas canvas tag string event_name event_name call_back call_back returns canvas_binding #: This procedure will create and return a {canvas_binding} object #, that binds {call_back} to {event_name} and {tag} name pair for {canvas}. assert canvas.is_master event_handler :@= event_handler_create@(canvas.widget) uid :@= uid_next@(canvas) canvas_binding :@= create@canvas_binding(canvas, tag, event_handler, event_name, call_back, uid) canvas_binding_insert@(canvas, canvas_binding) increment@(canvas_binding) application :@= canvas.widget.application assert !insert@(application.uid2binding, uid, canvas_binding) return canvas_binding procedure border_width_get@canvas takes canvas canvas returns unsigned #: This procedure will return the desired border_width of {canvas}. return canvas.border_width procedure border_width_set@canvas takes canvas canvas border_width unsigned returns_nothing #: This procedure will set the desired border_width of {canvas} #, to {border_width}. canvas.xborder_width := border_width increment@(canvas) procedure canvas_binding_insert@canvas takes canvas canvas canvas_binding canvas_binding returns_nothing #: This procedure will insert {canvas_binding} into the binding #, list in {canvas}. bindings :@= canvas.bindings size :@= bindings.size index :@= size loop while index != 0 index :-= 1 binding :@= bindings[index] if binding.uid < canvas_binding.uid index :+= 1 break insert@(bindings, index, canvas_binding) procedure clone@canvas takes master_canvas canvas frame frame returns canvas #system :@= standard@system() #debug_stream :@= system.error_out_stream #format@format2[address, address](debug_stream, # "clone@canvas(0x%x%, 0x%x%\n\", master_canvas.address, frame.address) clone_canvas :@= create@canvas(frame, master_canvas.widget.uid, master_canvas.group.item.uid) clone :@= frame.clone tcl_command :@= tcl_command_start@(clone) string_append@(tcl_command, "canvas") window_path_append@(clone_canvas, tcl_command) tcl_command_send@(clone) # Force an update: clone_canvas.xwidth := 0 return clone_canvas procedure clone_get@canvas takes canvas canvas returns clone #: This procedure will return the parent {clone} object associated #. with {canvas}. return canvas.widget.clone procedure create@canvas takes parent frame uid unsigned group_uid unsigned returns canvas #: This procedure will create and return a {canvas} widget with a #, unique identifier of {uid}, with a parent frame of {parent}. #, {group_uid} is the unique identifier to be assigned to the #, {group_item} in the returned {canvas} object. system :@= standard@system() bindings :@= allocate@vector[canvas_binding]() initialize canvas:: canvas := allocate@canvas() canvas.bindings := bindings canvas.black := create@color("black") canvas.image_grab := false canvas.image_grab_binding := ?? canvas.group := root_create@item_group(canvas, group_uid) canvas.transparent := create@color("") canvas.white := create@color("white") canvas.widget := create@widget1[canvas](uid, parent, canvas, canvas_set@widget_additional) canvas.xborder_width := 3 canvas.xwidth := 100 canvas.xheight := 100 # Create the image grab event binding: if canvas.is_master image_grab_binding :@= canvas_binding_create@(canvas, "", special, image_grab_call_back@canvas) canvas_binding_insert@(canvas, image_grab_binding) canvas.image_grab_binding := image_grab_binding return canvas procedure destroy@canvas takes canvas canvas returns_nothing #: This procedure will destroy {canvas}. destroy@widget1[canvas](canvas) procedure drop@canvas takes canvas canvas returns_nothing #: This procedure will cause {canvas} to go away. drop@widget1[canvas](canvas) procedure event@canvas takes canvas canvas line string index unsigned returns_nothing #: This process will process an event sent to {canvas} with #, remaining the data remaining in {line} starting at {index}. system :@= standard@system() debug_stream :@= system.error_out_stream clone :@= canvas.clone application :@= clone.application debug :@= application.debug if debug format@format3[address, string, unsigned](debug_stream, "Canvas Event: address=0x%x% line=%d% index=%d%\n\", canvas.address, line, index) zero :@= unsigned_convert@("0"[0]) size :@= line.size # Extract the binding uid: binding_uid :@= 0 loop while index < size character :@= line[index] while is_digit@(character) binding_uid := binding_uid * 10 + unsigned_convert@(character) - zero index :+= 1 index :+= 1 # Extract the item uid: item_uid :@= 0 loop while index < size character :@= line[index] while is_digit@(character) item_uid := item_uid * 10 + unsigned_convert@(character) - zero index :+= 1 index :+= 1 # Extract the x coordinate x :@= 0 loop while index < size character :@= line[index] while is_digit@(character) x := x * 10 + unsigned_convert@(character) - zero index :+= 1 index :+= 1 # Extract the x coordinate y :@= 0 loop while index < size character :@= line[index] while is_digit@(character) y := y * 10 + unsigned_convert@(character) - zero index :+= 1 index :+= 1 if debug format@format4[unsigned, unsigned, unsigned, unsigned](debug_stream, "event@canvas: binding_uid=%d% item_uid=%d% x=%d% y=%d%\n\", binding_uid, item_uid, x, y) # Deal with special cases here: if binding_uid = 0 if item_uid = 0 # This is a print event: put@("Print event\n\", debug_stream) else_if debug format@format1[unsigned](debug_stream, "Unknown special canvas event: %d%\n\", item_uid) else canvas_binding :@= lookup@(application.uid2binding, binding_uid) if canvas_binding !== ?? item :@= lookup@(application.uid2item, item_uid) if item !== ?? parent :@= item.parent canvas_binding.call_back(item, canvas_binding.tag, integer_convert@(x) - parent.item.x_absolute, integer_convert@(y) - parent.item.y_absolute) else_if debug format@format1[unsigned](debug_stream, "Could not find item with uid %d%\n\", item_uid) else_if debug format@format1[unsigned](debug_stream, "Could not find binding with uid %d%\n\", binding_uid) procedure foreground_get@canvas takes canvas canvas returns color #: This procedure will return the foreground color of {canvas}. return canvas.widget.foreground procedure foreground_set@canvas takes canvas canvas color color returns_nothing #: This procedure will set the foregound color of {canvas} to {color}. canvas.widget.foreground := color procedure height_get@canvas takes canvas canvas returns unsigned #: This procedure will return the desired height of {canvas}. return canvas.height procedure height_set@canvas takes canvas canvas height unsigned returns_nothing #: This procedure will set the desired height of {canvas} to {height}. canvas.xheight := height increment@(canvas) procedure image_grab@canvas takes canvas canvas returns string #: This procedure will cause the first slave canvas associated #, with {canvas} to return a bitmap of the canvas. canvas.image_grab := true return "" procedure image_grab_call_back@canvas takes item item tag string x integer y integer returns_nothing #: This procedure is called when a image grab event occurs: system :@= standard@system() debug_stream :@= system.error_out_stream put@("image_grab_call_back@canvas() called\n\", debug_stream) procedure increment@canvas takes canvas canvas returns_nothing #: This procedure will increment the modification count for {canvas}. increment@(canvas.widget) procedure is_master_get@canvas takes canvas canvas returns logical #: This procedure will create and return {true} if {canvas} is #, a member of the master clone tree and {false} otherwise. return canvas.clone.is_master procedure parent_get@canvas takes canvas canvas returns frame #: This procedure will return the parent {frame} for {canvas}. return canvas.widget.parent procedure restore@canvas takes restore restore frame frame returns canvas #: This procedure will restore the canvas from {restore} into {frame}. line_read@(restore, "C") height :@= unsigned_read@(restore) width :@= unsigned_read@(restore) border_width :@= unsigned_read@(restore) line_end@(restore) canvas :@= canvas_create@(frame) canvas.xheight := height canvas.xwidth := width canvas.xborder_width := border_width return canvas procedure save@canvas takes canvas canvas save_stream out_stream returns_nothing #: This procedure will save {canvas} to {save_stream}. format@format3[unsigned, unsigned, unsigned](save_stream, "C %d% %d% %d%\n\", canvas.xheight, canvas.xwidth, canvas.xborder_width) procedure uid_next@canvas takes canvas canvas returns unsigned #: This procedure will return a unique identifier for use #, in identifying items in {canvas}. return uid_next@(canvas.clone) procedure update@canvas takes master_canvas canvas clone_canvas canvas returns_nothing #: This procedure will update {clone_canvas} with the contents #, {master_canvas}. #system :@= standard@system() #debug_stream :@= system.error_out_stream #format@format2[address, address](debug_stream, # "update@canvas(0x%x%, 0x%x%)\n\", # master_canvas.address, clone_canvas.address) if !is_synchronized@widget1[canvas](master_canvas, clone_canvas) master_widget :@= master_canvas.widget clone_widget :@= clone_canvas.widget master_background :@= master_widget.background clone_background :@= clone_widget.background master_border_width :@= master_canvas.xborder_width clone_border_width :@= clone_canvas.xborder_width master_foreground :@= master_widget.foreground clone_foreground :@= clone_widget.foreground master_height :@= master_canvas.xheight clone_height :@= clone_canvas.xheight master_width :@= master_canvas.xwidth clone_width :@= clone_canvas.xwidth if master_background != clone_background || master_border_width != clone_border_width || master_foreground != clone_foreground || master_height != clone_height || master_width != clone_width # Configure the canvas: clone :@= clone_canvas.clone tcl_command :@= tcl_command_start@(clone) # Configure the canvas -- "{winpath} configure options...": window_path_append@(clone_canvas, tcl_command) string_append@(tcl_command, "configure") option_append@(tcl_command, "-bg") background_color_append@(master_widget, tcl_command) clone_canvas.widget.xbackground := master_background # There is no -fg attribute for a canvas: option_append@(tcl_command, "-borderwidth") unsigned_append@(tcl_command, master_border_width) clone_canvas.xborder_width := master_border_width option_append@(tcl_command, "-height") unsigned_append@(tcl_command, master_height) clone_canvas.xheight := master_height option_append@(tcl_command, "-width") unsigned_append@(tcl_command, master_width) clone_canvas.xwidth := master_width tcl_command_send@(clone) # Update any items that have changed: master_group :@= master_canvas.group clone_group :@= clone_canvas.group master_count :@= master_group.item.modification_count clone_count :@= clone_group.item.modification_count if master_count != clone_count update@(master_group, clone_group) # Update any level changes: master_count := master_group.level_modification_count clone_count := clone_group.level_modification_count if master_count != clone_count level_update@(master_group, clone_group) master_count := master_group.level_modification_count clone_count := clone_group.level_modification_count assert master_count = clone_count # Update any binding changes: master_bindings :@= master_canvas.bindings clone_bindings :@= clone_canvas.bindings master_size :@= master_bindings.size clone_size :@= clone_bindings.size master_index :@= 0 clone_index :@= 0 loop while master_index < master_size || clone_index < clone_size master_uid :@= 0xffffffff master_binding:: canvas_binding := ?? if master_index < master_size master_binding :@= master_bindings[master_index] master_uid := master_binding.uid clone_uid :@= 0xffffffff clone_binding:: canvas_binding := ?? if clone_index < clone_size clone_binding :@= clone_bindings[clone_index] clone_uid := clone_binding.uid if master_uid = clone_uid update@(master_binding, clone_binding) master_index :+= 1 clone_index :+= 1 else_if master_uid < clone_uid clone_binding := clone@(master_binding, clone_canvas, master_uid) insert@(clone_bindings, clone_index, clone_binding) clone_size :+= 1 else delete@(clone_bindings, clone_index) destroy@(clone_binding) clone_size :-= 1 if master_canvas.image_grab # We use the first clone canvas only: master_canvas.image_grab := false clone :@= clone_canvas.clone image_grab_binding :@= master_canvas.image_grab_binding tcl_command :@= tcl_command_start@(clone) # 'set ps [{winpath} postscript]': string_append@(tcl_command, "set ps [") window_path_append@(clone_canvas, tcl_command) string_append@(tcl_command, "postscript ]; ") # 'regsub -all "\n" $ps " " ps': string_append@(tcl_command, 'regsub -all "\\n" $ps " " ps ;') # 'puts {socket} "E {handler} 0 0 0 0 $ps"': string_append@(tcl_command, "puts") string_append@(tcl_command, clone.socket_name) string_append@(tcl_command, "\q\E") unsigned_append@(tcl_command, image_grab_binding.event_handler.number) string_append@(tcl_command, "0 0 0 0 $ps\q\") tcl_command_send@(clone) synchronize@widget1[canvas](master_canvas, clone_canvas) procedure width_get@canvas takes canvas canvas returns unsigned #: This procedure will return the desired width of {canvas}. return canvas.width procedure width_set@canvas takes canvas canvas width unsigned returns_nothing #: This procedure will set the desired width of {canvas} to {width}. canvas.xwidth := width increment@(canvas) procedure window_path_append@canvas takes canvas canvas tcl_command tcl_command returns_nothing #: This procedure will append the window path for {canvas} #, to {tcl_command}. window_path_append@(canvas.widget, tcl_command) #: {canvas_binding} procedures: procedure clone@canvas_binding takes master_binding canvas_binding clone_canvas canvas uid unsigned returns canvas_binding #: This procedure will clone a copy of {master_binding} for {canvas} #, with a unique identifier of {uid}. clone_binding :@= create@canvas_binding(clone_canvas, master_binding.tag, master_binding.event_handler, master_binding.event_name, master_binding.call_back, master_binding.uid) return clone_binding procedure create@canvas_binding routine_types procedure call_back takes item, string, integer, integer returns_nothing takes canvas canvas tag string event_handler event_handler event_name event_name call_back call_back uid unsigned returns canvas_binding #: This procedure will create and return a {canvas_binding} object #, consisting of {canvas}, {tag}, {event_handler}, {event_name}, #, {call_back}, and {uid}. system :@= standard@system() initialize canvas_binding:: canvas_binding := allocate@canvas_binding() canvas_binding.call_back := call_back canvas_binding.event_handler := event_handler canvas_binding.event_name := event_name canvas_binding.modification_count := 0 canvas_binding.parent := canvas canvas_binding.tag := tag canvas_binding.uid := uid increment@(canvas_binding) return canvas_binding procedure destroy@canvas_binding takes canvas_binding canvas_binding returns_nothing #: This procedure will destroy {canvas_binding}. assert false procedure increment@canvas_binding takes canvas_binding canvas_binding returns_nothing #: This procedure will increment the modification count for #, {canvas_binding}. canvas_binding.modification_count :+= 1 increment@(canvas_binding.parent) procedure update@canvas_binding takes master_binding canvas_binding clone_binding canvas_binding returns_nothing #: This procedure will update the contents of {clone_binding} to #, be the same as {master_binding}. if master_binding.modification_count != clone_binding.modification_count clone_binding.call_back := master_binding.call_back clone_binding.event_handler := master_binding.event_handler clone_binding.event_name := master_binding.event_name clone_binding.tag := master_binding.tag if clone_binding.event_name != special clone_canvas :@= clone_binding.parent clone :@= clone_canvas.clone tcl_command :@= tcl_command_start@(clone) window_path_append@(clone_canvas, tcl_command) string_append@(tcl_command, "bind") string_append@(tcl_command, clone_binding.tag) string_append@(tcl_command, string_convert@(clone_binding.event_name)) string_append@(tcl_command, "{set tags [") window_path_append@(clone_canvas, tcl_command) string_append@(tcl_command, "gettags [") window_path_append@(clone_canvas, tcl_command) string_append@(tcl_command, "find withtag current]]") string_append@(tcl_command, " ; regsub {(^T)([0-9]*)(.*)} $tags {\\2} uid") string_append@(tcl_command, " ; puts ") string_append@(tcl_command, clone.socket_name) string_append@(tcl_command, " \q\E") unsigned_append@(tcl_command, clone_binding.event_handler.number) unsigned_append@(tcl_command, clone_binding.uid) string_append@(tcl_command, "$uid %x %y\q\}") tcl_command_send@(clone) clone_binding.modification_count := master_binding.modification_count