diff options
Diffstat (limited to 'ipl/gpacks')
147 files changed, 31621 insertions, 0 deletions
diff --git a/ipl/gpacks/README b/ipl/gpacks/README new file mode 100644 index 0000000..3575dc7 --- /dev/null +++ b/ipl/gpacks/README @@ -0,0 +1,8 @@ + carpets numerical carpets + drawtree tree-drawing package + ged text editor + htetris Tetris game + tiger map drawing from Census TIGER data + vib graphics interface builder + weaving programs and procedures related to weaving + xtiles game diff --git a/ipl/gpacks/carpets/Makefile b/ipl/gpacks/carpets/Makefile new file mode 100644 index 0000000..1c814a5 --- /dev/null +++ b/ipl/gpacks/carpets/Makefile @@ -0,0 +1,14 @@ +# note that only carport is built here +# carplay is built by the carport program after generating carpincl.icn + +carport: + icont -usc carputil carprec + icont -us carport + + +# build executable and copy to ../../iexe +# (nothing done in this case because the executable doesn't stand alone) +Iexe: + +Clean: + rm -f carport carplay carpincl.icn *.u[12] diff --git a/ipl/gpacks/carpets/README b/ipl/gpacks/carpets/README new file mode 100644 index 0000000..b744040 --- /dev/null +++ b/ipl/gpacks/carpets/README @@ -0,0 +1,2 @@ +Programs for exploring numerical carpets. +See issue 45 of the Icon Analyst. diff --git a/ipl/gpacks/carpets/carplay.icn b/ipl/gpacks/carpets/carplay.icn new file mode 100644 index 0000000..34fe2ab --- /dev/null +++ b/ipl/gpacks/carpets/carplay.icn @@ -0,0 +1,283 @@ +############################################################################ +# +# File: carplay.icn +# +# Subject: Program to create "carpets" +# +# Author: Ralph E. Griswold +# +# Date: January 11, 1998 +# +############################################################################ +# +# This is an experimental program under development to produce carpets +# as specificed in the include file, carpincl.icn, which is produced by +# carport.icn. +# +############################################################################ +# +# Requires: Version 9 graphics and large integers +# +############################################################################ +# +# Links: carputil, lists, matrix, mirror, options, wopen +# +# Note: The include file may contain link declarations. +# +############################################################################ + +link carputil +link lists +link matrix +link mirror +link options +link wopen + +$include "carpincl.icn" + +$ifdef Randomize +link random +$endif + +$ifdef Scramble +link random +$endif + +$ifdef Background +$undef Hidden +$undef Save_carpet +$undef Dialogs +$undef Save_mirror +$define Hidden +$define Save_carpet +$endif + +$ifdef Dialogs +link interact +$undef Save_carpet +$undef Save_mirror +$endif + +global array +global cmod +global colors +global height +global modulus +global width + +procedure main() + local mcarpet + +$ifdef Randomize + randomize() +$endif + +# The carpet-generation process is now done by two procedures, the first to +# initialize the edges and the second to actually create the carpet. This +# has been done to allow possible extensions. + + init() + + weave() + +$ifdef Mirror + mcarpet := mirror(&window) # produced mirrored image +$endif + +$ifndef Hidden +$ifdef Mirror + WAttrib(mcarpet, "canvas=normal") # make the mirrored image visible + Raise() +$endif +$endif + +$ifdef Dialogs + Bg("light gray") # reset colors for dialogs + Fg("black") + repeat { # provide user dialog + case TextDialog("Save images?", , , , + ["Quit", "Save Image", "Save Mirrored"]) of { + "Quit" : exit() + "Save Image" : snapshot() + "Save Mirrored" : snapshot() + } + } +$else + +$ifdef Save_carpet + WriteImage(Name || ".gif") +$ifdef Save_mirror + WriteImage(Name || "_m.gif") +$endif +$endif + +$ifndef Hidden + repeat case Event() of { # process low-level user events + "q" : exit() + "s" : WriteImage(Name || ".gif") + "m" : WriteImage(Name || "_m.gif") + } +$endif +$endif + + +end + +# Initialize the carpet + +procedure init() + local m, n, v, canvas + + colors := carpcolr(Colors) | { + +$ifdef Dialogs + Notice("Unrecognized color specification.", "Palette c2 substituted.") +#else + write(&errout, "Unrecognized color specification.", "\n", + "Palette c2 substituted.") +$endif + + colors := colrplte("c2") + } + + cmod := *colors + + # The definitions in the following expressions may not be constants. + # Assignments are made to avoid expressions being evaluated multiple + # times. This not only prevents unnecessary evaluation later, but it + # also prevents values from changing while the carpet is being + # generated. + + modulus := Modulus + width := Width + height := Height + + array := create_matrix(height, width, 0) + +$ifdef Hidden + canvas := "canvas=hidden" +$else + canvas := "canvas=normal" +$endif + + WOpen(canvas, "size=" || width || "," || height) | { + +$ifdef Dialogs + ExitNotice("Cannot open window for carpet.") +$else + stop("Cannot open window for carpet.") +$endif + + } + + # Initialize the edges. + + m := 0 + every v := (Left \ height) do { + array[m +:= 1, 1] := v % modulus + } + + n := 0 + every v := (Top \ width) do { + array[1, n +:= 1] := v % modulus + } + + return + +end + +$ifndef Twopass # do modulus reduction on the fly. + +# Create the carpet. + +procedure weave() + local m, n + + every m := 1 to height do { + if *Pending() > 0 then { + if Event() === "q" then exit() + } + every n := 1 to width do { + +$ifdef Wrap + array[m, n] := neighbor( + array[(m - 1) | -1, (n - 1) | -1], + array[(m - 1) | -1, n], + array[m, (n - 1) | -1] + ) % modulus +$else + array[m, n] := neighbor( + array[m, n - 1], + array[m - 1, n - 1], + array[m - 1, n], + ) % modulus +$endif + + Fg(colors[(abs(integer(array[m, n])) % cmod) + 1]) + DrawPoint(n - 1, m - 1) + } + } + + return + +end + +$else # do modulus reduction on a second pass + +# In this version, the computations are made in plain arithmethic and +# then modulo-reduced in a second pass. The results are the same as +# long as all operations have satisfy the relationship (i op j) % n = +# (i % n) op (j % n). This is true for addition, subtraction, and +# multiplication. + +procedure weave() + local m, n + + every m := 1 to height do { + if *Pending() > 0 then { + if Event() === "q" then exit() + } + } + every n := 1 to width do { + +$ifdef Wrap + array[m, n] := neighbor( + array[(m - 1) | -1, (n - 1) | -1], + array[(m - 1) | -1, n], + array[m, (n - 1) | -1] + ) + } + } +$else + array[m, n] := neighbor( + array[m, n - 1], + array[m - 1, n - 1], + array[m - 1, n], + ) + } + } + +$endif + + every m := 1 to height do { + if *Pending() > 0 then { + if Event() === "q" then exit() + } + } + every n := 1 to width do { + Fg(colors[(abs(integer(array[m, n] % modulus)) % cmod) + 1]) + DrawPoint(n - 1, m - 1) + } + } + + return + +end + +$endif + +procedure neighbor(n, nw, w) + + return Neighbors + +end diff --git a/ipl/gpacks/carpets/carport.icn b/ipl/gpacks/carpets/carport.icn new file mode 100644 index 0000000..12c0351 --- /dev/null +++ b/ipl/gpacks/carpets/carport.icn @@ -0,0 +1,1156 @@ +############################################################################# +# +# File: carport.icn +# +# Subject: Program to create numerical carpets +# +# Author: Ralph E. Griswold +# +# Date: September 17, 1998 +# +############################################################################ +# +# This is a program for specifying "numerical carpets". It writes a $include +# file and compiles and executes carplay.icn to produce the actual carpet. +# +############################################################################ +# +# For the basic idea that motivated this program, see "Carpets and Rugs: An +# Exercise in Numbers", Dann E. Passoja and Akhlesh Lakhtakia, in The +# Visual Mind: Art and Mathematics, Michele Emmer, ed., The MIT Press, +# 1993, pp. 121-123. +# +# The concepts and general operation of this application are described in +# Issue 45 of The Icon Analyst (December, 1997). For on-line documentation +# on using this program, see +# +# http://www.cs.arizona.edu/icon/analyst/iasub/ia45/programs/doc.htm +# +############################################################################ +# +# Requires: Version 9 graphics, system(), and carplay.icn. +# +############################################################################ +# +# Links: carputil, interact, io, tables, vsetup, xcode +# +############################################################################ + +link carputil +link carprec +link interact +link io +link tables +link vsetup +link xcode + +global db_entries # list of specifications in database +global db_file # name of database file +global spec # current carpet specification +global database # database of specifications +global def_entries # list of definitions +global dopt_list # list of display options +global dset_list # list of display option states +global fopt_list # list of generation options +global fset_list # list of generation option states +global touched # database changed switch +global vidgets # table of interface tools + +$define NameDefault "default" +$define TopDefault "1" +$define LeftDefault "Top" +$define WidthDefault "128" +$define HeightDefault "Width" +$define ModulusDefault "5" +$define NeighborsDefault "n + nw + w" +$define LinksDefault ["seqfncs"] +$define ColorsDefault image("c2") + +$define SymWidth 15 # width of definition name field +$define DefWidth 80 # width of definition field +$define ExprWidth 80 # width of expression field +$define NameWidth 40 # width of name field + +procedure main() + + carprec + + init() + + GetEvents(vidgets["root"], , shortcuts) + +end + +# Add (or overwrite) definition. + +procedure add_def() + + if TextDialog("Add definition:", ["name", "definition"], , + [SymWidth, ExprWidth]) == "Cancel" then fail + + spec.Defns[dialog_value[1]] := dialog_value[2] + refresh_defs() + + return + +end + +# Add link + +procedure add_link() + + if OpenDialog("Add link:", , , , 20) == "Cancel" then fail + + put(spec.Links, dialog_value) + refresh_links() + + return + +end + +# Clear the database of specifications (a default one is then added). + +procedure clear_db() + + case TextDialog("Are you sure you want to clear the current database?", + , , , ["Yes", "No"]) of { + "No" : fail + "Yes": { + database := table() + new_spec() + database[spec.Name] := spec + refresh_db() + return + } + } + +end + +# Clear the table of definitions. + +procedure clear_defs() + + if TextDialog("Do you really want to clear the definition table?") == + "Cancel" then fail + + spec.Defns := table() + refresh_defs() + + return + +end + +# Clear all the links. + +procedure clear_links() + + if TextDialog("Do you really want to clear all links?") == + "Cancel" then fail + + spec.Links := [] + refresh_links() + + return + +end + +# Edit specification comments. + +procedure comments() + + repeat { + case TextDialog("Comments:", , spec.Comments, ExprWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default": { + spec.Comments := &dateline # default comments + next + } + "Okay" : { + spec.Comments := dialog_value[1] + break + } + } + } + + return + +end + +# Create a carpet from the current specification. + +procedure create_cb() + local path, output, i + + WAttrib("pointer=watch") + + output := open("carpincl.icn", "w") | { + Notice("Cannot open include file for writing.") + fail + } + + every i := 1 to *dopt_list do + if \dset_list[i] then + write(output, "$define ", map(dopt_list[i][1], &lcase, &ucase), + map(dopt_list[i][2:0], " ", "_")) + + every i := 1 to *fopt_list do + if \fset_list[i] then + write(output, "$define ", map(fopt_list[i][1], &lcase, &ucase), + fopt_list[i][2:0]) + + close(output) + + write_spec("carpincl.icn", spec) | { + Notice("Cannot open include file for writing.") + fail + } + + path := dpath("carplay.icn") | { + Notice("Fatal error; cannot find carpet generation program.") + exit() + } + + system("icont -s " || path || " -x") + + WAttrib("pointer=arrow") + + return + +end + +# Items for Database menu. + +procedure database_cb(vidget, value) + + case value[1] of { + "load ^@L": load_db() + "merge ^@M": load_db(1) # argument indicates merger + "revert ^@R": load_db(2) # argument indicates reversion + "save ^@S": save_db() + "save as ^@T": save_as_db() + "clear ^@Z": clear_db() + } + +end + +# Callback for item selected from database list. + +procedure db_cb(vidget, value) + local state + static db, sw + + initial db := vidgets["db"] + + if /value then return # deselected item + + if \sw then { # prevent loop from internal call + sw := &null + return + } + + state := VGetState(db) # save state to restore position + + repeat { + case TextDialog("Specification " || value, , , , + ["Delete", "Display", "Okay", "Cancel"], 3) of { + "Cancel": fail + "Okay" : { + spec.Name := value + spec := database[spec.Name] + refresh_defs() + refresh_db() + sw := 1 + VSetState(db, state) + refresh_links() + return + } + "Delete": { + if value == spec.Name then { + Notice("You cannot delete the current specification.") + next + } + delete(database, value) + refresh_db() + return + } + "Display": { + display_spec(database[value]) + next + } + } + } + +end + +# Make the expression in the current dialog into a definition. + +procedure define(s) + + if TextDialog("Add definition:", ["name", "definition"], [, s], + [SymWidth, ExprWidth]) == "Cancel" then fail + + spec.Defns[dialog_value[1]] := dialog_value[2] + refresh_defs() + + return + +end + +# Items for the Definitions menu. + +procedure definitions_cb(vidget, value) + + case value[1] of { + "add @A": add_def() + "clear @Z": clear_defs() + "load @F": load_defs() + "merge @J": load_defs(1) # nonnull argument indicates merger + "save @S": save_defs() + } + + return + +end + +# Callback for selection from the definitions text-list. + +procedure defs_cb(vidget, value) + + if /value then fail + + case TextDialog("Name: " || value, "definition", spec.Defns[value], + ExprWidth , ["Remove", "Okay", "Cancel"], 2) of { + "Remove": { + delete(spec.Defns, value) + refresh_defs() + } + "Okay" : spec.Defns[value] := dialog_value[1] + "Cancel": fail + } + + return + +end + +# Display all the current definitions. + +procedure display_defs() + local definition, lines, i + + if *def_entries = 0 then { + Notice("The definition table is empty.") + fail + } + + lines := [] + + every definition := !def_entries do + put(lines, left(definition, 12) || + left(spec.Defns[definition], ExprWidth)) + + push(lines, "", "name definition ") + + Notice ! lines + + return + +end + +# Display a carpet specification. + +$define FieldWidth (SymWidth + 1) + +procedure display_spec(dspec) + local lines, s, lst + + /dspec := spec + + lines := [ + "Specifications:", + "", + left("Name", FieldWidth) || dspec.Name, + left("Modulus", FieldWidth) || dspec.Modulus, + left("Width", FieldWidth) || dspec.Width, + left("Height", FieldWidth) || dspec.Height, + left("Top Row", FieldWidth) || dspec.Top, + left("Left Column", FieldWidth) || dspec.Left, + left("Neighbors", FieldWidth) || dspec.Neighbors, + left("Colors", FieldWidth) || dspec.Colors, + left("Comments", FieldWidth) || (\dspec.Comments | "") + ] + + if *dspec.Defns > 0 then { + put(lines, "", "Definitions:", "") + every put(lines, left(s := !keylist(dspec.Defns), FieldWidth) || + (\dspec.Defns[s] | "") \ 1) + } + + if *dspec.Links > 0 then { + put(lines, "", "Links:", "") + every put(lines, !dspec.Links) + } + + Notice ! lines + + return + +end + +# Write all specifications in include form + +procedure dump_all() + local spec + static dump_file + + repeat { + case OpenDialog("Save database as text:", dump_file) of { + "Okay" : { + every spec := database[!db_entries] do + write_spec(dialog_value, spec) + dump_file := dialog_value + return + } + "Cancel": fail + } + } + +end + +# Duplicate the current specification and make it current. + +procedure dupl_spec() + + spec := copy(spec) + spec.Defns := copy(spec.Defns) + refresh_defs() + name_spec(1) # nonnull means don't delete the old one + refresh_db() + + return + +end + +# Items for the File menu. + +procedure file_cb(vidgets, value) + + case value[1] of { + "generate @G": create_cb() + "display @D": doptions() + "options @O": foptions() + "quit @Q": quit() + } + + return + +end + +# Display options. + +procedure doptions() + + if ToggleDialog("Specify display options:", dopt_list, dset_list) == + "Cancel" then fail + else { + dset_list := dialog_value + return + } + +end + +# Display options. + +procedure foptions() + + if ToggleDialog("Specify generation options:", fopt_list, fset_list) == + "Cancel" then fail + else { + fset_list := dialog_value + return + } + +end + +# Set the carpet height. + +procedure height() + + repeat { + case TextDialog("Height:", , spec.Height, NameWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default": { + spec.Height := HeightDefault + next + } + "Okay" : { + spec.Height := dialog_value[1] + break + } + } + } + + return + +end + +# Initialize the application. + +procedure init() + local atts + + atts := ui_atts() + push(atts, "posx=10", "posy=10") + + (WOpen ! atts) | ExitNotice("Cannot open interface window.") + + vidgets := ui() + + database := table() + new_spec() + + db_file := &null + touched := &null + + dopt_list := [ # list of display options + "mirror", # show mirror image + "hidden", # hide images + "save carpet", # save carpet image automatically + "save mirror", # save mirror image automatically + "dialogs", # provide dialogs + "background" # run in background + ] + dset_list := list(*dopt_list) # choices + dset_list[1] := 1 # initially only enable mirroring + + fopt_list := [ # list of generation options + "wrap", # wrap edges + "randomize", # randomize + "two pass" # two-pass generation + ] + fset_list := list(*fopt_list) # choices + + return + +end + +# Edit the left-side expression. + +procedure left_expr() + + repeat { + case TextDialog("Left:", , spec.Left, ExprWidth, + ["Define", "Default", "Okay", "Cancel"], 3) of { + "Define" : { + define(dialog_value[1]) + break + } + "Cancel" : fail + "Default": { + spec.Left := LeftDefault + next + } + "Okay" : { + spec.Left := dialog_value[1] + break + } + } + } + + return + +end + +# Items for the Link menu. + +procedure link_cb(vidget, value) + + case value[1] of { + "add ^@A": add_link() + "clear ^@C": clear_links() + } + + return + +end + +# Callback for selection of an item from the links text-list. + +procedure links_cb(vidget, value) + local i, j, tmp + + if /value then return # deselected item + + case TextDialog("Link: " || value, , , , ["Remove", "Cancel"], 1) of { + "Remove": { + i := VGetState(vidgets["links"])[2] # second element is line number + tmp := [] + every (j := 1 to i - 1) | (j := i + 1 to *spec.Links) do + put(tmp, spec.Links[j]) + spec.Links := tmp + refresh_links() + } + "Cancel": fail + } + + return + +end + +# Load a carpet database. If sw is null, it replaces the current database. +# If sw is one, it is merged with the current database. If sw is 2, the +# database reverts to the last one loaded. + +procedure load_db(sw) + local input, tbl, caption + + caption := if sw === 2 then { + if \touched & \db_file then "Revert to last saved database?" + else { + Notice("Revert not possible or not necessary.") + fail + } + } + else "Load database:" + + repeat { + if OpenDialog(caption, db_file) == "Cancel" then fail + input := open(dialog_value) | { + Notice("Cannot open database.") + next + } + tbl := xdecode(input) | { + Notice("Cannot decode carpet database.") + next + } + db_file := dialog_value + close(input) + database := if sw === 1 then tblunion(database, tbl) else tbl + refresh_db(1) + spec := database[db_entries[1]] + return + } + +end + +# Load definitions file. + +procedure load_defs(sw) + local input, tbl + + repeat { + if OpenDialog("Specify definition file:") == "Cancel" then fail + input := open(dialog_value) | { + Notice("Cannot open definitions file.") + next + } + tbl := xdecode(input) | { + Notice("Cannot decode definitions.") + next + } + spec.Defns := if /sw then tbl else tblunion(spec.Defns, tbl) + close(input) + refresh_defs() + return + } + +end + +# Edit the modulus. + +procedure modulus() + + repeat { + case TextDialog("Modulus:", , spec.Modulus, NameWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default": { + spec.Modulus := ModulusDefault + next + } + "Okay" : { + spec.Modulus := dialog_value[1] + break + } + } + } + + return + +end + +procedure colors() + + repeat { + case TextDialog("Colors:", , spec.Colors, ExprWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default": { + spec.Colors := ColorsDefault + next + } + "Okay" : { + spec.Colors := dialog_value[1] + break + } + } + } + + return + +end + +# Edit the specification name. + +procedure name_spec(sw) + local old_name + + old_name := spec.Name + + if OpenDialog("Name:", spec.Name) == "Cancel" then fail + else { + spec.Name := dialog_value + database[dialog_value] := spec + if /sw then delete(database, old_name) + refresh_db() + } + + return + +end + +# Edit the neighbors expression. + +procedure neighbors() + + repeat { + case TextDialog("Neighborhood:", , spec.Neighbors, ExprWidth, + ["Define", "Default", "Okay", "Cancel"], 3) of { + "Define" : { + define(dialog_value[1]) + break + } + "Cancel" : fail + "Default": { + spec.Neighbors := NeighborsDefault + next + } + "Okay" : { + spec.Neighbors := dialog_value[1] + break + } + } + } + + return + +end + +# Create a fresh, empty definitions table. + +procedure new_defs() + + spec.Defns := table() + refresh_defs() + + return + +end + +# Create a fresh, empty links list. ??? what about clear_links()? + +procedure new_links() + + spec.Links := LinksDefault + refresh_links() + + return + +end + +# Create a new carpet specification from the default. + +procedure new_spec() + + spec := carpet() + spec.Name := NameDefault + spec.Width := WidthDefault + spec.Height := HeightDefault + spec.Modulus := ModulusDefault + spec.Top := TopDefault + spec.Left := LeftDefault + spec.Neighbors := NeighborsDefault + spec.Colors := ColorsDefault + spec.Comments := &dateline + + new_defs() + new_links() + + database[spec.Name] := spec + refresh_db() + + return + +end + +# Items for the Parameters menu. + +procedure edit_cb(vidget, value) + + case value[1] of { + "modulus @M": modulus() + "width @W": width() + "height @H": height() + "top @T": top_expr() + "left @L": left_expr() + "neighbors @N": neighbors() + "colors @C": colors() + "name @I": name_spec() + "comments @K": comments() + } + + return + +end + +# Quit the application. + +procedure quit() + + if /touched then exit() + + case SaveDialog("Save database?", db_file) of { + "Cancel": fail + "No" : exit() + "Yes" : { + save_db() + exit() + } + } + + return + +end + +# Refresh the carpet database. + +procedure refresh_db(sw) + + VSetItems(vidgets["db"], db_entries := keylist(database)) + + if sw === 1 then spec := database[db_entries[1]] + + update() + + if /sw then touched := 1 + + return + +end + +# Refresh the table of definitions. + +procedure refresh_defs() + + VSetItems(vidgets["defs"], def_entries := keylist(spec.Defns)) + + touched := 1 + + return + +end + +# Refresh the list of links. + +procedure refresh_links() + + VSetItems(vidgets["links"], sort(spec.Links)) + + touched := 1 + + return + +end + +# Save the current database to a specified file. + +procedure save_as_db() + local output, file + + repeat { + if OpenDialog("Save database:", db_file) == "Cancel" then fail + file := dialog_value + if exists(file) then { + if TextDialog("Overwrite existing file?") == "Cancel" then next + } + output := open(file, "w") | { + Notice("Cannot open database file for writing.") + next + } + db_file := file + xencode(database, output) + close(output) + touched := &null + return + } + +end + +# Save the current database + +procedure save_db() + local output + + if /db_file then return save_as_db() + + output := open(db_file, "w") | { + Notice("Cannot write database file.") + fail + } + + xencode(database, output) + + close(output) + + touched := &null + + return + +end + +# Save the current table of definitions to a file. + +procedure save_defs() + local output, file + + repeat { + if OpenDialog("Defns file:") == "Cancel" then fail + file := dialog_value + if exists(file) then { + if TextDialog("Overwrite existing file?") == "Cancel" then next + } + output := open(file, "w") | { + Notice("Cannot open definitions file for writing.") + next + } + xencode(spec.Defns, output) + close(output) + return + } + +end + +# Save the current specification as an include file. + +procedure save_spec() + static file + + initial file := "untitled.cpt" + + repeat { + if TextDialog("Save specifications:", ["name", "comments", "file"], + [spec.Name, spec.Comments, file], NameWidth) == "Cancel" then fail + spec.Name := dialog_value[1] + spec.Comments := dialog_value[2] + write_spec(dialog_value[3], spec) | { + Notice("Cannot write specification.") + next + } + file := dialog_value[3] + return + } + +end + +# Keyboard shortcuts. + +procedure shortcuts(e) + + if e === "\r" then create_cb() # quick generation initiation + else if &meta then case map(e, &lcase, &ucase) of { + "A" : add_def() + "C" : colors() + "D" : doptions() + "F" : load_defs() + "G" : create_cb() + "H" : height() + "I" : name_spec() + "J" : load_defs(1) + "K" : comments() + "L" : left_expr() + "M" : modulus() + "N" : neighbors() + "O" : foptions() + "Q" : quit() + "R" : show_colors() + "S" : save_defs() + "T" : top_expr() + "W" : width() + "X" : create_cb() + "Y" : display_defs() + "Z" : clear_defs() + "\^A": add_link() + "\^C": clear_links() + "\^D": dupl_spec() + "\^L": load_db() + "\^M": load_db(1) + "\^N": new_spec() + "\^R": load_db(2) + "\^S": save_db() + "\^T": save_as_db() + "\^W": save_spec() + "\^X": dump_all() + "\^Y": display_spec() + "\^Z": clear_db() + } + + return + +end + +procedure show_colors() + local colors + + colors := draw_colors(carpcolr(spec.Colors)) | { + Notice("Invalid color specification.") + fail + } + + WAttrib(colors, "label=" || spec.Colors) + + Event(colors) + + WClose(colors) + + Raise() + + return + +end + +# Items for the Specification menu. + +procedure specification_cb(vidget, value) + + case value[1] of { + "new ^@N": new_spec() + "copy ^@D": dupl_spec() + "display ^@Y": display_spec() + "write ^@W": save_spec() + } + + return + +end + +# Edit the top-row specification. + +procedure top_expr() + + repeat { + case TextDialog("Top:", , spec.Top, ExprWidth, + ["Define", "Default", "Okay", "Cancel"], 3) of { + "Define" : { + define(dialog_value[1]) + break + } + "Cancel" : fail + "Default": { + spec.Top := TopDefault + next + } + "Okay" : { + spec.Top := dialog_value[1] + break + } + } + } + + return + +end + +# Update the name of the current specification on the interface. + +procedure update() + static previous_name, sx, sy + + initial { + sx := vidgets["placeholder"].ax + sy := vidgets["placeholder"].ay + } + + # Update selection information on interface. + + WAttrib("drawop=reverse") + + DrawString(sx, sy, \previous_name) + DrawString(sx, sy, spec.Name) + + WAttrib("drawop=copy") + + previous_name := spec.Name + + return + +end + +# Edit the width of the carpet. + +procedure width() + + repeat { + case TextDialog("Width:", , spec.Width, NameWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default": { + spec.Width := WidthDefault + next + } + "Okay" : { + spec.Width := dialog_value[1] + break + } + } + } + + return + +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=457,276", "bg=gray-white", "label=carpets"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,457,276:carpets",], + ["current label:Label:::15,253,161,13:current specification: ",], + ["database:Menu:pull::35,0,64,21:Database",database_cb, + ["load ^@L","merge ^@J","save ^@S","save as ^@T","clear ^@Z", + "revert ^@R"]], + ["db:List:w::15,41,125,160:",db_cb], + ["definitions:Menu:pull::234,0,85,21:Definitions",definitions_cb, + ["add @A","load @F","merge @J","save @S","clear @Z"]], + ["definitions:Label:::166,209,98,13: definitions ",], + ["defs:List:w::160,41,125,160:",defs_cb], + ["edit:Menu:pull::99,0,36,21:Edit",edit_cb, + ["modulus @M","width @W","height @H","top @T","left @L", + "neighbors @N","colors @C","name @I","comments @K"]], + ["file:Menu:pull::0,0,36,21:File",file_cb, + ["generate @G","display @D","options @O","quit @Q"]], + ["line1:Line:::0,21,457,21:",], + ["line2:Line:::0,238,458,238:",], + ["link:Menu:pull::320,0,43,21:Links",link_cb, + ["add ^@A","clear ^@C"]], + ["link:Label:::313,209,98,13: links ",], + ["links:List:w::308,41,125,160:",links_cb], + ["placeholder:Label:::180,264,35,13: ",], + ["specification:Menu:pull::135,0,99,21:Specification",specification_cb, + ["new ^@N","copy ^@D","display ^@Y","write ^@W"]], + ["specifications:Label:::21,209,98,13:specifications",], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/carpets/carprec.icn b/ipl/gpacks/carpets/carprec.icn new file mode 100644 index 0000000..4601ab0 --- /dev/null +++ b/ipl/gpacks/carpets/carprec.icn @@ -0,0 +1,13 @@ + +record carprec( + Name, + Width, + Height, + Modulus, + Colors, + Hexpr, + Vexpr, + Nexpr, + Symbols, + Comments + ) diff --git a/ipl/gpacks/carpets/carputil.icn b/ipl/gpacks/carpets/carputil.icn new file mode 100644 index 0000000..77f0e2d --- /dev/null +++ b/ipl/gpacks/carpets/carputil.icn @@ -0,0 +1,269 @@ +############################################################################ +# +# File: carputil.icn +# +# Subject: Procedures to support numerical carpets +# +# Author: Ralph E. Griswold +# +# Date: January 16, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links: colrlist +# +############################################################################ + +link colrlist + +record carpet( # carpet specification + Name, + Width, + Height, + Modulus, + Colors, + Top, + Left, + Neighbors, + Defns, + Links, + Comments + ) + +record karpet( # karpet specification + Name, + Width, + Height, + Modulus, + Colors, + Paths, + Sweeps, + Neighbors, + Defns, + Links, + Comments + ) + +record pathexpr( # path expression + x, + y, + v + ) + +procedure carpcolr(cspec) + local clist + + clist := (colrhues | colrspec | colrplte | colrlist)(cspec) | fail + + return clist + +end + +# Convert string of color specifications to color list. + +procedure colrspec(s) + local lst, spec + + lst := [] + + s ? { + while spec := tab(upto(':')) do { + put(lst, ColorValue(spec)) | fail + move(1) + } + if not pos(0) then fail else return lst + } + +end + + +# Interpret string of characters as hues. + +procedure colrhues(s) + local lst, c + static hue_tbl, hues + + initial { + hue_tbl := table() + hue_tbl["R"] := "red" + hue_tbl["G"] := "green" + hue_tbl["B"] := "blue" + hue_tbl["C"] := "cyan" + hue_tbl["Y"] := "yellow" + hue_tbl["M"] := "magenta" + hue_tbl["k"] := "black" + hue_tbl["W"] := "white" + hue_tbl["O"] := "orange" + hue_tbl["P"] := "purple" + hue_tbl["V"] := "violet" + hue_tbl["b"] := "brown" + hue_tbl["p"] := "pink" + hue_tbl["G"] := "gray" + } + + lst := [] + + every c := !s do + put(lst, \hue_tbl[c]) | fail + + return lst + +end + +procedure write_spec(name, spec) + local n, output + static bar + + initial bar := repl("#", 72) + + output := open(name, "a") | fail + + every write(output, "link ", !sort(spec.Links)) + + write(output, "$define Comments ", image(spec.Comments)) + write(output, "$define Name ", image(spec.Name)) + write(output, "$define Width (", spec.Width, ")") + write(output, "$define Height (", spec.Height, ")") + write(output, "$define Modulus (", spec.Modulus, ")") + write(output, "$define Top (", spec.Top, ")") + write(output, "$define Left (", spec.Left, ")") + write(output, "$define Neighbors (", spec.Neighbors, ")") + write(output, "$define Colors ", spec.Colors) + + every n := !keylist(spec.Defns) do + write(output, "$define ", n, " (", spec.Defns[n], ")") + + write(output, bar) + + close(output) + + return + +end + +procedure write_spek(file, spec) + local n, output, links, initializers, p, weavers, neighbors, i + static bar + + initial bar := repl("#", 72) + + output := open(file, "w") | { + Notice("Cannot open include file for writing.") + fail + } + + every i := 1 to *dopt_list do + if \dset_list[i] then + write(output, "$define ", map(dopt_list[i][1], &lcase, &ucase), + map(dopt_list[i][2:0], " ", "_")) + + every i := 1 to *fopt_list do + if \fset_list[i] then + write(output, "$define ", map(fopt_list[i][1], &lcase, &ucase), + fopt_list[i][2:0]) + + write(output, "$define Comments ", image(specification["comments"])) + write(output, "$define Name ", image(specification["name"])) + write(output, "$define Width (", specification["width"], ")") + write(output, "$define Height (", specification["height"], ")") + write(output, "$define Modulus (", specification["modulus"], ")") + write(output, "$define Colors ", specification["colors"]) + + every n := !keylist(specification["definitions"]) do + write(output, "$define ", n, " (", specification["definitions"][n], ")") + + if *entries["initializers"] = 0 then { + Notice("No initializers.") + fail + } + else { + initializers := "$define Paths [" + every n := !entries["initializers"] do { + p := specification["initializers"][n] + initializers ||:= "pathexpr(create " || p.x || ", create " || p.y || + ", create " || p.v || ")," + } + write(output, initializers[1:-1], "]") + } + + if *entries["weavers"] = 0 then { + Notice("No weavers.") + fail + } + else { + weavers := "$define Weavers [" + every n := !entries["weavers"] do { + p := specification["weavers"][n] + weavers ||:= "pathexpr(create " || p.x || ", create " || p.y || ")," + } + write(output, weavers[1:-1], "]") + } + + if *specification["links"] > 0 then { + links := "$define Link " + every links ||:= !sort(specification["links"]) || ", " + write(output, links[1:-2]) + } + + if *specification["neighbors"] = 0 then { + Notice("No neighborhood expressions.") + fail + } + else { + neighbors := "$define Neighbors [" + every n := !keylist(specification["neighbors"]) do + neighbors ||:= "create " || specification["neighbors"][n] || "," + write(output, neighbors[1:-1], "]") + } + + write(output, bar) + + close(output) + + return + +end + +$define Cells 16 +$define Width 20 + +procedure draw_colors(clist) + local i, j, k, depth, color, colors + + depth := *clist / Cells + if *clist % Cells ~= 0 then depth +:= 1 + + WClose(\colors) + + colors := WOpen("size=" || (Cells * Width) || "," || (depth * Width), + "bg=black") | { + Notice("Cannot open window for color map.") + exit() + } + + every j := 0 to depth - 1 do + every i := 0 to Cells - 1 do { + color := get(clist) | break break + Fg(colors, color) | { + Notice("Cannot set foreground to " || image(color) || ".") + next + } + FillRectangle(colors, i * Width + 1, j * Width + 1, Width - 1, + Width - 1) + } + + Bg(colors, "dark gray") + Fg(colors, "black") + WAttrib(colors, "fillstyle=textured") + WAttrib(colors, "pattern=checkers") + + every k := i to Width - 1 do # fill out rest + FillRectangle(colors, k * Width + 1, j * Width + 1, Width - 1, Width - 1) + + return colors + +end diff --git a/ipl/gpacks/drawtree/Makefile b/ipl/gpacks/drawtree/Makefile new file mode 100644 index 0000000..770e719 --- /dev/null +++ b/ipl/gpacks/drawtree/Makefile @@ -0,0 +1,15 @@ +Build drawtree: + icont -s -c -u draw_crc + icont -s -c -u data + icont -s -c -u draw_sqr + icont -s -c -u draw_rec + icont -s -c -u draw_box + icont -s -c -u draw_bar + icont -s -c -u clr_list + icont -s -u drawtree + +Iexe: drawtree + cp drawtree ../../iexe/ + +Clean: + rm -f *.u* drawtree diff --git a/ipl/gpacks/drawtree/clr_list.icn b/ipl/gpacks/drawtree/clr_list.icn new file mode 100644 index 0000000..1021329 --- /dev/null +++ b/ipl/gpacks/drawtree/clr_list.icn @@ -0,0 +1,155 @@ +global shape_type + + +# main changing color procedure that setups the window and sets control +procedure change_color(shape) + + local fg, num, fill, tmp + + color_dialog_open := 1 + WAttrib(color_window, "canvas=normal") + + fg := Fg(color_window) + + num := 1 + every fill := !active_win_record.tree.color_list_u do { + Fg(color_window, fill) + FillRectangle(color_window, vidgets_color[string(num)].ux, + vidgets_color[string(num)].uy, + vidgets_color[string(num)].uw, + vidgets_color[string(num)].uh) + num +:= 1 + } + + Fg(color_window, fg) + + every num := !active_win_record.tree.color_list do + SetVidget(vidgets_color["color" || string(num)], 1) + + shape_type := shape + + return + +end + + + +# close the window and update the tree (picture) +procedure color_done_cb(vidget, value) + + color_dialog_open := &null + WAttrib(color_window, "canvas=hidden") + + case shape_type of { + "circle" : drawtree_circle(active_win_record.tree, children) + "rectangle" : drawtree_rectangle(active_win_record.tree, children) + "square" : { draw_grid(square_record) + drawtree_square(square_record, children, 0, square_record.x, + square_record.y, square_record.linewidth, + square_record.length) } + } + + sl_cb() + + return + +end + + + +procedure color_region_cb(vidget, e, x, y) + + ColorDialog("Select a new color:", + active_win_record.tree.color_list_u[integer(vidget.id)], + change_color_select, integer(vidget.id)) + return + +end + + + +procedure change_color_select(id, s) + + local fg + fg := Fg(color_window) + id := string(id) + + active_win_record.tree.color_list_u[id] := s + Fg(color_window, s) + FillRectangle(color_window, vidgets_color[id].ux, + vidgets_color[id].uy, + vidgets_color[id].uw, + vidgets_color[id].uh) + Fg(color_window, fg) + +end + + +procedure select_color_cb(vidget, value) + + local num, id, con + + con := 1 + + vidget.id ? { + tab(upto('1234567')) + num := tab(0) + } + + if /value then { + every id := 1 to *active_win_record.tree.color_list do { + if num == string(active_win_record.tree.color_list[id]) then + break } + active_win_record.tree.color_list := active_win_record.tree.color_list[1:id] ||| + active_win_record.tree.color_list[id + 1:0] + active_win_record.tree.num_color := *active_win_record.tree.color_list + } + else if \value then { + every id := 1 to *active_win_record.tree.color_list do + if num == string(active_win_record.tree.color_list[id]) then { + con := &null + break; + } + if \con then { + put(active_win_record.tree.color_list, integer(num)) + active_win_record.tree.num_color := *active_win_record.tree.color_list + } + } + + if active_win_record.tree.num_color == 0 then { + put(active_win_record.tree.color_list, 1) + active_win_record.tree.num_color := 1 } + + return + +end + + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure color_setup_atts() + return ["size=258,390", "bg=pale-gray", "label=Color Selection", "canvas=hidden"] +end + +procedure color_setup(win, cbk) +return vsetup(win, cbk, + ["color_setup:Sizer:::0,0,258,390:Color Selection",], + ["color3:Button:regular:1:212,121,21,33:S",select_color_cb], + ["color5:Button:regular:1:211,200,21,33:S",select_color_cb], + ["color7:Button:regular:1:212,278,21,33:S",select_color_cb], + ["cancel:Button:regular::136,343,54,31:Cancel",color_done_cb], + ["color1:Button:regular:1:211,39,21,33:S",select_color_cb], + ["color2:Button:regular:1:213,81,21,33:S",select_color_cb], + ["color4:Button:regular:1:213,161,21,33:S",select_color_cb], + ["color6:Button:regular:1:212,238,21,33:S",select_color_cb], + ["color_selection:Label:::20,12,112,13:Color Selection:",], + ["okay:Button:regular::50,341,54,31:Okay",color_done_cb], + ["1:Rect:sunken::18,40,183,34:",color_region_cb], + ["2:Rect:sunken::18,80,183,34:",color_region_cb], + ["3:Rect:sunken::18,120,183,34:",color_region_cb], + ["4:Rect:sunken::18,160,183,34:",color_region_cb], + ["5:Rect:sunken::18,200,183,34:",color_region_cb], + ["6:Rect:sunken::18,240,183,34:",color_region_cb], + ["7:Rect:sunken::18,280,183,34:",color_region_cb], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/drawtree/data.icn b/ipl/gpacks/drawtree/data.icn new file mode 100644 index 0000000..d835aae --- /dev/null +++ b/ipl/gpacks/drawtree/data.icn @@ -0,0 +1,365 @@ +global gen_table + + +# set the default for Children_R +procedure children_default() + + return Children_R(50, 3, table(), table()) + +end + +# generates children +procedure children_generation(children) + + local parent_id + local delete_id + local max + local id + local child + local parents + local num + + # set up the first child + max := ?children.max_children + children.all[0] := Child_Node_R(0, set(), &null, 0, 2 * &pi) + + # give child(ren) to the first node + every insert(children.all[0].children_id, 1 to max) + + # add the new children to the children list and set the children + # to be ready as parents + parents := set() + every insert(parents, id := !children.all[0].children_id) do + children.all[id] := Child_Node_R(0, set()) + + # generate children for each child created, some children may not have children + + every id := max+1 to children.num_children do + { + num := 0; + + # get a parent and give it a child + parent_id := ?parents + children.all[id] := Child_Node_R(parent_id, set()) + insert(children.all[parent_id].children_id, id) + insert(parents, id) + + # delete the parent from the parents set of has max number of children + if *children.all[parent_id].children_id >= children.max_children then + delete(parents, parent_id) + + # randomly delete a parent + delete_id := ?[1, &null] + if \delete_id & *parents ~== 0 then + { + until *children.all[id := ?parents].children_id ~== 0 do + if (num +:= 1) > (2 * *parents) then break; + delete(parents, id) + } + } + + count_children( children, 0 ) + # get the base and the bound for each child + assign_base_and_bound( children ) + # find the generation for each child + count_gen( children, 0, 0 ) + # print out children + # print_out(children) + # count number of children per generation + num_children_per_generation(children) + get_gen_id(children, 0) + +end + + +# for inputted data +procedure parse_text() + + local parent_id, text, intext, id, input_file, text_list + local text_info, part_child, left_b, child, children_new + + if Dialog(["Data File:"], [""], + [], [20]) == "Okay" then input_file := get(dialog_value) + else return fail + + children_new := Children_R(0, 0, table(), table()) + id := 1 + parent_id := 0 + + intext := open(input_file) | return fail + text := "" + while text ||:= read(intext) + text_list := [[text, 0]] + close(intext) + + # start the root + children_new.all[0] := Child_Node_R(0, set(), &null, 0, 2 * &pi, 0, 0) + + # build the tree + while text_info := get(text_list) do { + + text := text_info[1] + parent_id := text_info[2] + + text ? { + tab(upto('[') + 1) | return fail + part_child := "" + left_b := 0 + while child := tab(upto('[]') + 1) do { + + find("[", child) & part_child ||:= child & left_b +:= 1 & next + find("]", child) & part_child ||:= child & left_b -:= 1 & left_b > 0 & next + + child := part_child + if not find("[", child) then break + + # set up the new child + children_new.all[id] := Child_Node_R(parent_id, set()) + insert(children_new.all[parent_id].children_id, id) + + # check if the new child is also a parent + if child[-2:0] ~== "[]" then put(text_list, [child,id]) + id +:= 1 + + part_child := "" + left_b := 0 + child := "" + } + } + } + + children_new.num_children := id - 1; + + children_new.max_children := 0 + every id := 0 to children_new.num_children do + if *children_new.all[id].children_id > children_new.max_children then + children_new.max_children := *children_new.all[id].children_id + + count_children( children_new, 0 ) + # get the base and the bound for each child + assign_base_and_bound( children_new ) + # find the generation for each child + count_gen(children_new, 0, 0 ) + # count number of children per generation + num_children_per_generation(children_new) + get_gen_id(children_new, 0) + + return(children_new) + +end + + + +# for directory data +procedure children_directory() + + local dir_string + local children, text, intext + + children := Children_R(0, 0, table(), table()) + dir_string := begin_root() + system("ls -p " || dir_string || " > file") + intext := open("file") + text := read(intext) + if find("No such file or directory", text) then return fail + close(intext) + system("rm file") + + /dir_string & return fail + set_up_children_directory(children, dir_string) + + return children + +end + + + +# +procedure set_up_children_directory(children, dir_string) + + local parent_id + local count + local directory_table + local dir_list + local new_dir + + parent_id := count := 0 + directory_table := table() + + # set up the root (dir_string) + children.all[count] := Child_Node_R(0, set(), &null, 0, 2 * &pi) + directory_table[count] := [dir_string, 0] + count +:= 1 + dir_list := get_directory_list(dir_string) + if /dir_list then return; + children.max_children := *dir_list; + + # assign id number for each new child and record + while new_dir := get(dir_list) do { + directory_table[count] := [new_dir, parent_id] + insert(children.all[parent_id].children_id, count) + count +:= 1 + } + parent_id +:= 1; + + # initailize each new child + until parent_id = count do { + + # set up the new parent and get the children + children.all[parent_id] := Child_Node_R(directory_table[parent_id][2], + set()) + dir_list := get_directory_list(directory_table[parent_id][1]) + if *dir_list > children.max_children then + children.max_children := *dir_list + + # assign id number for each new child and record + while new_dir := get(dir_list) do { + directory_table[count] := [new_dir, parent_id] + insert(children.all[parent_id].children_id, count) + count +:= 1 + } + + parent_id +:= 1; + + } + + children.num_children := count - 1 + + count_children( children, 0 ) + # get the bas and the bound for each child + assign_base_and_bound( children ) + # find the generation for each child + count_gen(children, 0, 0 ) + # count number of children per generation + num_children_per_generation(children) + get_gen_id(children, 0) + +end + + +# get all the directory names that live in a certain directory +procedure get_directory_list(dir_string) + + local intext + local text + local dir_list + + dir_list := list() + + system("ls -p " || dir_string || " > file") + intext := open("file") + + while text := read(intext) do { + if find("/", text) then { + text ? { + push(dir_list, dir_string || "/" || tab(upto('/'))) } + } + } + + close(intext) + system("rm file") + return dir_list + +end + + +procedure begin_root() + + if Dialog(["Enter a directory:"], [""], + [], [20]) == "Okay" then return get(dialog_value) + else return fail + +end + + +# count the number of children +procedure count_children( children, id ) + + children.all[id].children_num := *children.all[id].children_id + every children.all[id].children_num +:= count_children(children, !children.all[id].children_id) + + return children.all[id].children_num + +end + + +# find the generation for each child +procedure count_gen( children, id, generation ) + + children.all[id].generation := generation + every count_gen(children, !children.all[id].children_id, generation + 1) + + return + +end + + +# get the base and the bound for each child +procedure assign_base_and_bound(children) + + local id, range, base, bound, num, child, base_s, bound_s + + # get the base and the bound + every id := 0 to children.num_children do + { + # get the base and the bound of its parent + bound_s := bound := children.all[id].bound + base_s := base := children.all[id].base + + # find the range and calulate its own base and bound + range := bound - base + every child := !children.all[id].children_id do + { + num := (children.all[child].children_num + 1)* range / children.all[id].children_num + bound_s := num + base_s + children.all[child].base := base_s + children.all[child].bound := bound_s + base_s := bound_s + } + } + +end + + +# find the number of children per generation +procedure num_children_per_generation(children) + + local id, num_of_children + + children.num_gen := table() + + every id := 0 to children.num_children do + children.num_gen[id] := 0 + + every id := 0 to children.num_children do { + num_of_children := *children.all[id].children_id + children.num_gen[children.all[id].generation + 1] +:= num_of_children + } + children.num_gen[0] := 1 + +end + + +# get the id number for each child for its generation starting at 1 +procedure get_gen_id(children, child) + + gen_table := table() + every gen_table[0 to children.num_children] := 1 + N_get_gen_id(children, child) + +end + + +procedure N_get_gen_id(children, child) + + local gen, new_child + + gen := children.all[child].generation + children.all[child].gen_id := gen_table[gen] + gen_table[gen] +:= 1 + every new_child := !children.all[child].children_id do + N_get_gen_id(children, new_child) + +end + + diff --git a/ipl/gpacks/drawtree/data1.exm b/ipl/gpacks/drawtree/data1.exm new file mode 100644 index 0000000..ced7af6 --- /dev/null +++ b/ipl/gpacks/drawtree/data1.exm @@ -0,0 +1 @@ +animals[mammals[land[]water[]]reptile[]] diff --git a/ipl/gpacks/drawtree/data2.exm b/ipl/gpacks/drawtree/data2.exm new file mode 100644 index 0000000..b6f3d29 --- /dev/null +++ b/ipl/gpacks/drawtree/data2.exm @@ -0,0 +1,4 @@ +animals[mammals[land[small[pets[cats[bad[]good[]okay[]]dogs[hound[black[dark[]middle[]light[]]brown[]] +germanshepard[baby[new[]old[]]]]]wild[]]large[pets[horse[brown[]]cow[milk[]cattle[]]]wild[]]]water[small[] +large[]]]reptile[frog[big[]]toad[ugly[]cute[]]]insects[good[ugly[]nice[]]bad[]small[]big[]]] + diff --git a/ipl/gpacks/drawtree/draw_bar.icn b/ipl/gpacks/drawtree/draw_bar.icn new file mode 100644 index 0000000..470fab0 --- /dev/null +++ b/ipl/gpacks/drawtree/draw_bar.icn @@ -0,0 +1,105 @@ +$define Win_Size 600 +$define BG "white" +$define FG "black" + +# set the default for DrawTree_Square_R +procedure drawtree_bar_default(fg, bg) + + local draw_record + + draw_record := DrawTree_Square_R() + + draw_record.win_width := Win_Size + 200 + draw_record.win_height := Win_Size + if /fg then draw_record.fg := FG else draw_record.fg := fg + if /bg then draw_record.bg := BG else draw_record.bg := bg + draw_record.color_list := [1, 2, 3, 4] + draw_record.color_list_u := ["red", "blue", "green", "orange", "yellow", "brown", "purple"] + draw_record.num_color := 4 + draw_record.win := WOpen("canvas=hidden", "size=" || Win_Size || "," || Win_Size + 100, + "bg=" || draw_record.bg, "fg=" || draw_record.fg) + draw_record.linewidth := 10 + draw_record.length := 580 + draw_record.space := 2 + draw_record.move := 15 + draw_record.x := draw_record.move + draw_record.y := 10 + + draw_record.menu := ["background", format_square_cb, "color list", format_square_cb, "linewidth", format_square_cb, + "space", format_square_cb, "length", format_square_cb, "snapshot", format_square_cb, "grid", format_square_cb] + + return draw_record + +end + + +procedure drawtree_bar(draw_record) + + draw_grid_bar(draw_record) + drawtree_bar_rec(draw_record, children, 0, draw_record.x, + draw_record.y, draw_record.linewidth, + draw_record.length) + +end + + +# draw a grid by using color +procedure draw_grid_bar(draw_record, size) + + local win, row, id, length + + /size & size := 2 + + EraseArea(draw_record.win) + + win := Clone(draw_record.win, "linewidth=" || size) + id := 1 + length := 2 * draw_record.move + draw_record.length + + every row := draw_record.move to draw_record.length/2 by draw_record.move do { + + Fg(win, draw_record.color_list_u[draw_record.color_list[id]]) + DrawLine(win, 15, row, draw_record.win_width, row) + DrawLine(win, 15, length - row, draw_record.win_width, length - row) + + if id >= draw_record.num_color then id := 1 else id +:= 1 + + } + +end + + + +# draw the tree in a circle seperated with line between each node +procedure drawtree_bar_rec(draw_record, children, id, x, y, width, length) + + local gen, new_id, win + + win := Clone(draw_record.win) + Fg(win, draw_record.color_list_u[draw_record.color_list[(children.all[id].generation) % + draw_record.num_color + 1]]) + + FillRectangle(win, x, y, width - draw_record.space, length) + + gen := 1 + every new_id := !children.all[id].children_id do + { + drawtree_bar_rec(draw_record, children, new_id, + (x + (gen * draw_record.linewidth)), + (y + draw_record.move), + (draw_record.linewidth), + (length - (2 * draw_record.move))) + gen := children.all[new_id].children_num + gen + 1 + } + +end + + + + + + + + + + diff --git a/ipl/gpacks/drawtree/draw_box.icn b/ipl/gpacks/drawtree/draw_box.icn new file mode 100644 index 0000000..20b4c1a --- /dev/null +++ b/ipl/gpacks/drawtree/draw_box.icn @@ -0,0 +1,182 @@ +$define Win_Size 1500 +$define BG "white" +$define FG "black" +$define COLOR_LIST ["yellow", "blue", "green", "red", "orange", "brown", "gray", "purple", "pink"] + +# set the default for DrawTree_Box_R +procedure drawtree_box_default(fg, bg) + + local draw_record + + draw_record := DrawTree_Box_R() + + draw_record.win_width := Win_Size + draw_record.win_height := Win_Size - 200 + if /fg then draw_record.fg := FG else draw_record.fg := fg + if /bg then draw_record.bg := BG else draw_record.bg := bg + draw_record.color_list := ["red", "blue", "green", "orange"] + draw_record.num_color := 4 + draw_record.win := WOpen("canvas=hidden", + "size=" || draw_record.win_width || "," || draw_record.win_height, + "bg=" || draw_record.bg, "fg=" || draw_record.fg, + "dx=10", "dy=10") + + draw_record.box_size := 20 + draw_record.draw_box_size := 16 + + set_box_shape(draw_record) + + draw_record.menu := ["background", format_box_cb, "total box size", format_box_cb, "visible box size", format_box_cb, "snapshot", format_box_cb] + + return draw_record + +end + + +procedure set_box_shape(draw_record) + + local y_num, x_num, x, y + + draw_record.grid_x := table() + draw_record.grid_y := table() + draw_record.grid_x_coor := table() + draw_record.grid_y_coor := table() + + y_num := 0 + x_num := 0 + every y := 0 to draw_record.win_height by draw_record.box_size do { + draw_record.grid_y[y_num] := y + draw_record.grid_y_coor[y] := y_num + y_num +:= 1 + } + + every x := 0 to draw_record.win_width by draw_record.box_size do { + draw_record.grid_x[x_num] := x + draw_record.grid_x_coor[x] := x_num + x_num +:= 1 + } + + draw_record.y_num := y_num + draw_record.x_num := x_num + + draw_record.x_start := table() + + return + +end + + + +# draw the tree in a seperated with line between each node +procedure drawtree_box(draw_record, children) + + local id, x, y + + every id := 0 to children.num_children do { + if children.num_gen[id] == 0 then break + + x := integer(((draw_record.x_num - children.num_gen[id]) / 2) + 1) + draw_record.x_start[id] := x + } + + EraseArea(draw_record.win) + + every id := 0 to children.num_children do { + y := children.all[id].generation + x := children.all[id].gen_id + draw_record.x_start[y] + DrawRectangle(draw_record.win, + draw_record.grid_x[x], + draw_record.grid_y[y], + draw_record.draw_box_size, + draw_record.draw_box_size) + } + +end + + +# event handler +procedure event_handler_box(draw_record, children, event) + + local x, y, gen, id, x_id + + if event == &lpress then { + + x := &x + y := &y + + while /draw_record.grid_x_coor[x] do { + x -:= 1 + if x == 0 then return fail + } + + while /draw_record.grid_y_coor[y] do { + y -:= 1 + if y == -1 then return fail + } + + y := draw_record.grid_y_coor[y] + x := draw_record.grid_x_coor[x] + if /draw_record.x_start[y] then return fail + x_id := x - draw_record.x_start[y] + + every id := 0 to children.num_children do { + if y == children.all[id].generation then + if x_id == children.all[id].gen_id then { + fill_boxes(draw_record, children, id, x, y) + break; + } + } + + } + + else if event == &mpress then { + + y := &y + while /draw_record.grid_y_coor[y] do { + y -:= 1 + if y == -1 then return fail + } + y := draw_record.grid_y_coor[y] + if /draw_record.x_start[y] then return fail + + every id := 0 to children.num_children do { + if y == children.all[id].generation then { + x := children.all[id].gen_id + draw_record.x_start[y] + Fg(draw_record.win, COLOR_LIST[children.all[id].gen_id % + *COLOR_LIST + 1]) + fill_boxes(draw_record, children, id, x, y) + } + } + + Fg(draw_record.win, draw_record.fg) + } + + else if event == &rpress then + drawtree_box(draw_record, children) + +end + + +procedure fill_boxes(draw_record, children, child, x, y) + + local id + + FillRectangle(draw_record.win, + draw_record.grid_x[x], + draw_record.grid_y[y], + draw_record.draw_box_size, + draw_record.draw_box_size) + + every id := !children.all[child].children_id do { + y := children.all[id].generation + x := children.all[id].gen_id + draw_record.x_start[y] + fill_boxes(draw_record, children, id, x, y) + } + +end + + + + + + diff --git a/ipl/gpacks/drawtree/draw_crc.icn b/ipl/gpacks/drawtree/draw_crc.icn new file mode 100644 index 0000000..c627285 --- /dev/null +++ b/ipl/gpacks/drawtree/draw_crc.icn @@ -0,0 +1,204 @@ +$include "info.icn" + +$define Win_Size 1500 + +# set the default for DrawTree_Circle_R +procedure drawtree_circle_default(fg, bg) + + local draw_record + + draw_record := DrawTree_Circle_R() + + draw_record.window_size := Win_Size + if /fg then draw_record.fg := FG else draw_record.fg := fg + if /bg then draw_record.bg := BG else draw_record.bg := bg + draw_record.color_list := COLOR_LIST + draw_record.color_list_u := COLOR_LIST_U + draw_record.num_color := 4 # take this out + draw_record.win := WOpen("canvas=hidden", "size=" || Win_Size || "," || Win_Size, + "bg=" || draw_record.bg, "fg=" || draw_record.fg) + draw_record.radius := 20 + draw_record.space := 18 + draw_record.linewidth := 2 + draw_record.gap := 2 + draw_record.generation := 0 + draw_record.num_children_code := &null + draw_record.tree := &null + draw_record.color_children := &null + + draw_record.menu := ["background", format_circle_cb, "color list", + format_circle_cb, "radius", format_circle_cb, + "space", format_circle_cb, "tree", format_circle_cb, + "gap", format_circle_cb, "generation", format_circle_cb, + "color format", format_circle_cb, "# of children", format_circle_cb, + "snapshot", format_circle_cb] + + return draw_record + +end + + + +# draw the tree in a circle gapd with line between each node +procedure drawtree_circle(draw_record, children) + + local win, id, radius, angle, num + + win := Clone(draw_record.win) + EraseArea(win) + + \draw_record.num_children_code & num := children.num_children / *draw_record.color_list + + # draw all the children + every id := 0 to children.num_children do + { + /num & Fg(win, draw_record.color_list_u[(draw_record.color_list[(children.all[id].generation) % + draw_record.num_color + 1])]) + \num & Fg(win, draw_record.color_list_u[draw_record.color_list[ + integer((children.all[id].children_num / num) + 1)]]) | + Fg(win, draw_record.color_list_u[draw_record.color_list[ + integer((children.all[id].children_num / num))]]) + \draw_record.color_children & draw_record.color_children == *children.all[id].children_id & + Fg(win, "gray") + radius := children.all[id].generation * draw_record.radius + angle := children.all[id].bound - children.all[id].base + every DrawCircle(win, draw_record.window_size/2, + draw_record.window_size/2, + radius to radius + draw_record.space, + children.all[id].base, angle) + } + + if draw_record.gap ~== 0 then { + WAttrib(win, "dx=" || (draw_record.window_size/2), + "dy=" || (draw_record.window_size/2)) + WAttrib(win, "linewidth=" || draw_record.gap) + Fg(win, draw_record.bg) + + # gap the children + every id := 1 to children.num_children do + { + radius := children.all[id].generation * draw_record.radius + DrawLine(win, (cos(children.all[id].base)*radius), + (sin(children.all[id].base)*radius), + (cos(children.all[id].base)*(radius+draw_record.space)), + (sin(children.all[id].base)*(radius+draw_record.space))) + } + } + + if draw_record.generation > 0 then drawtree_circle_radius_find(draw_record, children) + \draw_record.tree & drawtree_circle_line(draw_record, children, 0) + + return + +end + + +# map the tree with lines +procedure drawtree_circle_line(draw_record, children, id) + + local win, new_id, radius, new_radius, new_x, new_y, x, y + + win := Clone(draw_record.win) + WAttrib(win, "dx=" || (draw_record.window_size/2), + "dy=" || (draw_record.window_size/2)) + WAttrib(win, "linewidth=1") + Fg("black") + + every new_id := !children.all[id].children_id do { + + radius := children.all[id].generation * draw_record.radius + new_radius := children.all[new_id].generation * draw_record.radius + + x := cos((children.all[id].base + children.all[id].bound)/2)*radius + y := sin((children.all[id].base + children.all[id].bound)/2)*radius + new_x := cos((children.all[new_id].base + children.all[new_id].bound)/2)*new_radius + new_y := sin((children.all[new_id].base + children.all[new_id].bound)/2)*new_radius + + DrawLine(win, x, y, new_x, new_y) + FillCircle(win, x, y, 2) + FillCircle(win, new_x, new_y, 2) + + drawtree_circle_line(draw_record, children, new_id) + + } + + return + +end + + +# color code the node by the number of children +procedure drawtree_circle_radius_find(draw_record, children) + + local num, id, color_n, first, second, third, gen + + gen := draw_record.generation + num := 0 + every id := 0 to children.num_children do + { + if children.all[id].generation == gen then + num +:= 1 + } + + num := MAX_COL / num + color_n := BLUE + + every id := 0 to children.num_children do + { + if children.all[id].generation == gen then { + drawtree_circle_radius(draw_record, children, id, color_n) + color_n ? { + first := tab(upto(",")); move(1) + second := tab(upto(",")); move(1) + third := tab(0) + } + second := integer(second) + num + third := integer(third) - num + color_n := string(first) || "," || string(second) || "," || string(third) + } + } + + return + +end + + +# draw the tree +procedure drawtree_circle_radius(draw_record, children, id, color_n) + + local win, radius, angle, new_id + + win := Clone(draw_record.win) + + # draw all the children + every new_id := !children.all[id].children_id do + { + Fg(win, color_n) + radius := children.all[new_id].generation * draw_record.radius + angle := children.all[new_id].bound - children.all[new_id].base + every DrawCircle(win, draw_record.window_size/2, + draw_record.window_size/2, + radius to radius + draw_record.space, + children.all[new_id].base, angle) + drawtree_circle_radius(draw_record, children, new_id, color_n) + } + + if draw_record.gap ~== 0 then { + WAttrib(win, "dx=" || (draw_record.window_size/2), + "dy=" || (draw_record.window_size/2)) + WAttrib(win, "linewidth=" || draw_record.gap) + Fg(win, draw_record.bg) + + # gap the children + every new_id := !children.all[id].children_id do + { + radius := children.all[new_id].generation * draw_record.radius + DrawLine(win, (cos(children.all[new_id].base)*radius), + (sin(children.all[new_id].base)*radius), + (cos(children.all[new_id].base)*(radius+draw_record.space)), + (sin(children.all[new_id].base)*(radius+draw_record.space))) + } + } + +end + diff --git a/ipl/gpacks/drawtree/draw_rec.icn b/ipl/gpacks/drawtree/draw_rec.icn new file mode 100644 index 0000000..4191dbc --- /dev/null +++ b/ipl/gpacks/drawtree/draw_rec.icn @@ -0,0 +1,186 @@ +$include "info.icn" + +$define Win_Size 600 + +# set the default for DrawTree_Square_R +procedure drawtree_rectangle_default(fg, bg) + + local draw_record + + draw_record := DrawTree_Square_R() + + draw_record.win_width := Win_Size + 200 + draw_record.win_height := Win_Size - 200 + if /fg then draw_record.fg := FG else draw_record.fg := fg + if /bg then draw_record.bg := BG else draw_record.bg := bg + draw_record.color_list := COLOR_LIST + draw_record.color_list_u := COLOR_LIST_U + draw_record.num_color := 4 # take thins out + draw_record.win := WOpen("canvas=hidden", "size=" || Win_Size + 200 || "," || Win_Size, + "bg=" || draw_record.bg, "fg=" || draw_record.fg) + draw_record.linewidth := 10 + draw_record.length := Win_Size + 200 - 20 + draw_record.space := 2 + draw_record.move := 15 + draw_record.x := draw_record.move + draw_record.y := 10 + draw_record.tree := &null + draw_record.generation := 0 + draw_record.num_children_code := &null + draw_record.color_children := &null + + draw_record.menu := ["background", format_rectangle_cb, "color list", format_rectangle_cb, + "linewidth", format_rectangle_cb, + "space", format_rectangle_cb, "length", format_rectangle_cb, + "generation", format_rectangle_cb, "tree", format_rectangle_cb, + "color format", format_rectangle_cb, "# of children", format_rectangle_cb, + "snapshot", format_rectangle_cb] + + return draw_record + +end + + +# draw the tree in a circle seperated with line between each node +procedure drawtree_rectangle(draw_record, children) + + local gen, id, win, size, x, y, num + + win := Clone(draw_record.win) + EraseArea(win) + + \draw_record.num_children_code & num := children.num_children / *draw_record.color_list + + # draw all the children + every id := 0 to children.num_children do + { + /num & Fg(win, draw_record.color_list_u[(draw_record.color_list[(children.all[id].generation) % + draw_record.num_color + 1])]) + \num & Fg(win, draw_record.color_list_u[draw_record.color_list[ + integer((children.all[id].children_num / num) + 1)]]) | + Fg(win, draw_record.color_list_u[draw_record.color_list[ + integer((children.all[id].children_num / num))]]) + \draw_record.color_children & draw_record.color_children == *children.all[id].children_id & + Fg(win, "gray") + x := (children.all[id].base * draw_record.length) / (2 * &pi) + 10 + size := (((children.all[id].bound - children.all[id].base) * draw_record.length) / (2 * &pi)) + y := children.all[id].generation * draw_record.linewidth + 10 + FillRectangle(win, x, y, size, draw_record.linewidth - draw_record.space) + } + + every id := 0 to children.num_children do + { + x := (children.all[id].base * draw_record.length) / (2 * &pi) + 10 + size := (((children.all[id].bound - children.all[id].base) * draw_record.length) / (2 * &pi)) + y := children.all[id].generation * draw_record.linewidth + 10 + Fg(win, draw_record.bg) + DrawLine(win, x, y, x, y + draw_record.linewidth) + } + + if draw_record.generation > 0 then drawtree_rec_gen_find(draw_record, children) + \draw_record.tree & drawtree_rectangle_line(draw_record, children, 0) + + return + +end + + +# draw the tree by lines +procedure drawtree_rectangle_line(draw_record, children, id) + + local win, new_id, radius, new_radius, y_new, x_new, x, y, size + + size := 2 + win := Clone(draw_record.win) + Fg("black") + + every new_id := !children.all[id].children_id do { + + x := (((children.all[id].base + children.all[id].bound)/2) * draw_record.length) / (2 * &pi) + 10 + y := (children.all[id].generation) * draw_record.linewidth + 10 + draw_record.linewidth/2 + x_new := (((children.all[new_id].base + children.all[new_id].bound)/2) * draw_record.length) / (2 * &pi) + 10 + y_new := (children.all[new_id].generation)* draw_record.linewidth + 10 + draw_record.linewidth/2 + + DrawLine(win, x, y, x_new, y_new) + size := 2 + \draw_record.color_children & draw_record.color_children == *children.all[new_id].children_id & + size := 5 + FillCircle(win, x, y, size) + FillCircle(win, x_new, y_new, size) + drawtree_rectangle_line(draw_record, children, new_id) + + } + + return + +end + + +# color code by number of children +procedure drawtree_rec_gen_find(draw_record, children) + + local num, id, color_n, first, second, third, gen + + gen := draw_record.generation + num := 0 + every id := 0 to children.num_children do + { + if children.all[id].generation == gen then + num +:= 1 + } + + num := MAX_COL / num + color_n := BLUE + + every id := 0 to children.num_children do + { + if children.all[id].generation == gen then { + drawtree_rec_gen(draw_record, children, id, color_n) + color_n ? { + first := tab(upto(",")); move(1) + second := tab(upto(",")); move(1) + third := tab(0) + } + second := integer(second) + num + third := integer(third) - num + color_n := string(first) || "," || string(second) || "," || string(third) + } + } + + Fg("black") + + return + +end + + +# draw the tree +procedure drawtree_rec_gen(draw_record, children, id, color_n) + + local gen, new_id, win, size, x, y + + win := Clone(draw_record.win) + Fg(win, color_n) + + # draw all the children + every new_id := !children.all[id].children_id do + { + x := (children.all[new_id].base * draw_record.length) / (2 * &pi) + 10 + size := (((children.all[new_id].bound - children.all[new_id].base) * draw_record.length) / (2 * &pi)) + y := children.all[new_id].generation * draw_record.linewidth + 10 + FillRectangle(win, x, y, size, draw_record.linewidth - draw_record.space) + drawtree_rec_gen(draw_record, children, new_id, color_n) + } + + every new_id := !children.all[id].children_id do + { + x := (children.all[new_id].base * draw_record.length) / (2 * &pi) + 10 + size := (((children.all[new_id].bound - children.all[new_id].base) * draw_record.length) / (2 * &pi)) + y := children.all[new_id].generation * draw_record.linewidth + 10 + Fg(win, draw_record.bg) + DrawLine(win, x, y, x, y + draw_record.linewidth) + } + + return + +end diff --git a/ipl/gpacks/drawtree/draw_sqr.icn b/ipl/gpacks/drawtree/draw_sqr.icn new file mode 100644 index 0000000..d18a09c --- /dev/null +++ b/ipl/gpacks/drawtree/draw_sqr.icn @@ -0,0 +1,333 @@ +$include "info.icn" + +$define Win_Size 2000 +$define BG "white" +$define FG "black" +$define START 15 + +# set the default for DrawTree_Square_R +procedure drawtree_square_default(fg, bg) + + local draw_record + + draw_record := DrawTree_Square_R() + + draw_record.win_width := Win_Size + draw_record.win_height := Win_Size + if /fg then draw_record.fg := FG else draw_record.fg := fg + if /bg then draw_record.bg := BG else draw_record.bg := bg + draw_record.color_list := [1, 2, 3, 4] + draw_record.color_list_u := + ["red", "blue", "green", "orange", "yellow", "brown", "purple"] + draw_record.num_color := 4 + draw_record.win := + WOpen("canvas=hidden", "size=" || Win_Size || "," || Win_Size + 100, + "bg=" || draw_record.bg, "fg=" || draw_record.fg) + draw_record.linewidth := 10 + draw_record.gridwidth := 2 + draw_record.line_pos := VER + draw_record.justification := MIDDLE + draw_record.length := 580 + draw_record.space := 2 + draw_record.move := 15 + draw_record.under := &null + draw_record.population := &null + draw_record.x := START + draw_record.y := START + draw_record.num_children_code := &null + draw_record.tree := &null + draw_record.bar := 1 + + draw_record.menu := ["background", format_square_cb, "color list", + format_square_cb, "linewidth", format_square_cb, + "space", format_square_cb, "length", format_square_cb, + "index", format_square_cb, + "justification", format_square_cb, + "snapshot", format_square_cb, "grid", format_square_cb, + "line pos", format_square_cb, + "grid format", format_square_cb, + "population", format_square_cb, + "color format", format_square_cb, + "tree", format_square_cb, + "bar", format_square_cb] + + return draw_record + +end + + +# draw the tree with grids +procedure drawtree_square(draw_record) + + \draw_record.num_children_code & + draw_record.num_children_code := children.num_children / (*draw_record.color_list) + + draw_grid(draw_record) + drawtree_square_rec(draw_record, children, 0, draw_record.x, + draw_record.y, draw_record.linewidth, + draw_record.length) + \draw_record.tree & drawtree_square_line(draw_record, children, 0, draw_record.x, + draw_record.y, draw_record.length) + + return + +end + + +# draw a grid +procedure draw_grid_blue(draw_record) + + local win, row + + win := Clone(draw_record.win) + Fg(win, "light-blue") + + every row := draw_record.move + to draw_record.window_size by draw_record.move do + DrawLine(win, row, 0, row, draw_record.window_size) + +end + + +# draw a grid by using color +procedure draw_grid(draw_record) + + local win, row, id, length + + EraseArea(draw_record.win) + + if draw_record.gridwidth = 0 then return + + win := Clone(draw_record.win, "linewidth=" || draw_record.gridwidth) + id := 1 + length := 2 * START + draw_record.length + + every row := START to draw_record.length/2 by draw_record.move do { + + Fg(win, draw_record.color_list_u[draw_record.color_list[id]]) + if draw_record.line_pos === VER then + draw_ver(win, draw_record, row, length) + else + draw_hoz(win, draw_record, row, length) + + if id >= *draw_record.color_list then id := 1 else id +:= 1 + + } + +end + + +# draw the grid line vertical +procedure draw_ver(win, draw_record, row, length) + + case draw_record.justification of { + + LEFT : { + DrawLine(win, length - row * 2 + START, START, + length - row * 2 + START, draw_record.win_height) + } + MIDDLE : { + DrawLine(win, row, START, row, draw_record.win_height) + DrawLine(win, length - row, START, length - row, + draw_record.win_height) } + RIGHT : { + DrawLine(win, row * 2, START, + row * 2, draw_record.win_height) + } + } + + return + +end + + + +# draw the grid line horizontal +procedure draw_hoz(win, draw_record, row, length) + + case draw_record.justification of { + + LEFT : { + DrawLine(win, START, row * 2, + draw_record.win_width, row * 2) + } + MIDDLE : { + DrawLine(win, START, row, draw_record.win_width, row) + DrawLine(win, START, length - row, draw_record.win_width, + length - row) + } + RIGHT : { + DrawLine(win, START, length - row * 2 + START, + draw_record.win_width, length - row * 2 + START) + } + + + } + return + +end + + + +# draw the tree seperated with line between each node +procedure drawtree_square_rec(draw_record, children, id, x, y, width, length) + + local gen, new_id, win, x_new, y_new, new_length, x_o, tmp, angle + + win := Clone(draw_record.win) + + if draw_record.num_children_code === &null then { + Fg(win, draw_record.color_list_u[draw_record.color_list[ + (children.all[id].generation) % + draw_record.num_color + 1]]) } + else { + tmp := integer(children.all[id].children_num / draw_record.num_children_code) + if tmp > *draw_record.color_list then tmp := *draw_record.color_list + else if tmp < *draw_record.color_list then tmp +:= 1 + Fg(win, draw_record.color_list_u[draw_record.color_list[tmp]]) + } + + draw_record.line_pos === HOR & draw_record.justification == LEFT & + y == START & y +:= START + draw_record.line_pos === VER & draw_record.justification == RIGHT & + x == START & x +:= START + + if draw_record.line_pos === VER then { + \draw_record.under & EraseArea(win, x - draw_record.space, + y - draw_record.space, + length + ( 2 * draw_record.space), draw_record.space) + \draw_record.bar & FillRectangle(win, x, y, length, width - draw_record.space) + \draw_record.population & + new_length := (draw_record.length * children.all[id].children_num) / + (children.all[0].children_num) & + (if draw_record.justification == MIDDLE then + x_o := (draw_record.length - new_length)/2 + START + else x_o := x) & + WAttrib(win, "fg=gray") & + if draw_record.population == "Bar" then + FillRectangle(win, x_o, y, new_length, width - draw_record.space) + else { + angle := (children.all[id].children_num * 2 * &pi) / children.num_children + FillCircle(win, x_o + START, y + width/2, (width - draw_record.space) / 2, 0, angle) + } + } + else { + + \draw_record.under & EraseArea(win, x - draw_record.space, + y - draw_record.space, + draw_record.space, length) + \draw_record.bar & FillRectangle(win, x, y, width - draw_record.space, length) + \draw_record.population & + new_length := (draw_record.length * children.all[id].children_num) / + (children.all[0].children_num) & + WAttrib(win, "fg=gray") & + if draw_record.population == "Bar" then + FillRectangle(win, x, y + length - new_length, + width - draw_record.space, + new_length) + else { + angle := (children.all[id].children_num * 2 * &pi) / children.num_children + FillCircle(win, x + draw_record.linewidth/2, y + length - START, + (width - draw_record.space) / 2, 0, angle) + } + } + + gen := 1 + every new_id := !children.all[id].children_id do + { + + if (length) < (2 * draw_record.move) then + return + + #gen +:= .1 * deep_children(new_id, children) + + if draw_record.line_pos === VER then { + + case draw_record.justification of { + LEFT : { y_new := y + (gen * draw_record.linewidth) + x_new := x } + MIDDLE: { y_new := y + (gen * draw_record.linewidth) + x_new := x + draw_record.move } + RIGHT: { y_new := y + (gen * draw_record.linewidth) + x_new := draw_record.length - length + 4 * START + } + } + + drawtree_square_rec(draw_record, children, new_id, + x_new, y_new, draw_record.linewidth, + length - (2 * draw_record.move)) + } + else { + + case draw_record.justification of { + LEFT : { y_new := draw_record.length - length + 4 * START + x_new := x + (gen * draw_record.linewidth) } + MIDDLE: { y_new := y + draw_record.move + x_new := x + (gen * draw_record.linewidth) } + RIGHT: { y_new := y + x_new := x + (gen * draw_record.linewidth) } + } + + drawtree_square_rec(draw_record, children, new_id, + x_new, #(x + (gen * draw_record.linewidth)), + y_new, # (y + draw_record.move), + (draw_record.linewidth), + (length - (2 * draw_record.move))) + } + + gen := children.all[new_id].children_num + gen + 1 + } + +end + + + +procedure drawtree_square_line(draw_record, children, id, x, y, length) + + local gen, new_id, y_new, x_new, win + + win := Clone(draw_record.win) + + if draw_record.line_pos === VER then { + + gen := 1 + every new_id := !children.all[id].children_id do { + + case draw_record.justification of { + LEFT : { y_new := y + (gen * draw_record.linewidth) + x_new := x } + MIDDLE: { y_new := y + (gen * draw_record.linewidth) + x_new := x + draw_record.move } + RIGHT: { y_new := y + (gen * draw_record.linewidth) + x_new := draw_record.length - length + 4 * START + } + } + + DrawLine(win, x, y, x_new, y_new) + FillCircle(win, x, y, 2) + drawtree_square_line(draw_record, children, new_id, x_new, y_new, length - (2 * draw_record.move)) + gen := children.all[new_id].children_num + gen + 1 + } + } + else { + + gen := 1 + every new_id := !children.all[id].children_id do { + + case draw_record.justification of { + LEFT : { y_new := draw_record.length - length + 4 * START + x_new := x + (gen * draw_record.linewidth) } + MIDDLE: { y_new := y + draw_record.move + x_new := x + (gen * draw_record.linewidth) } + RIGHT: { y_new := y + x_new := x + (gen * draw_record.linewidth) } + } + + DrawLine(win, x, y, x_new, y_new) + FillCircle(win, x, y, 2) + drawtree_square_line(draw_record, children, new_id, x_new, y_new, length - (2 * draw_record.move)) + gen := children.all[new_id].children_num + gen + 1 + } + } + +end diff --git a/ipl/gpacks/drawtree/drawtree.icn b/ipl/gpacks/drawtree/drawtree.icn new file mode 100644 index 0000000..d7fe92b --- /dev/null +++ b/ipl/gpacks/drawtree/drawtree.icn @@ -0,0 +1,866 @@ +# +# Michael Shipman +# +# Honors Project +# + +$include "info.icn" +$include "record.icn" + +# link from the icon library +link random +link interact +link vsetup +link ximage + +# link from own program +link data +link draw_crc +link draw_sqr +link draw_box +link draw_rec +link clr_list + +global ID + +procedure main(args) + + local root, paused, main_window + + ID := 1 + + randomize() + + #Open the color window + (WOpen ! color_setup_atts()) | stop("can't open window") + vidgets_color := color_setup() + color_root := vidgets_color["root"] + color_window := &window + &window := &null + + # Open the main window + (WOpen ! ui_atts()) | stop("can't open window") + vidgets := ui() # set up vidgets + root := vidgets["root"] + main_window := &window + + initialize() + + repeat { + + # main window + &window := main_window + while (*Pending() > 0) do + ProcessEvent(root, QuitCheck) + + active_win_record := win_record_one + &window := win_record_one.win + process_event() + active_win_record := win_record_two + &window := win_record_two.win + process_event() + active_win_record := win_record_three + &window := win_record_three.win + process_event() + active_win_record := win_record_four + &window := win_record_four.win + process_event() + + + } + + +end + +############################################################################################### +# setups + +procedure initialize() + + WAttrib("pointer=watch") + + # generate children + Draw_String("children_default") + children := children_default() + Draw_String("children_generation") + children_generation(children) + Draw_String("get_gen_id") + get_gen_id(children, 0) + # Draw_String("print_out") + #print_out(children) + + # set up default for the record + Draw_String("drawtree_circle_default") + circle_record := drawtree_circle_default() + Draw_String("drawtree_square_default") + square_record := drawtree_square_default() + Draw_String("drawtree_rectangle_default") + rectangle_record := drawtree_rectangle_default() + Draw_String("drawtree_box_default") + box_record := drawtree_box_default() + + # draw the trees + Draw_String("drawtree_circle") + drawtree_circle(circle_record, children) + Draw_String("drawtree_square") + drawtree_square(square_record, children) + Draw_String("drawtree_rectangle") + drawtree_rectangle(rectangle_record, children) + Draw_String("drawtree_box") + drawtree_box(box_record, children) + + # Now get events, pass control to the procedure quit() if an event is not + # captured by a vidget. + Draw_String("win one") + win_record_one := set_scroll_window(circle_record) + Draw_String("win two") + win_record_two := set_scroll_window(square_record) + Draw_String("win three") + win_record_three := set_scroll_window(rectangle_record) + Draw_String("win four") + win_record_four := set_scroll_window(box_record) + + Draw_String("DONE! ") + WDelay(100) + Draw_String(" ") + + WAttrib("pointer=top left arrow") + +end + + +# notify the process +procedure Draw_String(s) + + static x, y, w, h + initial { + x := vidgets["where"].ux + y := vidgets["where"].uy + w := vidgets["where"].uw + h := vidgets["where"].uh + } + + Clip(x, y, w, h) + EraseArea() + DrawString(x + 1, y + 20, s) + Clip() + +end + + + +# switch the state of the window to normal or hidden +procedure DrawTree_cb(vidget, value) + + local win + + # get the window + case vidget.id of { + "circle": win := win_record_one.win + "layer": win := win_record_two.win + "square": win := win_record_two.win + "bar": win := win_record_three.win + "rectangle": win := win_record_three.win + "box": win := win_record_four.win + default: return fail + } + + # switch the state - hidden or normal + /value & WAttrib(win, "canvas=hidden") + \value & WAttrib(win, "canvas=normal") + + return + +end + + +# generate new tree +procedure re_generate(data) + + local children_tmp + + WAttrib("pointer=watch") + + if data == DIR then { + children_tmp := children_directory() + /children_tmp & WAttrib("pointer=top left arrow") & return fail + children.num_gen := table() + children.all := table() + children := children_tmp + } + else if data == GEN then { + # generate children + Draw_String("children_generation") + children.num_gen := table() + children.all := table() + children_generation(children) + } + else if data == DATA then { + children_tmp := parse_text() + /children_tmp & WAttrib("pointer=top left arrow") & return fail + children.num_gen := table() + children.all := table() + children := children_tmp + } + + # draw the trees + Draw_String("drawtree_circle") + drawtree_circle(circle_record, children) + Draw_String("drawtree_square") + drawtree_square(square_record) + Draw_String("drawtree_rectangle") + drawtree_rectangle(rectangle_record, children) + Draw_String("drawtree_box") + drawtree_box(box_record, children) + + Draw_String(" ") + + WAttrib("pointer=top left arrow") + + return + +end + +# callback to the file menu bar in the main window +procedure file_cb(vidget, value) + case get(value) of { + INPUT_DATA: re_generate(DATA) + QUIT : stop() + } +end + + + +# callback to the menu bar in the main window +procedure format_gen_cb(vidget, value) + + case get(value) of { + MAX_NODES: { + if Dialog(["Enter number of nodes:"], [""], + [children.num_children], + [4]) == "Okay" then children.num_children := integer(get(dialog_value)) + } + MAX_CHILDREN: { + if Dialog(["Enter max number of children for each parent:"], [""], + [children.max_children], + [1]) == "Okay" then children.max_children := integer(get(dialog_value)) + } + GENERATE: re_generate(GEN) + DIRECTORY: re_generate(DIR) + } + +end + + +# quit the program +procedure quit_cb(vidget, value) + + stop() + +end + + + +############################################################################################### +# scroll windows + +# process the event of the scroll window +procedure process_event() + + while (*Pending(active_win_record.win) > 0) & /active_win_record.resize_state do { + ProcessEvent(active_win_record.root, region, ,resize) + } + + if \active_win_record.resize_state then + { + sl_cb(active_win_record.scv, active_win_record.scv.callback.value) + sl_cb(active_win_record.sch, active_win_record.sch.callback.value) + DrawRidge(active_win_record.win, 0, 24, active_win_record.view_width + SCROLLBAR_WIDTH, 24, 2) + active_win_record.resize_state := &null + } + + # color window + while \color_dialog_open do { + &window := color_window + while (*Pending() > 0) do + ProcessEvent(color_root, QuitCheck) + } + + return +end + + +# set the default for the record +procedure set_scroll_window(tree) + + local win_record + + win_record := Scroll_Win_Record() + active_win_record := win_record + + win_record.id := ID + ID +:= 1 + + win_record.tree := tree + + win_record.vpos := win_record.hpos := 0 + + win_record.view_width := WINDOW_SIZE + win_record.view_height := WINDOW_SIZE + + win_record.picw := IMAGE_SIZE + win_record.pich := IMAGE_SIZE + + win_record.win := WOpen("size=" || + (win_record.view_width + SCROLLBAR_WIDTH + 1) || "," || + (win_record.view_height + SCROLLBAR_WIDTH + 1) , "bg=pale-gray", + "canvas=hidden", "resize=on") + + win_record.root := Vroot_frame(win_record.win) + + # Create two scrollbars. + win_record.scv := Vvert_scrollbar(win_record.root, -1, MENUSIZE, win_record.win, sl_cb, 1, + win_record.view_height-MENUSIZE,SCROLLBAR_WIDTH, win_record.pich, 0, , win_record.view_height) + win_record.sch := Vhoriz_scrollbar(win_record.root, 0, -1, win_record.win, sl_cb, 2, + win_record.view_width, SCROLLBAR_WIDTH, 0, win_record.picw, , win_record.view_width) + + # Create menu bars + win_record.FormatMenu := Vsub_menu ! ([win_record.win] ||| tree.menu) + win_record.tm := Vmenu_bar(win_record.root, 0, 0, win_record.win, "Format", + win_record.FormatMenu) + + VResize(win_record.root) + + # Draw the initial view of the pixmap, based on the scrollbar's values. + sl_cb(win_record.scv, win_record.scv.callback.value) + sl_cb(win_record.sch, win_record.sch.callback.value) + + # Draw a line between the menu and the region + DrawRidge(win_record.win, 0, 24, win_record.view_width + SCROLLBAR_WIDTH, 24, 2) + + return win_record + +end + + +# +procedure region(e, x, y) + + &x := active_win_record.hpos + x + &y := active_win_record.vpos + y - MENUSIZE + + event_handler_box(box_record, children, e) + sl_cb() + + return + +end + + +# +procedure resize(root) + + VReformat(active_win_record.scv, WAttrib(active_win_record.scv.win, "height") - SCROLLBAR_WIDTH- MENUSIZE) + VReformat(active_win_record.sch, WAttrib(active_win_record.sch.win, "width") - SCROLLBAR_WIDTH) + + active_win_record.view_width := WAttrib("width") -SCROLLBAR_WIDTH + active_win_record.view_height := WAttrib("height")-SCROLLBAR_WIDTH + + active_win_record.resize_state := 1 + + return + +end + + +# Copy a portion of the bitmap to the main +# window based on the values of the scrollbars. +procedure sl_cb(caller, val) + + if \val then + (caller.id = 1, active_win_record.vpos := val) | active_win_record.hpos := val + CopyArea(active_win_record.tree.win, active_win_record.win, + active_win_record.hpos, active_win_record.vpos, + active_win_record.view_width, active_win_record.view_height-MENUSIZE, 0, MENUSIZE) + + return + +end + + + +################################################################################################# +# change the format + +# a callback to change the format of circle +procedure format_circle_cb(caller, val) + + local e, s + + case e := get(val) of { + "background" : ColorDialog("Select a new background color:", + active_win_record.tree.bg, change_color_bg, + active_win_record.tree.bg) + "color list" : s := change_color("circle") + "radius" : s := change_radius() + "space" : s := change_space() + "gap" : s := change_gap() + "snapshot" : s := take_picture() + "tree" : s := change_tree() + "generation" : s := change_gen_color() + "color format" : s := change_color_format() + "# of children" : s := change_num_of_children() + } + + \s & drawtree_circle(active_win_record.tree, children) & sl_cb() + + return + +end + + +# a call back to change the format of the square +procedure format_square_cb(caller, val) + + local e, size, s + + size := 2 + + case e := get(val) of { + "background" : ColorDialog("Select a new background color:", + active_win_record.tree.bg, + change_color_bg, active_win_record.tree.bg) + "color list" : s := change_color("square") + "linewidth" : s := change_linewidth() + "space" : s := change_space_rec() + "snapshot" : s := take_picture() + "length" : s := change_length() + "index" : s := change_index() + "grid" : s := change_gridwidth() + "line pos" : s := change_line_pos() + "grid format" : s := change_grid_format() + "justification" : s := change_justification() + "population" : s := change_population() + "color format" : s := change_color_format() + "tree" : s := change_tree() + "bar" : s := change_bar_tree() + } + + \s & drawtree_square(square_record) & sl_cb() + + return + +end + + + +# a callback to change the format of the rectangle +procedure format_rectangle_cb(caller, val) + + local e, s + + case e := get(val) of { + "background" : ColorDialog("Select a new background color:", + active_win_record.tree.bg, change_color_bg, + active_win_record.tree.bg) + "color list" : s := change_color("rectangle") + "linewidth" : s := change_linewidth() + "space" : s := change_space_rec() + "snapshot" : s := take_picture() + "length" : s := change_length() + "tree" : s := change_tree() + "generation" : s := change_gen_color() + "color format" : s := change_color_format() + "# of children" : s := change_num_of_children() + } + + \s & drawtree_rectangle(active_win_record.tree, children) & sl_cb() + + return + +end + + +# +procedure format_box_cb(caller, val) + + local e, s + + case e := get(val) of { + "background" : ColorDialog("Select a new background color:", + active_win_record.tree.bg, change_color_bg, + active_win_record.tree.bg) + "total box size" : s := change_box_size() + "visible box size": s := change_box_size_vis() + "snapshot" : s := take_picture() + } + + \s & set_box_shape(active_win_record.tree) & + drawtree_box(active_win_record.tree, children) & + sl_cb() + + return + +end + + +# +procedure change_box_size() + + if Dialog(["Enter a new size of the box:"], [""], + [active_win_record.tree.box_size], [3]) == "Okay" then { + if dialog_value[1] < 0 then Notice("Invalid number") & return fail + else + active_win_record.tree.box_size := get(dialog_value) & return 1 + } + +end + + +# +procedure change_gen_color() + + if Dialog(["Generation coded:"], [""], + [active_win_record.tree.generation], [3]) == "Okay" then + active_win_record.tree.generation := integer(get(dialog_value)) & return 1 + + return fail + +end + + +# +procedure change_box_size_vis() + + if Dialog(["Enter a new size of the box:"], [""], + [active_win_record.tree.draw_box_size], [3]) == "Okay" then { + if dialog_value[1] < 0 | dialog_value[1] > active_win_record.tree.box_size then + Notice("Invalid number: Must be between 0 and ", active_win_record.tree.box_size) & + return fail + else + active_win_record.tree.draw_box_size := get(dialog_value) & return 1 + } + +end + + +# +procedure change_color_bg(id, s) + + active_win_record.tree.bg := s + WAttrib(active_win_record.tree.win, "bg=" || s) + + return 1 + +end + + +# +procedure change_radius() + + local space + + if Dialog(["Enter a new width of the line:"], [""], + [active_win_record.tree.radius], [3]) == "Okay" then { + if dialog_value[1] < 0 then Notice("Invalid number: Must be between 0 and 99, inclusive.") & + return fail + else { + space := active_win_record.tree.radius - active_win_record.tree.space + active_win_record.tree.radius := get(dialog_value) + active_win_record.tree.space := active_win_record.tree.radius - space + return 1 + } + } + +end + + +# +procedure change_linewidth() + + local space + + if Dialog(["Enter a new width of the line:"], [""], + [active_win_record.tree.linewidth], [3]) == "Okay" then { + if dialog_value[1] < 0 then Notice("Invalid number: Must be between 0 and 99, inclusive.") & + return fail + else + active_win_record.tree.linewidth := get(dialog_value) & return 1 + } + +end + + +# +procedure change_gridwidth() + + local space + + if Dialog(["Enter a new width of the grid line:"], [""], + [active_win_record.tree.gridwidth], [3]) == "Okay" then { + if dialog_value[1] < 0 then Notice("Invalid number: Must be between 0 and 99, inclusive.") & + return fail + else + active_win_record.tree.gridwidth := get(dialog_value) & return 1 + } + +end + + +# +procedure change_space() + + if Dialog(["Enter a new space size:"], [""], + [active_win_record.tree.radius - active_win_record.tree.space], + [3]) == "Okay" then { + if (dialog_value[1] < 0) | (dialog_value[1] > active_win_record.tree.radius - 1) then + Notice("Invalid number: Must be between 0 and ", active_win_record.tree.radius - 1, + " inclusive.") & return fail + else { + active_win_record.tree.space := active_win_record.tree.radius - dialog_value[1] + active_win_record.tree.linewidth := get(dialog_value) + return 1 + } + } + +end + + +# +procedure change_space_rec() + + if Dialog(["Enter a new space size:"], [""], + [active_win_record.tree.space], + [3]) == "Okay" then { + if (dialog_value[1] < 0) | (dialog_value[1] > active_win_record.tree.linewidth) then + Notice("Invalid number: Must be between 0 and ", active_win_record.tree.linewidth - 1, + " inclusive.") & return fail + else + active_win_record.tree.space := dialog_value[1] & return 1 + } + +end + + +# +procedure change_length() + + if Dialog(["Enter a new length:"], [""], [active_win_record.tree.length], [3]) == "Okay" then { + active_win_record.tree.length := dialog_value[1] + return 1 } + + return fail + +end + + +# +procedure change_num_of_children() + + if Dialog(["# of children:"], [""], [active_win_record.tree.color_children], [1]) == "Okay" then { + active_win_record.tree.color_children := dialog_value[1] + return 1 } + + return fail + +end + + +# +procedure change_index() + + if Dialog(["Enter a new index:"], [""], [active_win_record.tree.move], [2]) == "Okay" then { + active_win_record.tree.move := dialog_value[1] + return 1 } + + return fail + +end + + +# +procedure change_line_pos() + + if SelectDialog("Vertical or Horizontal?", [VER, HOR], active_win_record.tree.line_pos, + ["Okay", "Cancel"]) == "Okay" then { + if dialog_value == VER then active_win_record.tree.line_pos := VER + else active_win_record.tree.line_pos := HOR + return 1 } + + return fail + +end + + +# +procedure change_justification() + + if SelectDialog("Justification", [LEFT, MIDDLE, RIGHT], + active_win_record.tree.justification, + ["Okay", "Cancel"]) == "Okay" then { + case dialog_value of { + LEFT : active_win_record.tree.justification := LEFT + MIDDLE : active_win_record.tree.justification := MIDDLE + RIGHT : active_win_record.tree.justification := RIGHT + } + return 1 } + + return fail + +end + + +# +procedure change_grid_format() + + local tmp + + \active_win_record.tree.under & tmp := NUNDER + /active_win_record.tree.under & tmp := UNDER + + if SelectDialog("Grid Format", [UNDER, NUNDER], tmp, + ["Okay", "Cancel"]) == "Okay" then { + case dialog_value of { + UNDER : active_win_record.tree.under := &null + NUNDER : active_win_record.tree.under := 1 + } + return 1 } + + return fail + +end + + +# +procedure change_tree() + + local tmp + + \active_win_record.tree.tree & tmp := YES + /active_win_record.tree.tree & tmp := NO + + if SelectDialog("See a tree?", [YES, NO], YES, + ["Okay", "Cancel"]) == "Okay" then { + case dialog_value of { + NO : active_win_record.tree.tree := &null + YES : active_win_record.tree.tree := 1 + } + return 1 } + + return fail + +end + + +# +procedure change_bar_tree() + + local tmp + + \active_win_record.tree.tree & tmp := YES + /active_win_record.tree.tree & tmp := NO + + if SelectDialog("See a bar tree?", [YES, NO], YES, + ["Okay", "Cancel"]) == "Okay" then { + case dialog_value of { + NO : active_win_record.tree.bar := &null + YES : active_win_record.tree.bar := 1 + } + return 1 } + + return fail + +end + + +# +procedure change_population() + + local tmp + + if /active_win_record.tree.tree then tmp := NONE + else tmp := active_win_record.tree.tree + + if SelectDialog("Population:", [NONE, BAR, CIRCLE], tmp, + ["Okay", "Cancel"]) == "Okay" then { + case dialog_value of { + NONE : active_win_record.tree.population := &null + BAR : active_win_record.tree.population := BAR + CIRCLE : active_win_record.tree.population := CIRCLE + } + return 1 } + + return fail + +end + + +# +procedure change_color_format() + + local tmp + + \active_win_record.tree.tree & tmp := "Population" + /active_win_record.tree.tree & tmp := "Generation" + + if SelectDialog("Color format?", ["Population", "Generation"], tmp, + ["Okay", "Cancel"]) == "Okay" then { + case dialog_value of { + "Generation" : active_win_record.tree.num_children_code := &null + "Population" : active_win_record.tree.num_children_code := 1 + } + return 1 } + + return fail + +end + + +# +procedure change_gap() + + if Dialog(["Enter a new gap:"], [""], [active_win_record.tree.gap], [2]) == "Okay" then { + active_win_record.tree.gap := dialog_value[1] & return 1 } + + return fail + +end + + +# +procedure take_picture() + + snapshot(active_win_record.tree.win, + active_win_record.hpos, active_win_record.vpos, + active_win_record.view_width, active_win_record.view_height-MENUSIZE) + + return fail + +end + + + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=220,368", "bg=gray-white"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,220,368:",], + ["bar:Button:regular:1:50,105,98,20:Bar",DrawTree_cb], + ["box:Button:regular:1:21,341,28,17:Box",DrawTree_cb], + ["circle:Button:regular:1:50,77,98,20:Circle",DrawTree_cb], + ["file:Menu:pull::0,0,36,21:File",file_cb, + ["Input Data","quit"]], + ["fomat:Menu:pull::37,0,50,21:Format",format_gen_cb, + ["Max # Nodes","Max # Children","Generate","Directory"]], + ["label1:Label:::20,52,126,13:Directed Approach:",], + ["label2:Label:::21,156,119,13:Layered Approach:",], + ["layer:Button:regular:1:51,178,100,21:Layer",DrawTree_cb], + ["line1:Line:::0,22,219,22:",], + ["where:Rect:sunken::18,262,185,40:",], + ) +end +#===<<vib:end>>=== end of section maintained by vib + diff --git a/ipl/gpacks/drawtree/generate.icn b/ipl/gpacks/drawtree/generate.icn new file mode 100644 index 0000000..065e2fa --- /dev/null +++ b/ipl/gpacks/drawtree/generate.icn @@ -0,0 +1,193 @@ +global gen_table + + +# set the default for Children_R +procedure children_default() + + return Children_R(50, 3, table(), table()) + +end + +# generates children +procedure children_generation(children) + + local parent_id + local delete_id + local max + local id + local child + local parents + local num + + # set up the first child + max := ?children.max_children + children.all[0] := Child_Node_R(0, set(), &null, 0, 2 * &pi) + + # give child(ren) to the first node + every insert(children.all[0].children_id, 1 to max) + + # add the new children to the children list and set the children + # to be ready as parents + parents := set() + every insert(parents, id := !children.all[0].children_id) do + children.all[id] := Child_Node_R(0, set()) + + # generate children for each child created, some children may not have children + + every id := max+1 to children.num_children do + { + num := 0; + + # get a parent and give it a child + parent_id := ?parents + children.all[id] := Child_Node_R(parent_id, set()) + insert(children.all[parent_id].children_id, id) + insert(parents, id) + + # delete the parent from the parents set of has max number of children + if *children.all[parent_id].children_id >= children.max_children then + delete(parents, parent_id) + + # randomly delete a parent + delete_id := ?[1, &null] + if \delete_id & *parents ~== 0 then + { + until *children.all[id := ?parents].children_id ~== 0 do + if (num +:= 1) > (2 * *parents) then break; + delete(parents, id) + } + } + + count_children( children, 0 ) + # get the base and the bound for each child + assign_base_and_bound( children ) + # find the generation for each child + count_gen( children, 0, 0 ) + # print out children + # print_out(children) + # count number of children per generation + num_children_per_generation(children) + +end + + +# count the number of children +procedure count_children( children, id ) + + children.all[id].children_num := *children.all[id].children_id + every children.all[id].children_num +:= count_children(children, !children.all[id].children_id) + + return children.all[id].children_num + +end + + +# find the generation for each child +procedure count_gen( children, id, generation ) + + children.all[id].generation := generation + every count_gen(children, !children.all[id].children_id, generation + 1) + + return + +end + + +# get the base and the bound for each child +procedure assign_base_and_bound(children) + + local id, range, base, bound, num, child, base_s, bound_s + + # get the base and the bound + every id := 0 to children.num_children do + { + # get the base and the bound of its parent + bound_s := bound := children.all[id].bound + base_s := base := children.all[id].base + + # find the range and calulate its own base and bound + range := bound - base + every child := !children.all[id].children_id do + { + num := (children.all[child].children_num + 1)* range / children.all[id].children_num + bound_s := num + base_s + children.all[child].base := base_s + children.all[child].bound := bound_s + base_s := bound_s + } + } + +end + + +# find the number of children per generation +procedure num_children_per_generation(children) + + local id, num_of_children + + children.num_gen := table() + + every id := 0 to children.num_children do + children.num_gen[id] := 0 + + every id := 0 to children.num_children do { + num_of_children := *children.all[id].children_id + children.num_gen[children.all[id].generation + 1] +:= num_of_children + } + children.num_gen[0] := 1 + +end + + +# get the id number for each child for its generation starting at 1 +procedure get_gen_id(children, child) + + gen_table := table() + + every gen_table[0 to children.num_children] := 1 + + N_get_gen_id(children, child) + +end + + +procedure N_get_gen_id(children, child) + + local gen, new_child + + gen := children.all[child].generation + children.all[child].gen_id := gen_table[gen] + gen_table[gen] +:= 1 + + every new_child := !children.all[child].children_id do + N_get_gen_id(children, new_child) + +end + + + +procedure print_out(children) + + local id, child + + write(left("Child", 4), left("Parent",4), left("Children", 21), + left("Num", 4), + left("base", 7), left("bound", 7), left("gen", 7)) + + every id := 0 to children.num_children do + { + child := "" + every child ||:= " " || !children.all[id].children_id + write(left(id, 4), left(children.all[id].parent_id,4), + left(child, 20), + left(children.all[id].children_num, 4), + left(children.all[id].base, 6), left(" ", 1), + left(children.all[id].bound, 6), left(" ", 1), + left(children.all[id].generation, 3)) + } + +end + + + + diff --git a/ipl/gpacks/drawtree/info.icn b/ipl/gpacks/drawtree/info.icn new file mode 100644 index 0000000..ef3f925 --- /dev/null +++ b/ipl/gpacks/drawtree/info.icn @@ -0,0 +1,70 @@ +# CONSTANT + +$define MAX_NODES "Max # Nodes" +$define MAX_CHILDREN "Max # Children" +$define GENERATE "Generate" +$define QUIT "quit" +$define DIRECTORY "Directory" +$define INPUT_DATA "Input Data" + +$define VER "Vertical" +$define HOR "Horizontal" + +$define LEFT "Left" +$define MIDDLE "Middle" +$define RIGHT "Right" + +$define UNDER "Under" +$define NUNDER "Not Under" + +$define YES "Yes" +$define NO "No" + +$define NONE "None" +$define BAR "Bar" +$define CIRCLE "Circle" + +# scroll bar +$define WINDOW_SIZE 300 +$define IMAGE_SIZE 1500 +$define SCROLLBAR_WIDTH 15 +$define MENUSIZE 25 + +$define COLOR_LIST [1, 2, 3, 4] +$define COLOR_LIST_U ["red", "blue", "green", "orange", "yellow", "brown", "purple"] +$define BG "white" +$define FG "black" +$define MAX_COL 65535 +$define BLUE "0,0,65535" +$define GREEN "0,65535,0" +$define RED "65535,0,0" + +$define GEN 1 +$define DIR 2 +$define DATA 3 + +# table of children +global children + +# records for trees +global circle_record +global square_record +global rectangle_record +global box_record + +# records for scroll windows +global win_record_one +global win_record_two +global win_record_three +global win_record_four +global active_win_record # a flag to keep track of the active window + +global vidgets + +global vidgets +global vidgets_color + +global color_dialog_open # flag if dialog is open +global color_window, color_root + + diff --git a/ipl/gpacks/drawtree/record.icn b/ipl/gpacks/drawtree/record.icn new file mode 100644 index 0000000..c81425f --- /dev/null +++ b/ipl/gpacks/drawtree/record.icn @@ -0,0 +1,104 @@ +record Child_Node_R ( + parent_id, # the parent + children_id, # its children id numbers + children_num, # number of children + base, # the base + bound, # the bound + generation, # the generation it appears + gen_id # the id number of its generation + ) + + +record Children_R ( + num_children, # number of children a tree represents + max_children, # max number of children a child can have + num_gen, # number of children at certain generation + all ) # a table of Child_Node_R + + +record Scroll_Win_Record( + id, # the window id number + win, # the window + vpos, + hpos, + view_width, # the width of the view area + view_height, # the height of the view area + resize_state, # 1 if resize event is noticed + scv, # the length of the vertical scroll bar + sch, # the length of the horizonal scroll bar + picw, # + pich, # + FormatMenu, # the menu bar + tm, + root, # the root of the window + tree) # + + +record DrawTree_Circle_R(win, # the window for the tree + window_size, # the window size + bg, # background color + fg, # foreground color + color_list, # id color in the list + color_list_u, # color + num_color, # number for color in the list + radius, # starting place to draw the line + space, # ending place to draw the line + gap, # space between children + linewidth, # the size of the line + generation, # color code of generation + tree, # tree + num_children_code, # color code by population + color_children, + menu) # list for the menu bar + +record DrawTree_Square_R(win, # the window for the tree + win_height, # the window height + win_width, # the window width + bg, # background color + fg, # foreground color + color_list, # id color in the list + color_list_u, # color + num_color, # number of color in the list + linewidth, # size of the line + gridwidth, # size of the grid line + line_pos, # draw the line ver or hor + length, # the length of the longest child + space, # the space between each child + move, # index of the bar + under, # format of the grid + population, # bar graph of # of children + justification, # starts bar: left, middle, or right + num_children_code, # color code by population + tree, # see the tree by lines + bar, # see the tree by bars + generation, # color code of generation + color_children, + x, + y, + menu) + + + +record DrawTree_Box_R(win, # the window for the tree + win_height, # the window height + win_width, # the window width + bg, # background color + fg, # foreground color + color_list, # id color in the list + color_list_u, # color + num_color, # number of color in the list + box_size, # size of the box in pixels + draw_box_size, # size of the visible box in pixels + grid_y, # a table for coord of y + grid_x, # a table for coord of x + grid_y_coor, # a table + grid_x_coor, # a table + x_num, # size of grid_x + y_num, # size of grid_y + x_start, # the first x box on a line + menu) + + + + + diff --git a/ipl/gpacks/ged/Makefile b/ipl/gpacks/ged/Makefile new file mode 100644 index 0000000..46e88db --- /dev/null +++ b/ipl/gpacks/ged/Makefile @@ -0,0 +1,11 @@ +ICONT=icont +IFLAGS=-us + +ged: ged.icn control.icn textedit.icn + $(ICONT) $(IFLAGS) ged control textedit + +Iexe: ged + cp ged ../../iexe/ + +Clean: + rm -f ged *.u? diff --git a/ipl/gpacks/ged/control.icn b/ipl/gpacks/ged/control.icn new file mode 100644 index 0000000..41aeaf3 --- /dev/null +++ b/ipl/gpacks/ged/control.icn @@ -0,0 +1,410 @@ +############################################################################ +# +# Name: control.icn +# +# Title: Controls for ged.icn +# +# Author: Robert J. Alexander +# +# Date: June 27, 1993 +# +############################################################################ +# +# General code for controls +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ + +global ControlList,ControlExit + +record MouseEvent(type,x,y) + + +procedure DoEvents(w,unusedEventProc,data) + local ctrl,evt,interval,mx,my + until \ControlExit do { + WAttrib(w,"pointer=top left arrow") + evt := Event(w) + interval := &interval + case type(evt) of { + "string": { + (\unusedEventProc)(w,evt,data,interval) + } + "integer": { + mx := &x + my := &y + if evt = &lpress then { # if left mouse button mouse down + if ctrl := GetControl(mx,my) then { + case type(ctrl) of { + "Button": { + TrackButton(ctrl,data,mx,my) + } + default: &null + } | break + } + else (\unusedEventProc)(w,evt,data,interval,mx,my) + } + else (\unusedEventProc)(w,evt,data,interval,mx,my) + } + default: (\unusedEventProc)(w,evt,data,interval) + } + } + return +end + + +procedure InitControl() + ControlList := [] + return +end + + +procedure AddControl(ctrl) + push(ControlList,ctrl) + return ctrl +end + + +procedure RemoveControl(ctrl) + local i + every i := 1 to *ControlList do { + if ControlList[i] === ctrl then { + ControlList := ControlList[1:i] ||| ControlList[i + 1:0] + return ctrl + } + } +end + + +procedure GetControl(x,y) + local btn + every btn := !ControlList do { + if PtInRect(x,y,btn.x,btn.y,btn.width,btn.height) then + return btn + } +end + + +# +# Buttons +# + +record Button(w,x,y,width,height,event,data,value, + contents,font) + + +procedure TrackButton(btn,data,mx,my) + local evt,w + w := btn.w + btn.event(btn,"pressed",data,mx,my) + repeat { + evt := Event(w) + if type(evt) == "integer" then { + mx := &x + my := &y + case evt of { + &ldrag|&mdrag|&rdrag: { # dragging + btn.event(btn,"dragging",data,mx,my) + } + &lrelease: { # mouse release left + return btn.event(btn, + if PtInRect(mx,my,btn.x,btn.y,btn.width,btn.height) then + "released" else "cancelled",data,mx,my) + } + } + } + } +end + + +procedure NewButton(w,x,y,width,height,event,data,value,contents,font) + local btn + btn := Button(w,x,y,width,height,event,data,value,contents,font) + return AddControl(btn) +end + + +procedure RemoveButton(btn) + return RemoveControl(btn) +end + + +procedure DrawButton(btn) + local charHeight,charWidth,font,nameWidth,nm,w,x,y + w := btn.w + DrawRectangle(w,btn.x,btn.y,btn.width,btn.height) + case type(nm := btn.contents) of { + "string": { + Font(w,\font) + charWidth := WAttrib(w,"fwidth") + charHeight := WAttrib(w,"fheight") + nameWidth := *nm * charWidth + GotoXY(w,x + (btn.width - nameWidth) / 2, + y + (btn.height - charHeight) / 2 + charHeight * 7 / 8) + writes(w,nm) + GotoXY(w,0,0) + } + "procedure": { + btn.contents(w,btn) + } + } + return +end + + +# +# Scrollers +# + +global ScrollDelay + +record Scroller(w,x,y,width,height,event,data,value, + maxValue,smallScroll,largeScroll,upBtn,downBtn,thumbBtn,centerBtn) + + +procedure NewScroller(w,x,y,width,height,event,data,value, + maxValue,smallScroll,largeScroll) + local scroller + initial ScrollDelay := 100 + /value := 1 + /width := 18 + scroller := Scroller(w,x,y,width,height,event,data,value, + maxValue,smallScroll,largeScroll) + AddControl(scroller) + scroller.upBtn := NewButton(w,x,y,width,width, + Scroll_BtnEvent,scroller,,Scroll_UpArrow) + scroller.downBtn := NewButton(w,x,y + height - width,width,width, + Scroll_BtnEvent,scroller,,Scroll_DownArrow) + scroller.centerBtn := NewButton(w,x,y + width,width,height - 2 * width, + Scroll_CenterEvent,scroller,,Scroll_CenterContents) + scroller.thumbBtn := NewButton(w,x,0,width,width, + Scroll_ThumbEvent,scroller,,Scroll_ThumbContents) + Scroll_SetValue(scroller,scroller.value) + return scroller +end + + +procedure RemoveScroller(scroller) + every RemoveButton(scroller.upBtn | scroller.downBtn | scroller.thumbBtn | + scroller.centerBtn) + return RemoveControl(scroller) +end + + +procedure DrawScroller(scroller) + local height,w,width,x,y + w := scroller.w + x := scroller.x + y := scroller.y + width := scroller.width + height := scroller.height + DrawRectangle(w,x,y,width,height) + DrawButton(scroller.upBtn) + DrawButton(scroller.downBtn) + Scroll_DrawThumb(scroller) + return scroller +end + + +procedure Scroll_BtnEvent(btn,evt,data) + local incr,scroller + static delayDone + scroller := btn.data + incr := case btn of { + scroller.upBtn: -scroller.smallScroll + default: +scroller.smallScroll + } + if evt == "pressed" then { + delayDone := &null + Scroll_DoScroll(scroller,incr,data) + } + else if evt == ("released" | "cancelled") then return + until type(Pending(btn.w)[1]) == "integer" do { + if /delayDone then { + delay(ScrollDelay) + delayDone := 1 + } + else Scroll_DoScroll(scroller,incr,data) + } + return +end + + +procedure Scroll_CenterEvent(btn,evt,data,x,y) + local incr,largeScroll,scroller,thumbBtn + static delayDone,direction + scroller := btn.data + thumbBtn := scroller.thumbBtn + largeScroll := scroller.largeScroll + incr := if y < thumbBtn.y then -largeScroll else +largeScroll + if evt == "pressed" then { + delayDone := &null + direction := incr + Scroll_DoScroll(scroller,incr,data) + } + else if evt == ("released" | "cancelled") then return + until type(Pending(btn.w)[1]) == "integer" do { + if incr := if y >= thumbBtn.y + thumbBtn.height then + +largeScroll else if y < thumbBtn.y then -largeScroll then { + if incr = direction then { + if /delayDone then { + delay(ScrollDelay) + delayDone := 1 + } + else Scroll_DoScroll(scroller,incr,data) + } + } + } + return +end + + +procedure Scroll_DoScroll(scroller,incr,data) + local oldValue + oldValue := scroller.value + if Scroll_SetValue(scroller,scroller.value + incr) ~= oldValue then { + Scroll_DrawThumb(scroller) + scroller.event(scroller,"scrolled",data,oldValue) + } + return +end + + +procedure Scroll_ThumbEvent(btn,evt,data,x,y) + local scroller,w + static dy + scroller := btn.data + case evt of { + "pressed": { + dy := y - btn.y + } + "released" | "cancelled": { + Scroll_DoThumb(scroller,y - dy,data) + return + } + } + until type(Pending(btn.w)[1]) === "integer" do { + Scroll_DoThumb(scroller,y - dy,data) + } + return +end + + +procedure Scroll_DoThumb(scroller,y,data) + local centerBtn,oldValue + centerBtn := scroller.centerBtn + oldValue := scroller.value + if Scroll_SetValue(scroller,(scroller.maxValue - 1) * + (y - centerBtn.y) / + (centerBtn.height - centerBtn.width) + 1) ~= oldValue then { + Scroll_DrawThumb(scroller) + scroller.event(scroller,"scrolled",data,oldValue) + } + return +end + + +procedure Scroll_CenterContents(w,btn) + $ifdef TRUE_GRAY + WAttrib(w,"fg=gray") + $else + Pattern(w,"2,1,2") + WAttrib(w,"fillstyle=opaquestippled") + $endif + FillRectangle(w,btn.x,btn.y,btn.width,btn.height) + $ifdef TRUE_GRAY + WAttrib(w,"fg=black") + $else + WAttrib(w,"fillstyle=solid") + $endif + DrawRectangle(w,btn.x,btn.y,btn.width,btn.height) + return +end + + +procedure Scroll_ThumbContents(w,btn) + FillRectangle(w,btn.x,btn.y,btn.width,btn.height) + return +end + + +procedure Scroll_SetValue(scroller,value) + (value >:= scroller.maxValue) | (value <:= 1) + scroller.value := value + scroller.thumbBtn.y := scroller.y + scroller.width + + ((scroller.height - 3 * scroller.width) * + (scroller.value - 1) / (0 ~= scroller.maxValue - 1) | 0) + return value +end + + +procedure Scroll_DrawThumb(scroller) + DrawButton(scroller.centerBtn) + DrawButton(scroller.thumbBtn) + return +end + + +procedure Scroll_UpArrow(w,btn) + local x,xseg,y,yseg + x := btn.x + y := btn.y + xseg := btn.width / 6.0 + yseg := btn.height / 6.0 + DrawLine(w, + x + 3 * xseg,y + 1 * yseg, + x + 5 * xseg,y + 3 * yseg, + x + 4 * xseg,y + 3 * yseg, + x + 4 * xseg,y + 5 * yseg, + x + 2 * xseg,y + 5 * yseg, + x + 2 * xseg,y + 3 * yseg, + x + 1 * xseg,y + 3 * yseg, + x + 3 * xseg,y + 1 * yseg) + return +end + + +procedure Scroll_DownArrow(w,btn) + local x,xseg,y,yseg + x := btn.x + y := btn.y + xseg := btn.width / 6.0 + yseg := btn.height / 6.0 + DrawLine(w, + x + 3 * xseg,y + 5 * yseg, + x + 5 * xseg,y + 3 * yseg, + x + 4 * xseg,y + 3 * yseg, + x + 4 * xseg,y + 1 * yseg, + x + 2 * xseg,y + 1 * yseg, + x + 2 * xseg,y + 3 * yseg, + x + 1 * xseg,y + 3 * yseg, + x + 3 * xseg,y + 5 * yseg) + return +end + + +# +# Utility Procedures +# + +procedure PtInRect(px,py,rx,ry,rwidth,rheight) + return (rx <= px < rx + rwidth & ry <= py < ry + rheight,&null) +end + +## procedure ShowArgs(x[]) + ## argnbr := 0 + ## every y := !x do { + ## write("arg ",argnbr +:= 1," = ",image(y)) + ## } + ## return y +## end + +## procedure wr(s[]) + ## return + ## every writes(!s) + ## write() + ## return +## end diff --git a/ipl/gpacks/ged/ged.icn b/ipl/gpacks/ged/ged.icn new file mode 100644 index 0000000..0446d1e --- /dev/null +++ b/ipl/gpacks/ged/ged.icn @@ -0,0 +1,153 @@ +############################################################################ +# +# Name: ged.icn +# +# Title: Mouse-Oriented Text Editor for Windows +# +# Author: Robert J. Alexander +# +# Date: April 17, 1993 +# +############################################################################ +# +# Usage: (see Usage() procedure, below) +# +# See the file "textedit.icn" for a list of the editor's features. +# +############################################################################ +# +# Links: io, options, textedit +# +############################################################################ + +link io +link options +link textedit + +procedure Usage(s) + write(\s) + write( + "Usage: ged <options> file..._ + \n_ + \nIf file is \"-\" then standard input is edited read-only._ + \n_ + \nOptions:_ + \n_ + \n -g s Geometry (<columns>x<lines>+x+y)_ + \n -f s Font_ + \n -t n Tab stop spacing_ + \n -b Don't keep backup file if write successful_ + \n -i Don't ignore case in find and replace_ + \n -c s Save context in file \"s\"_ + \n -T s Window title (if omitted, first file name is used)_ + \n -R Read-only_ + \n -S Standard input file prompts for save before close_ + \n -L n Start at line number n_ + \n -N x Buffer name for standard input file_ + \n -H Print help window text to standard output_ + \n -E s Repeated string to use as first line past EOF_ + \n -X Use this if window manager crashes while scrolling_ + \n_ + \n <<< Use control-? to get a \"help\" window. >>>_ + \n") + exit() +end + + +global Geometry,Font,WindowName,ReadOnly,LineNbr,Tabs,IgnoreCase,CopyAreaBug, + UseCtx,CtxFile,StdInBufName,RmBackup,EOFStr,SaveStdIn + +procedure Options(arg) + local opt + opt := options(arg,"Rg:f:t+T:L+hHiXc:N:bE:S",Usage) + if \opt["h"] then Usage() + if \opt["H"] then { + write(EditHelpText()) + exit() + } + Geometry := \opt["g"] | "80x48" + Font := \opt["f"] | "fixed" + WindowName := opt["T"] + StdInBufName := opt["N"] + SaveStdIn := opt["S"] + Tabs := (1 <= \opt["t"] | 8) + 1 + ReadOnly := opt["R"] + LineNbr := \opt["L"] | 1 + IgnoreCase := (\opt["i"],&null) | 1 + CopyAreaBug := opt["X"] + UseCtx := CtxFile := opt["c"] + RmBackup := opt["b"] + EOFStr := opt["E"] + return opt +end + + + + +procedure main(arg) + local fn,f,text,ctx + Options(arg) + InitControl() + AddCtx(arg) + ctx := Edit(arg,Geometry,Font,WindowName,1,,,ReadOnly,LineNbr,IgnoreCase, + UseCtx,LoadFile,SaveFile,RmBackup,EOFStr) + WriteCtx(ctx) +end + + +procedure AddCtx(arg) + local f,t,line,r,i + if \UseCtx & f := open(CtxFile) then { + if *arg = 0 then { + while put(arg,read(f)) + } + else { + t := table() + while line := read(f) do { + r := EditParseCtx(line) + t[r.fileName] := line + } + every i := 1 to *arg do { + arg[i] := \t[arg[i]] + } + } + close(f) + return + } +end + + +procedure WriteCtx(ctx) + local f,fn + if \UseCtx & type(ctx) == "list" & f := open(CtxFile,"w") then { + every fn := !ctx do { + if not match("*",fn) then write(f,fn) + } + close(f) + return + } +end + + +procedure LoadFile(fn) + local f,text,changed + if fn == "-" then { + f := &input + fn := \StdInBufName | "*Standard Input*" + ReadOnly := 1 + changed := SaveStdIn + } + else { + f := open(fn) | fail + } + text := [] + every put(text,!f) + close(&input ~=== f) + return EditLoadRec(text,fn,changed) +end + + +procedure SaveFile(fn, text) + stop() # this isn't called, yet (files are inappropriately saved in + # the edit proc) +end diff --git a/ipl/gpacks/ged/textedit.icn b/ipl/gpacks/ged/textedit.icn new file mode 100644 index 0000000..06a98c4 --- /dev/null +++ b/ipl/gpacks/ged/textedit.icn @@ -0,0 +1,3091 @@ +############################################################################ +# +# Name: textedit.icn +# +# Title: Mouse-Oriented Text Edit Widget for Windows +# +# Author: Robert J. Alexander +# +# Date: June 27, 1993 +# +############################################################################ +# +# Features +# +# - Lots of commands, currently invoked by control-keys (until menus +# are implemented). Use ^? in the editor to get a help screen, +# or see the EditHelpText() procedure, below. +# +# - Selections are started by clicking with the left mouse button. +# They are extended by dragging with the left button, or by +# clicking and/or dragging with center or right button. +# +# - Double-click selects word; triple-click selects line. Double- +# click on a bracket-type character (one of '{}()[]<>', or +# single or double quote) selects text between it and its mate. +# Double- click on a non-word, non-bracked character selects a +# single character. +# +# - Multiple level undo-redo. The number of actions that can be +# undone/redone is currently set arbitrarily to MaxUndo (see +# code). In this version, each keystroke is individually +# undoable. Only data- modifying actions, currently, are +# undoable (i.e. cursor movements are not undoable). +# +# - A Find/Replace facility that supports regular expressions as +# well as plain character strings. To find a regular expression +# bracket the Find string with slashes /.../. The regular +# expressions are nearly identical to egrep style -- see file +# regexp.icn for details. +# +# - Multiple files open concurrently (i.e. multiple buffers) each +# with their own contexts, and the many features for navigation +# among them and closing unneeded ones. +# +# - Editing code is written with reusability in mind, but is not +# quite ready for it yet. For example, currently +# window-relative x and y coordinates cannot be specified. But +# it's not too far off. +# +# +# Features to add: +# +# Better command-entry user interface (menus). +# Dynamically updating, non-modal info windows (maybe). +# Line wrap mode. +# Consider revising undo for typed characters. Currently there +# is one undo event per character typed. +# Save As. +# User-defined commands, keys. +# "Modified" indicator in title (this was once coded but didn't work). +# +# Implementation improvements: +# +# Use the fast scrolling capability as used for the scroll bars +# for other scrolling needs, too, like find, go to line, etc. +# Revise method of searching for matching brackets -- currently is +# geometrical with space between brackets -- a long wait +# if no matching bracket found. +# Change event handling so that there is a central event +# dispatcher, not one in "control", maybe. (This +# really applies to "control.icn", not "edit"). +# Implement textedit more independent from ged, so that it can +# serve as a general text widget. +# +# System-dependent code +# +# There is some system-dependent code in this file, which is +# currently enabled for UNIX and OS/2. Some features are disabled +# for other systems. Those areas of code can be located by +# searching for the word "System". If any of you users of +# unsupported systems add support for your system, please pass the +# changes on (to me: alex@metaphor.com, or to Ralph Griswold in +# care of the Icon Project, who can forward it to me). +# +# BUGS: +# +# Insertion point can go off-screen when using "arrow" keys. +# See "better bulletproofing" in "Features", above. +# +# +# Procedures and Records in textedit.icn (alphabetically): +# +# Edit() EditMemoryStats() +# EditAddTrail() EditMessage() +# EditAddUndo() EditMouseEvent() +# EditAdjustMarks() EditMoveBufToFront() +# EditBackTrail() EditNewBuffer() +# EditBackupFile() EditNextBuffer() +# EditBeep() EditNonPos() +# EditBufCtxList() EditNoteState() +# EditBufNameList() EditOpen() +# EditBuffer. EditOpenCmd() +# EditChanged() EditOpenSelectedFile() +# EditClearMsgPos() EditOutputSelection() +# EditClearTrail() EditPaintLines() +# EditClose() EditParseCtx() +# EditCopy() EditPaste() +# EditCreateMark() EditPrevBuffer() +# EditCreateMarkCmd() EditQuit() +# EditCreateMsgBox() EditRec. +# EditCreateOneLineBuffer() EditRecentBuffer() +# EditCtxRec. EditRedo() +# EditCursorBox() EditRefreshAndScroll() +# EditCursorDown() EditRefreshScreen() +# EditCursorLeft() EditReplace() +# EditCursorRight() EditReplaceAgainCmd() +# EditCursorUp() EditReplaceCmd() +# EditCut() EditResizeWindow() +# EditCwd() EditRunFilter() +# EditDataKeyTyped() EditSave() +# EditDelete() EditSaveCmd() +# EditDeleteCmd() EditSaveCopy() +# EditDeleteMark() EditSaveEvery() +# EditDeleteToEnd() EditScreenLine() +# EditDeleteTrail() EditScroll() +# EditDisplaySelection() EditScrollToLine() +# EditDupAtLastClick() EditScrollToSelection() +# EditEqualSel() EditScrollToSelectionIfOffScreen() +# EditErrorMessage() EditScrolled() +# EditEvent() EditSelectAll() +# EditExecuteIcon() EditSelectLine() +# EditExpandImageLine() EditSelectNonspaces() +# EditExpandNormalLine() EditSelectWholeLines() +# EditExpandText() EditSelectWord() +# EditFind() EditSelectedTag() +# EditFindAgainCmd() EditSelection. +# EditFindCmd() EditSelectionLines() +# EditFindFileAndLine() EditSelectionToFind() +# EditFindTag() EditSetMaxUndo() +# EditFlushEvents() EditSetScroll() +# EditFnTail() EditShellCommand() +# EditForeTrail() EditShiftLeft() +# EditForgetUndos() EditShiftLines() +# EditGetOneKey() EditShiftRight() +# EditGetScreenOffset() EditSortSelection() +# EditGetStringOffset() EditTag. +# EditGetTextDialog() EditTextAsNeeded() +# EditGoToCol() EditTextFromFileCmd() +# EditGoToLine() EditToggleAutoIndent() +# EditGoToLineCmd() EditToggleBackward() +# EditGoToMark() EditToggleCase() +# EditGoToMarkCmd() EditToggleImage() +# EditGoToTag() EditToggleTrace() +# EditHelpBuffer() EditToggleWrap() +# EditHelpCmd() EditTrailRec. +# EditHelpText() EditUndo() +# EditHighlightSelection() EditUndoRec. +# EditInfoCmd() EditValidateSelection() +# EditInputSelection() EditWaitForAnyEvent() +# EditInsertBuffers() EditWriteMode() +# EditIsEmptySelection() EditWriteToFile() +# EditKeyEvent() EditWrites() +# EditLoadRec. Max() +# EditMakeTmp() Min() +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: control, varsub, regexp, shquote, xcompat +# +############################################################################ + +procedure EditHelpText() + static text + initial { + EditSetMaxUndo() + # + # The commands. + # + text := ( + "\n Control Key Commands_ + \n --------------------_ + \n Q quit_ + \n O open..._ + \n W close..._ + \n D write a copy..._ + \n S save_ + \n E save every modified buffer..._ + \n C copy_ + \n X cut_ + \n V paste_ + \n Z undo (up to " || MaxUndo || " changes)_ + \n Y redo_ + \n @ go to line and/or column..._ + \n A select all_ + \n H cursor left_ + \n J cursor down_ + \n K cursor up_ + \n L cursor right_ + \n F find..._ + \n G find again_ + \n U set \"find\" string from selection_ + \n R replace..._ + \n T replace again_ + \n B backward mode toggle for find/replace_ + \n $ info..._ + \n ? open help buffer_ + \n_ + \n Escape Key Commands_ + \n --------------------_ + \n d duplicate selected text at \"*Last Click*\"_ + \n ` go to \"*Last Place*\"_ + \n . next buffer (unshifted \">\")_ + \n , previous buffer (unshifted \"<\")_ + \n 1 *Scratch* buffer_ + \n 2-8 nth most recent buffer_ + \n o open selected file_ + \n B insert buffer names_ + \n r enter data from file..._ + \n l locate selection_ + \n m mark location..._ + \n j jump to mark..._ + \n t add current location to trail_ + \n T clear trail_ + \n 9 go to last trail location (unshifted \"(\")_ + \n 0 go to next trail location (unshifted \")\")_ + \n p go to selected tag_ + \n P discard cached tags table_ + \n bksp delete to end of text_ + \n [ shift lines left 1 column_ + \n ] shift lines right 1 column_ + \n u \"show unprintables\" toggle_ + \n a auto indent toggle_ + \n return execute selected text as shell command_ + \n i execute selected text as Icon code_ + \n f run program to filter selection..._ + \n R insert ruler_ + \n s go to \"file:line\" in selected text..._ + \n w wrap mode toggle for find/replace_ + \n c case independence toggle for find/replace_ + \n v enter control character_ + \n x reverse (transpose) selected characters_ + \n Q quit without saving context_ + \n & &trace toggle_ + \n M memory allocation statistics..._ + \n Z forget undos and redos for buffer_ + \n") + } + return text +end + + +link control,varsub,regexp,shquote +link xcompat + + +record EditRec(w,text,selection,scroller, + rows,columns,dialogFile,undoStatus,autoIndent,image,readOnly, + backward,wrap,ignoreCase,findString,replaceString,lastKey, + lastData,oldTextLen,oldSel,wname,buf,bufferTable,bufferList, + loadFileProc,saveFileProc,enterControl,msgX,msgY,boxShowing, + backTrail,foreTrail,useCtx,exitCtxList,tempDir,rmBackup,wd,lastFilter) +record EditBuffer(text,selection,saveFileName,autoIndent,image,scrollValue, + undoList,redoList,readOnly,initialSize,version,saveVersion,markTable) +record EditSelection(r1,c1,r2,c2) +record EditUndoRec(proc,args,selection,oldSel,version) +record EditTag(fileName,pattern) +record EditLoadRec(text,fileName,changed) + +global EditFunnyChars,SpecialFn,WordSet,System,Space,NonSpace,MaxUndo, + EditClipboard,EditEOFStr +global EditTextAsNeededLength,EditTextAsNeededLines +global scrollWidth + + +procedure EditSetMaxUndo() + return .(MaxUndo := 100) +end + + +procedure Edit(fnList,geometry,font,wname, + autoIndent,img,dialogFile,readOnly,lineNbr,ignoreCase,useCtx, + loadFileProc,saveFileProc,rmBackup,eofStr) + local columns,e,geo,height,position,rows,w,width,x,i,wdwname + initial { + EditFunnyChars := &cset[1:33] ++ &cset[128:0] -- "\t" + WordSet := &letters ++ &digits ++ "_" + Space := ' \t\v\n\r\f' + NonSpace := ~Space + System := + if &features == "UNIX" then "UNIX" + else if match("OS/2 ",&host) then "OS2" + EditSetMaxUndo() + EditClipboard := "XedClip" + EditEOFStr := \eofStr | "~" + } + scrollWidth := 18 + SpecialFn := "*Scratch*" + /geometry := "80x24" + /font := "fixed" + x := XBind("font=" || font) | + stop("Can't create window with font ",image(font)) + geometry ? { + columns := tab(find("x")) & move(1) & rows := tab(upto('+-')\1 | 0) + position := tab(0) + } + columns := integer(columns) | 80 + rows := integer(rows) | 24 + /wname := EditFnTail(EditCwd()) || + (case System of {default: "/" ; "OS2": "\\"}) + wdwname := EditFnTail(&progname) || " -- " || (\wname | "") + columns +:= 4 # Crude way to make room for the scroll bar + geo := columns * WAttrib(x,"fwidth") || "x" || rows * WAttrib(x,"fheight") || + position + x := &null + w := open(wdwname,"x","font=" || font,"geometry=" || geo, + "cursor=on") | + stop("Can't create window") + width := WAttrib(w,"width") + height := WAttrib(w,"height") + e := EditRec( + w, # w + , # text + , # selection + # scroller + NewScroller(w,width - scrollWidth,-1,scrollWidth,height + 1, + EditScrolled,e,1,1,1,rows - 2), + rows, # rows + columns, # columns + dialogFile, # dialogFile + , # undoStatus + autoIndent, # autoIndent + img, # image + readOnly, # readOnly + , # backward + 1, # wrap + ignoreCase, # ignoreCase + , # findString + , # replaceString + , # lastKey + , # lastData + , # oldTextLen + , # oldSel + wdwname, # wname + , # buf + table(), # bufferTable + list(), # bufferList + loadFileProc, # loadFileProc + saveFileProc, # saveFileProc + , # enterControl + , # msgX + , # msgY + , # boxShowing + [], # backTrail + [], # foreTrail + useCtx, # useCtx + , # exitCtxList + ("" ~== getenv("TMP")) || "/" | # tmpdir + (case System of {default: "/tmp/" ; "OS2": "c:/tmp/"}), + rmBackup, # rmBackup + wname, # wd + "") # lastFilter + every EditOpen(e,!fnList[2:0],readOnly) + EditOpen(e,fnList[1],readOnly) + if *e.bufferList = 0 then EditOpen(e) + if lineNbr ~=== 1 then { + EditScrollToLine(e,lineNbr) + } + DoEvents(w,EditEvent,e) + close(w) + return e.exitCtxList +end + + +procedure EditFnTail(fn) + local i + every i := find("/",fn) + return fn[\i + 1:0] | fn +end + + +procedure EditEvent(w,evt,e,interval,x,y) + EditClearMsgPos(e) + if \e.boxShowing then { + e.boxShowing := &null + EditPaintLines(e) + } + case type(evt) of { + "integer": EditMouseEvent(w,evt,e,interval,x,y) + "string": EditKeyEvent(w,evt,e,interval) + } + return +end + + +procedure EditClearMsgPos(e) + e.msgX := e.msgY := &null + return +end + + +procedure EditClose(e) + local dw,resp + if EditChanged(e) then { + repeat { + dw := EditCreateMsgBox(e,"Close") + write(dw,"Save \"",e.buf.saveFileName,"\" before closing_ + \n(save, don't save, cancel)?\n") + resp := EditGetOneKey(dw) + close(dw) + EditFlushEvents(e.w) + case map(resp[1]) of { + "s": {EditSave(e) & break} + "d": break + "c": fail + } + } + } + delete(e.bufferTable,e.buf.saveFileName) + pop(e.bufferList) + EditOpen(e,e.bufferList[1] | &null) + return +end + + +procedure EditForgetUndos(e) + local dw,resp,buf + buf := e.buf + repeat { + dw := EditCreateMsgBox(e,"Forget Undos & Redos") + write(dw,"Forget undos and redos for \"",buf.saveFileName,"\"_ + \n(ok, cancel)?\n") + resp := EditGetOneKey(dw) + close(dw) + EditFlushEvents(e.w) + case map(resp[1]) of { + "o": break + "c": fail + } + } + buf.undoList := [] + buf.redoList := [] + return +end + + +procedure EditQuit(e,noCtx) + if /noCtx then e.exitCtxList := EditBufCtxList(e) + every 1 to *e.bufferTable do { + if EditEscapePressed(e) then return + EditClose(e) | return + WAttrib(e.w,"pointer=top left arrow") + } + ControlExit := 1 + return +end + + +procedure EditSaveEvery(e) + local buf,currentBuf,resp,dw + currentBuf := e.buf + every buf := !copy(e.bufferList) do { + EditOpen(e,buf) + if EditChanged(e) then { + repeat { + dw := EditCreateMsgBox(e,"Save Every") + write(dw,"Save \"",buf.saveFileName,"\"_ + \n(save, don't save, cancel)?\n") + resp := EditGetOneKey(dw) + close(dw) + EditFlushEvents(e.w) + case map(resp[1]) of { + "s": { + EditSave(e) & + WAttrib(e.w,"pointer=top left arrow") & break + } + "d": break + "c": fail + } + } + } + } + EditOpen(e,currentBuf) + return +end + + +procedure EditRecentBuffer(e,n) + /n := 2 + return EditOpen(e,e.bufferList[n]) +end + + +procedure EditOpen(e,fn,readOnly) + local text,buf,loadRec,ctx,dw,resp,x + /fn := SpecialFn + if not string(fn) then { + # + # A buffer was passed -- bring it to the front. + # + if buf === e.buf then return + buf := fn + fn := buf.saveFileName + text := buf.text + EditMoveBufToFront(e,buf) + } + else { + fn := varsub(fn) + if \e.useCtx then { + ctx := EditParseCtx(fn) + fn := ctx.fileName + } + else ctx := EditCtxRec(fn) + if /buf := \e.bufferTable[fn] then { + # + # There is already a buffer by this name -- bring it to the + # front. + # + if buf === e.buf then return + text := buf.text + EditMoveBufToFront(e,buf) + } + else { + # + # Create a new buffer. + # + EditSetWatch(e) + if fn == SpecialFn then { + # + # The special scratch buffer name was specified -- + # create a buffer with no text. + # + text := [] + buf := EditNewBuffer(e,fn,text) + readOnly := 1 + } + else if loadRec := e.loadFileProc(fn) then { + # + # There is a file by the specified name -- set up a + # buffer with its text. + # + fn := loadRec.fileName + text := loadRec.text + buf := EditNewBuffer(e,fn,text) + buf.version := buf.saveVersion := 1 + if \loadRec.changed then buf.version +:= 1 + } + else { + # + # There is no file by the specified name -- create an + # empty buffer. + # + if /readOnly then { + repeat { + dw := EditCreateMsgBox(e,"File Not Found") + write(dw,image(fn)," if saved,\nwill create a new file._ + \n(ok, cancel)?\n") + resp := EditGetOneKey(dw) + close(dw) + EditFlushEvents(e.w) + case map(resp[1]) of { + "o" | "\r": break + "c": fail + } + } + if match("*",fn) then readOnly := 1 + } + text := [] + buf := EditNewBuffer(e,fn,text) + } + buf.selection := \ctx.selection + buf.scrollValue := \ctx.scrollValue + every x := !\ctx.markList do { + buf.markTable[x[1]] := x[2] + } + buf.readOnly := readOnly + } + } + (\e.buf).scrollValue := e.scroller.value + e.buf := buf + e.text := text + e.selection := buf.selection + e.scroller.maxValue := *text + WAttrib(e.w,"windowlabel=" || e.wname || " -- " || buf.saveFileName) + WAttrib(e.w,"iconlabel=" || e.wd) + EditSetScroll(e,buf.scrollValue) + EditPaintLines(e) + return +end + + +procedure EditMoveBufToFront(e,buf) + local bufl,i + bufl := e.bufferList + every i := 1 to *bufl do { + if bufl[i] === buf then break + } + e.bufferList := [buf] ||| bufl[1:i] ||| bufl[i + 1:0] + return +end + + +procedure EditPrevBuffer(e) + local bufl + bufl := e.bufferList + put(bufl,get(bufl)) + EditOpen(e,bufl[1]) + return +end + + +procedure EditNextBuffer(e) + local bufl + bufl := e.bufferList + push(bufl,pull(bufl)) + EditOpen(e,bufl[1]) + return +end + + +procedure EditNewBuffer(e,fn,text) + local buf + buf := EditBuffer(text) + e.bufferTable[fn] := buf + push(e.bufferList,buf) + buf.selection := EditSelection(1,1,1,1) + buf.saveFileName := fn + buf.autoIndent := e.autoIndent + buf.image := e.image + buf.undoList := [] + buf.redoList := [] + buf.markTable := table() + buf.initialSize := *text + buf.version := buf.saveVersion := 0 + buf.scrollValue := 0 + return buf +end + + +procedure EditSaveCmd(e) + if not EditChanged(e) then + EditErrorMessage(e,"File not changed") + else if \e.buf.readOnly then + EditErrorMessage(e,"File is read-only, so can't be saved") + else EditSave(e) + return +end + + +procedure EditCut(e) + if EditCopy(e) then { + EditNoteState(e) + EditReplace(e) + EditRefreshScreen(e) + } + return +end + + +procedure EditNoteState(e) + e.oldTextLen := *e.text + e.oldSel := copy(e.selection) + return +end + + +procedure EditRefreshScreen(e) + local start + start := Min(e.oldSel.r1,e.selection.r1) + if *e.text = e.oldTextLen then { + EditPaintLines(e,EditScreenLine(e,start), + EditScreenLine(e,Max(e.selection.r2,e.oldSel.r2))) + } + else { + EditPaintLines(e,EditScreenLine(e,start)) + } + return +end + + +procedure Min(i1,i2[]) + every i1 >:= !i2 + return i1 +end + + +procedure Max(i1,i2[]) + every i1 <:= !i2 + return i1 +end + + +procedure EditPaste(e) + local f,fn,t + EditNoteState(e) + fn := e.tempDir || EditClipboard + t := [] + if f := open(fn) then { + every put(t,!f) + close(f) + } + EditReplace(e,t) + EditRefreshScreen(e) + return +end + + +procedure EditUndo(e) + local r,sel,sel2 + e.undoStatus := "undoing" + ##EditPrintUndo(e) + EditNoteState(e) + if r := pop(e.buf.undoList) then { + sel := e.selection + sel2 := r.selection + sel.r1 := sel2.r1 + sel.c1 := sel2.c1 + sel.r2 := sel2.r2 + sel.c2 := sel2.c2 + r.proc!(\r.args | [e]) + sel2 := r.oldSel + sel.r1 := sel2.r1 + sel.c1 := sel2.c1 + sel.r2 := sel2.r2 + sel.c2 := sel2.c2 + e.buf.version := r.version + } + else EditBeep(e) + e.undoStatus := &null + EditRefreshAndScroll(e) + return +end + + +procedure EditRedo(e) + local r,sel,sel2 + e.undoStatus := "redoing" + ##EditPrintUndo(e) + EditNoteState(e) + if r := pop(e.buf.redoList) then { + sel := e.selection + sel2 := r.selection + sel.r1 := sel2.r1 + sel.c1 := sel2.c1 + sel.r2 := sel2.r2 + sel.c2 := sel2.c2 + r.proc!(\r.args | [e]) + } + else EditBeep(e) + e.undoStatus := &null + EditRefreshAndScroll(e) + return +end + + +procedure EditSelectAll(e) + local oldSel,sel + sel := e.selection + oldSel := copy(sel) + sel.r1 := sel.c1 := sel.c2 := 1 + sel.r2 := *e.text + 1 + EditHighlightSelection(e,oldSel) + return +end + + +procedure EditToggleImage(e) + e.buf.image := (\e.buf.image,&null) | 1 + EditPaintLines(e) + return +end + + +procedure EditToggleAutoIndent(e) + e.buf.autoIndent := (\e.buf.autoIndent,&null) | 1 + return +end + + +procedure EditRunFilter(e) + local cmd,f,fn,oldSel,t + if not &features == "pipes" then fail + EditSetWatch(e) + oldSel := copy(e.selection) + EditSelectWholeLines(e) + EditHighlightSelection(e,oldSel) + if cmd := EditGetTextDialog(e,"Filter", + "Enter filter command:\n(enter . for last: ",image(e.lastFilter), + ")\n") then { + if cmd == "." then cmd := e.lastFilter + e.lastFilter := cmd + fn := EditMakeTmp(e) + if f := open(fn,"w") then { + every write(f,EditSelectionLines(e,,1)) + close(f) + f := open(cmd || " < " || fn,"pr") + t := [] + while put(t,read(f)) + close(f) + remove(fn) + put(t,"") + EditNoteState(e) + EditReplace(e,t) + EditRefreshScreen(e) + } + else EditErrorMessage(e,"Can't create work file \"",fn,"\"") + } + return +end + + +procedure EditMakeTmp(e) + return e.tempDir || "xe" || &clock[1+:2] || &clock[4+:2] || &clock[7+:2] +end + +procedure EditShellCommand(e) + local cmd,f,t,s,tsep + static sep + initial sep := case System of {"UNIX": "\n" ; "OS2": "&"} + if \System then { + EditSetWatch(e) + if EditIsEmptySelection(e) then { + EditNoteState(e) + EditSelectWholeLines(e) + EditRefreshScreen(e) + } + cmd := "" + t := [] + tsep := "" + every s := EditSelectionLines(e,,1) do { + cmd ||:= tsep || s + tsep := sep + put(t,s) + } + # f := open("(" || cmd || ") 2>&1","rp") + f := open("sh 2>&1 -c " || shquote(cmd),"rp") + every put(t,!f) + close(f) + put(t,"") + EditNoteState(e) + EditReplace(e,t) + EditRefreshAndScroll(e) + return + } +end + + +procedure EditInsertBuffers(e) + local cmd,f,t,s + t := EditBufNameList(e) + put(t,"") + EditNoteState(e) + EditReplace(e,t) + EditRefreshAndScroll(e) + return +end + + +procedure EditBufNameList(e) + local t + t := [] + every put(t,(!sort(e.bufferTable))[1]) + return t +end + + +procedure EditBufCtxList(e) + local t,buf,marks,x,mark + e.buf.scrollValue := e.scroller.value # update buffer's scroll position + t := [] + every buf := !e.bufferList do { + if buf.saveVersion > 0 then { + marks := "" + every x := !sort(buf.markTable) do { + mark := x[1] + if match(!"*~",mark) then next + while mark[upto(',}',mark)] := "_" + marks ||:= "," || mark || "," || EditOutputSelection(x[2]) + } + put(t,buf.saveFileName || "{" || buf.selection.r1 || + "," || buf.selection.c1 || "," || buf.selection.r2 || "," || + buf.selection.c2 || "," || buf.scrollValue || marks || "}") + } + } + return t +end + + +procedure EditOutputSelection(sel) + return sel.r1 || "," || sel.c1 || "," || sel.r2 || "," || sel.c2 +end + + +procedure EditInputSelection() + return EditSelection( + integer(tab(find(","))), + (move(1),integer(tab(find(",")))), + (move(1),integer(tab(find(",")))), + (move(1),integer(tab(many(&digits))))) +end + + +record EditCtxRec(fileName,selection,scrollValue,markList) + +procedure EditParseCtx(fn) + local ctx,sel,scrollValue,markList + fn ? { + if fn := tab(find("{")) & move(1) & ctx := tab(find("}")) & + pos(-1) then { + ctx ? { + sel := EditInputSelection() + scrollValue := (move(1),integer(tab(find(",") | 0))) + markList := [] + until pos(0) do { + move(1) + put(markList,[tab(find(",")),(move(1),EditInputSelection())]) + } + } + } + else { + fn := tab(0) + } + } + return EditCtxRec(fn,sel,scrollValue,markList) +end + + +procedure EditFindFileAndLine(e) + local line,fn,lineNbr,lineNbr2,column + EditSetWatch(e) + if EditIsEmptySelection(e) then EditSelectWholeLines(e) + line := EditSelectionLines(e) + # + # Parse the file:line specification. + # + line ? { + if ="File " then { + # + # Parse Icon (i.e. MPW) spec. + # + fn := tab(find("; Line ")) + move(7) + lineNbr := integer(tab(many(&digits))) + } + else { + # + # Determine whether UNIX or Cset/2 format. + # + tab(upto('(:')) + case move(1) of { + ":": { + # + # UNIX + # + tab(1) + tab(many(' \t')) + fn := trim(tab(find(":") | 0),' \t') + move(1) + =" Line" # concession to some Icon messages + tab(many(' \t')) + lineNbr := integer(tab(many(&digits))) + if ="," then { + lineNbr2 := integer(tab(many(&digits))) + } + } + "(": { + # + # Cset/2 + # + tab(1) + fn := tab(find("(")) + move(1) + lineNbr := integer(tab(upto(':)'))) + =":" + column := integer(tab(find(")"))) + } + } + } + } + if EditOpen(e,fn) then { + EditScrollToLine(e,\lineNbr,"wholeLine") & + EditGoToCol(e,\column) | &null & + if \lineNbr2 then { + EditNoteState(e) + e.selection.r2 := lineNbr2 + 1 + EditRefreshScreen(e) + } + else {} + } + return +end + + +procedure EditGetTextDialog(e,title,s[]) + local cmd,dw + dw := EditCreateMsgBox(e,title) + every writes(dw,!s) + write(dw) + cmd := read(dw) | fail + close(dw) + return "" ~== cmd +end + + +procedure EditErrorMessage(e,s[]) + return EditMessage!([e,"Oops!"] ||| s) +end + + +procedure EditMessage(e,title,s[]) + local dw + dw := EditCreateMsgBox(e,title) + every writes(dw,!s) + write(dw) + EditWaitForAnyEvent(dw) + close(dw) + return +end + + +procedure EditShiftLeft(e) + EditNoteState(e) + EditShiftLines(e,1) + EditRefreshScreen(e) + return +end + + +procedure EditShiftRight(e) + EditNoteState(e) + EditShiftLines(e,-1) + EditRefreshScreen(e) + return +end + + +procedure EditCursorLeft(e) + local oldSel,sel + sel := e.selection + oldSel := copy(sel) + EditNoteState(e) + if (sel.c1 -:= 1) < 1 then { + sel.c1 := if (sel.r1 -:= 1) < 1 then 1 else *e.text[sel.r1] + 1 + } + sel.r2 := sel.r1 ; sel.c2 := sel.c1 + EditValidateSelection(e) + EditRefreshAndScroll(e) + return +end + + +procedure EditCursorRight(e) + local oldSel,sel + sel := e.selection + oldSel := copy(sel) + EditNoteState(e) + if (sel.c2 +:= 1) > (*e.text[sel.r2] + 1 | 1)\1 then { + sel.r2 +:= 1 + sel.c2 := 1 + } + sel.r1 := sel.r2 ; sel.c1 := sel.c2 + EditValidateSelection(e) + EditRefreshAndScroll(e) + return +end + + +procedure EditCursorUp(e) + local oldSel,sel + sel := e.selection + oldSel := copy(sel) + if not (e.lastKey == ("\^J" | "\^K")) then e.lastData := + EditGetScreenOffset(e,e.text[sel.r1],sel.c1) + EditNoteState(e) + sel.r2 := sel.r1 -:= 1 + sel.c1 := sel.c2 := EditGetStringOffset(e,e.text[sel.r1],e.lastData) + EditValidateSelection(e) + EditRefreshAndScroll(e) + return +end + + +procedure EditCursorDown(e) + local oldSel,sel + sel := e.selection + oldSel := copy(sel) + if not (e.lastKey == ("\^J" | "\^K")) then e.lastData := + EditGetScreenOffset(e,e.text[sel.r1],sel.c1) + EditNoteState(e) + sel.r2 := sel.r1 +:= 1 + sel.c1 := sel.c2 := EditGetStringOffset(e,e.text[sel.r1],e.lastData) + EditValidateSelection(e) + EditRefreshAndScroll(e) + return +end + + +procedure EditFindCmd(e) + (e.findString := EditGetTextDialog(e,"Find", + "Find what string or /regular expression/?\n (Current: ", + image(e.findString),")\n")) | return + EditFind(e,e.findString) + return +end + + +procedure EditFindAgainCmd(e) + EditFind(e,e.findString) + return +end + + +procedure EditSelectionToFind(e) + e.findString := EditSelectionLines(e) + return +end + + +procedure EditDisplaySelection(e) + if EditIsEmptySelection(e) then EditCursorBox(e) + else { + if EditScrollToSelectionIfOffScreen(e) then + EditPaintLines(e) + } + return +end + + +procedure EditOpenSelectedFile(e) + local sel,fn + EditNoteState(e) + if EditIsEmptySelection(e) then { + sel := EditSortSelection(e.selection) + if not any(NonSpace,e.text[sel.r1],sel.c1) then { + if sel.c1 > 1 then {sel.c1 -:= 1 ; sel.c2 -:= 1} + } + EditSelectNonspaces(e) + EditRefreshScreen(e) + } + fn := EditSelectionLines(e) + if any(NonSpace,fn) then EditOpen(e,fn) + return +end + + +procedure EditReplaceCmd(e) + local dw + dw := EditCreateMsgBox(e,"Replace") + write(dw,"Replace what string or /regular expression/?\n (Current: ", + image(e.findString),")\n") + e.findString := "" ~== read(dw) + write(dw,"\nwith what string?\n (Current: ",image(e.replaceString),")\n") + (e.replaceString := "" ~== read(dw)) | {close(dw) ; return} + close(dw) + EditFind(e,e.findString,e.replaceString) + return +end + + +procedure EditReplaceAgainCmd(e) + EditFind(e,e.findString,e.replaceString) + return +end + + +procedure EditToggleBackward(e) + return e.backward := (\e.backward,&null) | 1 + return +end + + +procedure EditToggleWrap(e) + return e.wrap := (\e.wrap,&null) | 1 +end + + +procedure EditToggleCase(e) + return e.ignoreCase := (\e.ignoreCase,&null) | 1 +end + + +procedure EditTextFromFileCmd(e) + local f,fn,t + if fn := EditGetTextDialog(e,"Enter Text from File", + "Enter text from what file?\n") then { + fn := varsub(fn) + if f := open(fn) then { + t := [] + while put(t,read(f)) + close(f) + EditNoteState(e) + EditReplace(e,t) + EditRefreshScreen(e) + } + else EditErrorMessage(e,"Can't find file named \"",fn,"\"") + } + return +end + + +procedure EditToggleTrace() + return &trace := if &trace = 0 then -1 else 0 +end + + +procedure EditDeleteCmd(e) + EditNoteState(e) + EditDelete(e) + EditRefreshAndScroll(e) + return +end + + +procedure EditGoToLineCmd(e) + local resp,line,col + static digits + initial digits := &digits ++ "-" + if resp := EditGetTextDialog(e,"Go To Line", + "Enter line number [column number]:\n") then { + resp ? { + line := tab(many(digits)) + tab(upto(digits)) & + col := tab(many(digits)) + } + if line := integer(line) then EditScrollToLine(e,line,"wholeLine") + if col := integer(col) then EditGoToCol(e,col) + } + return +end + + +procedure EditGoToCol(e,col) + local line,sel + sel := EditSortSelection(e.selection) + line := e.text[sel.r1] + if col <= 0 then col := *line + 1 + col + if not (0 < col <= *line + 1) then {EditBeep(e) ; return} + EditNoteState(e) + sel.c1 := col + sel.c2 := col + 1 + sel.r2 := sel.r1 + EditValidateSelection(e) + EditRefreshScreen(e) + return +end + + +procedure EditScrollToLine(e,line,wholeLine) + EditNoteState(e) + EditGoToLine(e,line,wholeLine) | {EditBeep(e) ; fail} + EditRefreshAndScroll(e) + return +end + + +procedure EditCwd() + local p,cwd + static pwd + initial pwd := case System of {"UNIX": "pwd" ; "OS2": "cd"} + if p := open(\pwd,"rp") then { + cwd := read(p) + close(p) + return cwd + } +end + + +procedure EditMemoryStats(e) + local dw,lst + dw := EditCreateMsgBox(e,"Memory Stats",64,25) + write(dw,"\n Memory Allocation Statistics") + write(dw,"\n Current region sizes") + lst := [] ; every put(lst, ®ions) + write(dw," static: ",lst[1], + "\n string: ",lst[2], + "\n block: ",lst[3]) + write(dw,"\n Current bytes allocated") + lst := [] ; every put(lst, &storage) + write(dw," static: ",lst[1], + "\n string: ",lst[2], + "\n block: ",lst[3]) + write(dw,"\n Accumulated bytes allocated") + lst := [] ; every put(lst, &allocated) + write(dw," total: ",lst[1], + "\n static: ",lst[2], + "\n string: ",lst[3], + "\n block: ",lst[4]) + write(dw,"\n Collections") + lst := [] ; every put(lst, &collections) + write(dw," total: ",lst[1], + "\n static: ",lst[2], + "\n string: ",lst[3], + "\n block: ",lst[4]) + EditWaitForAnyEvent(dw) + close(dw) + return +end + +procedure EditInfoCmd(e) + local dw,sel,t,buf,cwd + sel := e.selection + buf := e.buf + cwd := EditCwd() + dw := EditCreateMsgBox(e,"Info",Max(64,*buf.saveFileName + 10, + *\cwd + 24 | 0),24) + write(dw,"\n Mouse-Oriented Editor for Windows") + write(dw," written in Icon by Bob Alexander\n") + write(dw," File: ", + "\"" || ("" ~== \buf.saveFileName) || "\"" | "** none **") + write(dw," ",if EditChanged(e) then "Modified" else "Not modified", + " since save") + write(dw," Lines: ",*e.text) + t := 0 + every t +:= *!e.text + 1 + write(dw," Chars: ",t) + t := 0 = *e.text | sel.r2 - sel.r1 + 1 + writes(dw," The Selection: line ",sel.r1,", column ",sel.c1) + if sel.r2 ~= sel.r1 then writes(dw," to line ",sel.r2,", column ",sel.c2) + else if sel.c2 ~= sel.c1 then writes(dw," to column ",sel.c2) + write(dw) + write(dw," Lines selected: ",abs(sel.r2 - sel.r1) + 1) + t := 0 + every t +:= *EditSelectionLines(e) + 1 + write(dw," Chars selected: ",t - 1) + write(dw," Current size of Undo/Redo list: ",*buf.undoList, + "/",*buf.redoList) + write(dw," Current directory: \"",\cwd,"\"") + write(dw) + + EditWriteMode(dw,e.wrap,"Wrap Mode for Find") + EditWriteMode(dw,e.ignoreCase,"Case Independence Mode for Find") + EditWriteMode(dw,e.backward,"Find Backward") + EditWriteMode(dw,buf.autoIndent,"Auto Indent") + EditWriteMode(dw,buf.readOnly,"Read Only") + EditWriteMode(dw,buf.image,"Show Unprintables") + write(dw," Tab spacing: ",\Tabs - 1 | "off") + write(dw," Tags table size: ",EditGoToTag(e,,"size")) + EditWriteMode(dw,&trace ~= 0 | &null,"Trace") + EditWaitForAnyEvent(dw) + close(dw) + return +end + + +## procedure EditHelpCmd(e) + ## local dw,help,lines,maxw,line + ## help := EditHelpText() + ## help ? { + ## maxw := lines := 0 + ## while line := tab(find("\n")) do { + ## move(1) + ## lines +:= 1 + ## maxw <:= *line + ## } + ## } + ## dw := EditCreateMsgBox(e,"Help",maxw + 1,lines + 1) + ## writes(dw,help) + ## EditWaitForAnyEvent(dw) + ## close(dw) + ## return +## end + +procedure EditHelpBuffer(e) + local dw,help,lines,maxw,line + EditOpen(e,"*Help*","readOnly") + if *e.text = 0 then { + EditReplace(e,EditHelpText()) + e.buf.saveVersion := e.buf.version + EditPaintLines(e) + } + return +end + + + +procedure EditOpenCmd(e) + local dw,bufSort,resp,fn,n,maxwid + maxwid := 0 + every fn := key(e.bufferTable) do maxwid <:= *fn + maxwid := Max(64,maxwid + 10) + dw := EditCreateMsgBox(e,"Open",maxwid,*e.bufferTable + 8) + bufSort := sort(e.bufferTable) + write(dw,"List of Open Files") + write(dw,"------------------") + n := 0 + every fn := !bufSort do + write(dw,n +:= 1,". ",if EditChanged(e,fn[2]) then "(" || fn[1] || ")" + else fn[1], + if fn[2] === e.buf then " <-" else if fn[2] === e.bufferList[2] + then " *" else "") + write(dw,"\n(Enter a number or a file name)\nOpen which file?\n") + resp := read(dw) + close(dw) + if resp == "" then return + EditOpen(e,bufSort[integer(resp)][1] | resp) + return +end + + +procedure EditDataKeyTyped(e,evt) + local oldSel,r,r1,r2,sel,t,text + static oneChar + initial oneChar := ["x"] + sel := e.selection + text := e.text + if EditIsEmptySelection(e) & evt ~== "\r" then { + # + # This is optimized code for inserting a character into + # an empty selection. + # + oldSel := copy(sel) + r1 := r2 := sel.r1 + if (r1 > *text,put(text,evt),r2 +:= 1) | + (text[r1][sel.c1+:0] := evt) then + sel.c2 := sel.c1 +:= 1 + EditAddUndo(e,EditDelete,,sel,oldSel) + EditAdjustMarks(e,oldSel,oneChar) + EditScrollToSelectionIfOffScreen(e) + EditPaintLines(e,EditScreenLine(e,r1),EditScreenLine(e,r2)) + } + else { + EditSortSelection(sel) + r := sel.r1 + # + # Generalized replacement of selection by typed character. + # + t := evt + EditNoteState(e) + if evt == "\r" & \e.buf.autoIndent then { + detab(text[r],Tabs) ? { + t ||:= entab(tab(many(' \t')),Tabs) + } + sel.c2 := many(' \t',text[sel.r2],sel.c2) + } + EditReplace(e,t,sel) + EditRefreshAndScroll(e) + } + return +end + + +procedure EditKeyEvent(w,evt,e) + static deleteKey,cursorLeftKey,printChars + initial { + deleteKey := "\d" + cursorLeftKey := "\^H" + if System === "OS2" then { + deleteKey := "\^H" # for OS/2 backspace key deletes + cursorLeftKey := "\x10"# and Delete key does cursor-left + } + e.findString := e.replaceString := e.lastKey := "" + printChars := &ascii[33:128] ++ "\r\t" + } + ## write("{{{{ event = ",image(evt)," x = ",&x," y = ",&y," t = ",&time) + if \e.enterControl then { + EditDataKeyTyped(e,evt) + e.enterControl := &null + } + else case evt of { + "\^Q": EditQuit(e) # quit + "\^O": EditOpenCmd(e) # open + "\^W": EditClose(e) # close file + "\^D": EditSaveCopy(e) # write a copy + "\^S": EditSaveCmd(e) # save + "\^E": EditSaveEvery(e) # save modified buffers + "\^C": EditCopy(e) # copy + "\^X": EditCut(e) # cut + "\^V": EditPaste(e) # paste + "\^Z": EditUndo(e) # undo + "\^Y": EditRedo(e) # redo + "\^A": EditSelectAll(e) # select all + deleteKey: + EditDeleteCmd(e) # delete/backspace + "\^@": EditGoToLineCmd(e) # go to line + cursorLeftKey: + EditCursorLeft(e) # cursor left + "\^J": EditCursorDown(e) # cursor down + "\^K": EditCursorUp(e) # cursor up + "\^L": EditCursorRight(e) # cursor right + "\^F": EditFindCmd(e) # find + "\^G": EditFindAgainCmd(e) # find again + "\^U": EditSelectionToFind(e) # set find string to selection + "\^R": EditReplaceCmd(e) # replace + "\^T": EditReplaceAgainCmd(e) # replace again + "\^B": EditToggleBackward(e) # backward mode toggle + "\x1c": EditInfoCmd(e) # info + "\^?" | "\^/": EditHelpBuffer(e) # help + "\e": { # escape key sequence + evt := Event(w) + if type(evt) == "string" then case evt of { + "d": EditDupAtLastClick(e) # duplicate at "*Last Click*" + "`": EditGoToMark(e,"*Last Place*") # go to "*Last Place*" + ",": EditPrevBuffer(e) # previous buffer + ".": EditNextBuffer(e) # next buffer + "1": EditOpen(e) # scratch buffer + "o": EditOpenSelectedFile(e) # open selected file + "B": EditInsertBuffers(e) # insert buffer names + "m": EditCreateMarkCmd(e) # create mark + "j": EditGoToMarkCmd(e) # jump to mark + "t": EditAddTrail(e) # add selection to trail + "T": EditClearTrail(e) # add selection to trail + "9": EditBackTrail(e) # go to last trail loc + "0": EditForeTrail(e) # go to next trail loc + "u": EditToggleImage(e) # "image" toggle + "a": EditToggleAutoIndent(e) # autoindent toggle + "\r": EditShellCommand(e) # do a shell command + "f": EditRunFilter(e) # run program (filter) + "i": EditExecuteIcon(e) # run program (filter) + "s": EditFindFileAndLine(e) # find "file:line" from text + "w": EditToggleWrap(e) # wrap mode toggle + "c": EditToggleCase(e) # case independence toggle + "r": EditTextFromFileCmd(e) # enter text from file + "l": EditDisplaySelection(e) # scroll to selection + "p": EditSelectedTag(e) # go to tag + "P": EditGoToTag(e,,"refresh") # purge tags file + deleteKey: EditDeleteToEnd(e) # delete to end of text + "[": EditShiftLeft(e) # shift 1 left + "]": EditShiftRight(e) # shift 1 right + "v": e.enterControl := 1 # enter a control char + "x": EditReverseText(e) # reverse selected characters + "Q": EditQuit(e,"noCtx") # quit w/o saving context + "&": EditToggleTrace() # &trace + "M": EditMemoryStats(e) # memory allocation stats + "Z": EditForgetUndos(e) # forget undos & redos + "R": EditRuler(e) # insert a ruler + !&digits: EditRecentBuffer(e,evt) # nth most recent buffer + default: EditBeep(e) + } + } + default: if any(printChars,evt) then # data key typed + EditDataKeyTyped(e,evt) + else EditBeep(e) + } + e.lastKey := evt + return +end + + +procedure EditGoToLine(e,line,wholeLine) + local sel + sel := e.selection + if line = 0 then { + EditCreateMark(e) + sel.r1 := sel.r2 := *e.text + 1 + sel.c1 := sel.c2 := 1 + return + } + if line <= 0 then line := *e.text + line + 1 + if 1 <= line <= *e.text then { + EditCreateMark(e) + sel.r1 := sel.r2 := line + sel.c1 := sel.c2 := 1 + if \wholeLine then sel.r2 +:= 1 + return + } + else EditBeep(e) +end + + +procedure EditBeep(e) + if System ~=== "OS2" then writes("\^G") + return +end + + +procedure EditScreenLine(e,line) + return line - e.scroller.value + 1 +end + + +procedure EditScrollToSelectionIfOffScreen(e,linesAtBottom) + /linesAtBottom := 0 + return if not + (1 <= EditScreenLine(e,e.selection.r1) <= e.rows - linesAtBottom) then + EditScrollToSelection(e) +end + + +procedure EditRefreshAndScroll(e,linesAtBottom) + return ( + if EditScrollToSelectionIfOffScreen(e,linesAtBottom) then + EditPaintLines(e) + else + EditRefreshScreen(e) + ) +end + + +procedure EditWriteMode(w,mode,modeString) + return write(w," ",modeString,": ",if \mode then "on" else "off") +end + + +procedure EditWaitForAnyEvent(w) + local evt + # + # Actually, wait for mouse UP or any key. + # + repeat { + if type(evt := Event(w)) == "integer" then { + if evt = (&lrelease|&mrelease|&rrelease) then break + } + else break + } + return evt +end + + +procedure EditGetOneKey(w) + local evt + while type(evt := Event(w)) == "integer" do { + } + return evt +end + + +procedure EditFlushEvents(w) + while Pending(w)[1] do Event(w) + return +end + + +procedure EditSaveCopy(e) + local fn + if fn := EditGetTextDialog(e,"Write a Copy", + "Write a copy to what file?\n") then return EditSave(e,fn,,1) +end + + +procedure EditMouseEvent(w,evt,e,interval,x,y) + local oldSel,sel,text + static lastKey,lastMouseEvent,clickCount,lastMouseX,lastMouseY + initial { + lastKey := "" + clickCount := lastMouseEvent := 0 + } + ## write("{{{{ event = ",image(evt)," x = ",x," y = ",y," t = ",&time) + sel := e.selection + text := e.text + if evt === (&lpress | &mpress | &rpress) then { + # + # Process mouse button presses, checking for double and triple + # clicks. + # + if lastMouseEvent = evt & + interval <= 200 & # double-click interval + lastMouseX - 4 < x < lastMouseX + 4 & # double-click has slop + lastMouseY - 4 < y < lastMouseY + 4 then { # of +/- 4 pixels + 3 >= (clickCount +:= 1) | (clickCount := 1) + } + else { + clickCount := 1 + lastMouseX := x + lastMouseY := y + } + lastMouseEvent := evt + } + oldSel := copy(sel) + case evt of { + &lpress: { # mouse left button pressed + sel.r1 := sel.r2 := &row + e.scroller.value - 1 + sel.c1 := sel.c2 := EditGetStringOffset(e,text[sel.r1],&col) + case clickCount of { + 1: EditCreateMark(e,"*Last Click*",oldSel) + 2: EditSelectWord(e) + 3: EditSelectLine(e) + } + EditValidateSelection(e) + EditHighlightSelection(e,oldSel) + } + &rpress|&mpress|&null: { + if &row < 1 then { + sel.c2 := 1 + EditHighlightSelection(e,oldSel) + oldSel := copy(sel) + until e.scroller.value <= 1 | *Pending(e.w) > 0 do { + sel.r2 := e.scroller.value + EditHighlightSelection(e,oldSel) + oldSel := copy(sel) + EditScroll(e,e.scroller.value - 1,e.scroller.value) + EditSetScroll(e,e.scroller.value - 1) + } + } + else if &row > e.rows then + until e.scroller.value >= *text | *Pending(e.w) > 0 do { + sel.c2 := 1 + sel.r2 := e.scroller.value + e.rows + EditHighlightSelection(e,oldSel) + oldSel := copy(sel) + EditScroll(e,e.scroller.value + 1,e.scroller.value) + EditSetScroll(e,e.scroller.value + 1) + } + else { + sel.r2 := &row + e.scroller.value - 1 + sel.c2 := EditGetStringOffset(e,text[sel.r2], &col) + case clickCount of { + 2: EditSelectWord(e) + 3: EditSelectLine(e) + } + EditValidateSelection(e) + if not EditEqualSel(sel,oldSel) then + EditHighlightSelection(e,oldSel) + } + } + &ldrag|&mdrag|&rdrag: { + if not Pending(w)[1] then EditMouseEvent(w,&null,e,interval,x,y) + } + ## &lrelease|&mrelease|&rrelease: + &resize: EditResizeWindow(e) + } + return +end + + + +procedure EditResizeWindow(e) + local height,oldScroller,w,width + w := e.w + width := WAttrib(w,"width") + height := WAttrib(w,"height") + e.columns := WAttrib(w,"columns") + e.rows := WAttrib(w,"lines") + oldScroller := RemoveScroller(e.scroller) + e.scroller := + NewScroller(w,width - scrollWidth,-1,scrollWidth,height + 1, + EditScrolled,e,oldScroller.value,1 <= *e.text | 1,1,e.rows - 2) + EraseArea(w) + DrawScroller(e.scroller) + EditPaintLines(e) + return e +end + + +procedure EditEqualSel(sel1,sel2) + return sel1.r1 = sel2.r1 & + sel1.c1 = sel2.c1 & + sel1.r2 = sel2.r2 & + sel1.c2 = sel2.c2 +end + + +procedure EditShiftLines(e,n) + local h,i,line,oldSel,p,sel,text + sel := e.selection + oldSel := copy(sel) + text := e.text + EditSelectWholeLines(e) + EditAddUndo(e,EditReplace,sel,sel,oldSel) + every i := sel.r1 to sel.r2 - 1do { + line := text[i] + if p := many(' \t',line) then h := detab(line[1:p],Tabs) + else {p := 1 ; h := ""} + if n > 0 then { + (h[-n:0] := "") | (h := "") + } + else { + h ||:= repl(" ",-n) + } + text[i] := entab(h,Tabs) || line[p:0] + } + return +end + + +procedure EditSelectWholeLines(e,sel) + /sel := e.selection + EditSortSelection(sel) + if sel.c2 ~= 1 | sel.r1 = sel.r2 then sel.r2 +:= 1 + sel.c1 := sel.c2 := 1 + return sel +end + + +procedure EditCreateMsgBox(e,title,width,height) + local dw,x,y,w,b + w := e.w + /title := "?" + /width := 60 + /height := 10 + /e.msgX := 0 <= (WAttrib(w,"posx") + WAttrib(w,"pointerx") - 92) | 0 & + e.msgY := 0 <= (WAttrib(w,"posy") + WAttrib(w,"pointery") - 72) | 0 + x := e.msgX + y := e.msgY + b := XBind("font=fixed") + width *:= WAttrib(b,"fwidth") + height *:= WAttrib(b,"fheight") + dw := open(title,"x","geometry=" || width || "x" || height || + "+" || x || "+" || y) + return dw +end + + +procedure EditFind(e,s,replace,direction) + local backward,c,findMap,findProc,matchProc,r,sel,sel2,text,lookHere + EditSetWatch(e) + findMap := if \e.ignoreCase then map else 1 + sel := e.selection + EditSortSelection(sel) + sel2 := copy(sel) + text := e.text + backward := e.backward + backward := case direction of { + "forward": &null + "backward": 1 + default: e.backward + } + findProc := find + matchProc := match + lookHere := \replace ~== s + if *s > 2 then { + if s[1] == "/" & s[-1] == "/" then { + Re_Filter := findMap + s := RePat(s[2:-1]) | {EditBeep(e) ; return} + findProc := ReFind + matchProc := ReMatch + } + } + s := findMap(string(s)) + EditNoteState(e) + if \backward then { + # + # Search backward. + # + (\lookHere, + c := (matchProc(s,findMap(text[r := sel2.r1]),sel2.c1),sel2.c1)) | + every c := findProc(s,findMap(text[r := sel2.r1]),,sel2.c1) + if \c | + (every r := (sel2.r1 - 1 to 1 by -1) | + (if \e.wrap then *text to sel2.r1 by -1) do { + if EditEscapePressed(e) then break &fail + every c := findProc(s,findMap(text[r])) + if \c then break + }) then { + sel.r1 := sel.r2 := r + sel.c1 := c + sel.c2 := matchProc(s,findMap(text[r]),c) + ## writes((/replace,"Found ") | "Replaced ",image(s)," at ") + ## EditPrintSelection(e) + if EditReplace(e,\replace) then { + ## writes("with ",image(replace)," -- new ") + ## EditPrintSelection(e) + } + EditRefreshAndScroll(e) + } + else { + ## write("\^GCan't find ",image(s)) + EditBeep(e) + } + } + else { + # + # Search forward. + # + if (\lookHere, + c := (matchProc(s,findMap(text[r := sel2.r1]),sel2.c1),sel2.c1)) | + (c := findProc(s,findMap(text[r := sel2.r2]),sel2.c2)) | + (every r := (sel2.r2 + 1 to *text) | + (if \e.wrap then 1 to sel2.r2) do { + if EditEscapePressed(e) then break &fail + if c := findProc(s,findMap(text[r])) then break + }) then { + sel.r1 := sel.r2 := r + sel.c1 := c + sel.c2 := matchProc(s,findMap(text[r]),c) + ## writes((/replace,"Found ") | "Replaced ",image(s)," at ") + ## EditPrintSelection(e) + if EditReplace(e,\replace) then { + ## writes("with ",image(replace)," -- new ") + ## EditPrintSelection(e) + } + EditRefreshAndScroll(e,4) + } + else { + ## write("\^GCan't find ",image(s)) + EditBeep(e) + } + } + EditCreateMark(e,,sel2) + return +end + + +procedure EditScrollToSelection(e) + local r1,r2,rows,sel,selRows + sel := e.selection + rows := e.rows + r1 := sel.r1 + r2 := sel.r2 + if r2 > r1 then r1 :=: r2 + selRows := r2 - r1 + 1 + EditSetScroll(e,if selRows >= rows then r1 else r1 - (rows - selRows) / 2) + return +end + + +procedure EditSelectWord(e) + local b,c,i,line,sel,text + static bracketChars,startBrackets,endBrackets + initial { + bracketChars := '()[]{}<>"\'' + startBrackets := "([{<\"'" + endBrackets := ")]}>\"'" + } + sel := e.selection + if line := e.text[sel.r2] then { + if EditIsEmptySelection(e) then { + if any(bracketChars,c := line[sel.c1]) then { + # + # Double click on a bracket-type character selects chars + # between the brackets. + # + text := e.text + if find(c,startBrackets) then { + sel.c1 +:= 1 + b := map(c,startBrackets,endBrackets) + if i := bal(b,c,b,EditTextAsNeeded(e,line,sel.r1 + 1,*text), + sel.c1) then { + sel.r2 := sel.r1 + EditTextAsNeededLines + sel.c2 := i - EditTextAsNeededLength + } + } + else { + b := map(c,endBrackets,startBrackets) + if i := bal(b,c,b,EditTextAsNeeded(e,line,sel.r1 - 1,1,-1, + reverse),*line - sel.c1 + 2) then { + sel.r2 := sel.r1 - EditTextAsNeededLines + sel.c2 := *text[sel.r2] - (i - EditTextAsNeededLength) + 2 + } + } + } + else { + # + # Select a word -- current selection empty. + # + if sel.c2 := many(WordSet,line,sel.c1) then { + sel.c1 +:= 1 + while any(WordSet,line,0 < (sel.c1 -:= 1)) + sel.c1 +:= 1 + } + else { + sel.c2 +:= 1 + EditValidateSelection(e) + } + } + } + # + # Handle extend-select. + # + else if sel.r1 < sel.r2 | (sel.r1 = sel.r2 & sel.c1 < sel.c2) then { + # + # Extend forward. + # + sel.c2 := many(WordSet,line,sel.c2) | sel.c2 + } + else { + # + # Extend backward. + # + while any(WordSet,line,0 < (sel.c2 -:= 1)) + sel.c2 +:= 1 + } + } + return +end + + +procedure EditSelectNonspaces(e) + local line,sel + sel := e.selection + if line := e.text[sel.r2] then { + if EditIsEmptySelection(e) then { + # + # Select a word -- current selection empty. + # + if sel.c2 := many(NonSpace,line,sel.c1) then { + sel.c1 +:= 1 + while any(NonSpace,line,0 < (sel.c1 -:= 1)) + sel.c1 +:= 1 + } + else { + sel.c2 +:= 1 + EditValidateSelection(e) + } + } + # + # Handle extend-select. + # + else if sel.r1 < sel.r2 | (sel.r1 = sel.r2 & sel.c1 < sel.c2) then { + # + # Extend forward. + # + sel.c2 := many(NonSpace,line,sel.c2) | sel.c2 + } + else { + # + # Extend backward. + # + while any(NonSpace,line,0 < (sel.c2 -:= 1)) + sel.c2 +:= 1 + } + } + return +end + + +procedure EditTextAsNeeded(e,line,rfrom,rto,rby,prc) + /rby := 1 + /prc := 1 + EditTextAsNeededLength := 0 + EditTextAsNeededLines := 0 + suspend line := prc(line) + EditTextAsNeededLength := *line + EditTextAsNeededLines := 1 + suspend line ||:= prc(e.text[rfrom to rto by rby]) do { + if *line > 2000 then EditSetWatch(e) + if EditEscapePressed(e) then fail + EditTextAsNeededLength := *line + EditTextAsNeededLines +:= 1 + } +end + + +procedure EditEscapePressed(e) + if *Pending(e.w) > 0 then { + if Event(e.w) === "\e" then return + } +end + + +procedure EditSetWatch(e) + return WAttrib(e.w,"pointer=watch") +end + + +procedure EditSelectLine(e) + local line,sel + sel := e.selection + line := e.text[sel.r2] + if EditIsEmptySelection(e) then { + # + # Select whole line if current selection empty. + # + sel.c2 := sel.c1 := 1 + sel.r2 +:= 1 + } + else if sel.r1 < sel.r2 | (sel.r1 = sel.r2 & sel.c1 < sel.c2) then { + # + # Extend forward. + # + sel.c2 := 1 + sel.r2 +:= 1 + } + else { + # + # Extend backward. + # + sel.c2 := 1 + } + EditValidateSelection(e) + return +end + + +procedure EditValidateSelection(e,sel) + /sel := e.selection + (sel.r1 <:= 1) | + (if sel.r1 > *e.text then { + sel.r1 := *e.text + 1 + sel.c1 := 1 + }) + (sel.r2 <:= 1) | + (if sel.r2 > *e.text then { + sel.r2 := *e.text + 1 + sel.c2 := 1 + }) + (sel.c1 <:= 1) | + (sel.c1 >:= ((*e.text[sel.r1] + 1) | 1)\1) + (sel.c2 <:= 1) | + (sel.c2 >:= ((*e.text[sel.r2] + 1) | 1)\1) + ##EditPrintSelection(e,"EditValidateSelection returned",sel) + return +end + + +procedure EditSave(e,fn,sel,saveCopy) + local bakfn,buf,dw,resp,i + EditSetWatch(e) + buf := e.buf + (/fn := buf.saveFileName) | (fn := varsub(fn)) + if /fn | fn == "" | match("*",fn) | + \buf.readOnly then return EditSaveCopy(e) + if /saveCopy & buf.initialSize > 0 then { + if System == "OS2" then { + # + # Create a backup file name by substituting a ".bak" suffix. + # + i := 0 + every i := find(".",fn) + bakfn := fn[1:i] || ".bak" + } + else { + # + # Create a backup file name by appending "~". + # + bakfn := fn || "~" + } + EditBackupFile(e,fn,bakfn) | { + EditErrorMessage(e,"Unable to create backup file \"",bakfn,"\"") + fail + } + } + e.buf.initialSize := *e.text + # + # Check if he's trying to write over a directory. + # + if System == "UNIX" & system("test -d " || fn) = 0 then { + EditErrorMessage(e,image(fn)," is a directory") + fail + } + # + # Check if he's overwriting a file. + # + if System == "UNIX" & \saveCopy & system("test -f " || fn) = 0 then { + dw := EditCreateMsgBox(e,"Save") + write(dw,"Replace existing \"",fn,"\"?_ + \n(replace, don't replace)?\n") + resp := EditGetOneKey(dw) + close(dw) + EditFlushEvents(e.w) + case map(resp[1]) of { + "r" | "\r": {} + "d": fail + } + } + EditWriteToFile(e,fn,sel,"edit") | fail + if \e.rmBackup then remove(\bakfn) + return +end + + +procedure EditWriteToFile(e,fn,sel,tag) + local f,line + if f := open(fn,"w") then { + &error := 1 + every line := (if \sel then EditSelectionLines(e,sel,1) else !e.text) do { + write(f,line) | { + EditErrorMessage(e,"Error writing file: ",&errortext," (", + image(&errorvalue),")") + close(f) + fail + } + } + &error := 0 + close(f) + e.buf.saveVersion := e.buf.version + return + } + else EditErrorMessage(e,"Unable to write to ",tag," file \"",fn,"\"") +end + + +procedure EditBackupFile(e,fn1,fn2) + local f1,f2,buf + f1 := open(fn1,"r") | return &null + f2 := open(fn2,"w") | fail + &error := 1 + while buf := read(f1) do { + write(f2,buf) | { + EditErrorMessage(e,"Error copying file: ",&errortext," (", + image(&errorvalue),")") + every close(f1 | f2) + fail + } + } + &error := 0 + every close(f2 | f1) + return fn2 +end + + +procedure EditSelectionLines(e,sel,x) + local text + /sel := e.selection + sel := EditSortSelection(sel) + text := e.text + if sel.r1 = sel.r2 then suspend text[sel.r1][sel.c1:sel.c2] + else { + suspend text[sel.r1][sel.c1:0] + every suspend text[sel.r1 + 1 to sel.r2 - 1] + if /x | sel.c2 ~= 1 then + suspend text[sel.r2][1:sel.c2] + } +end + + +procedure EditCopy(e) + local f,fn + if not EditIsEmptySelection(e) then { + fn := e.tempDir || EditClipboard + if f := open(fn,"w") then { + every write(f,EditSelectionLines(e)) + close(f) + } + else EditErrorMessage(e,"Can't open clipboard file \"",fn,"\"") + return + } + # fail +end + + +procedure EditDelete(e) + local sel,text + sel := e.selection + text := e.text + if EditIsEmptySelection(e) & (sel.c1 -:= 1) = 0 then { + # + # Handle backspace over the beginning of a line. + # + if sel.r1 > 1 then { + sel.r1 -:= 1 + sel.c1 := *text[sel.r1] + 1 + } + else { + # + # Here if no text left in buffer. + # + sel.c1 := 1 + if *text = 0 then return # buffer was already empty + if *text = 1 & text[1] == "" then { + get(text) + EditAddUndo(e,EditCreateOneLineBuffer) + return text + } + } + } + return EditReplace(e) +end + + +procedure EditDeleteToEnd(e) + local sel + EditNoteState(e) + sel := EditSortSelection(e.selection) + sel.r2 := *e.text + 1 + sel.c2 := 1 + EditDelete(e) + EditRefreshAndScroll(e) + return +end + + +procedure EditCreateOneLineBuffer(e) + put(e.text,"") + EditAddUndo(e,EditDelete,,e.selection) + return +end + + +procedure EditPaintLines(e,fromLine,toLine) + local col1,col2,cols,ender,fwidth,i,off,row1,row2,rows,screenLine, + scroll,scroller,sel,str,t1,t2,text,w + # + # Set up convenient variables. + # + ##write("Painting lines ",\fromLine | "start"," to ",\toLine | "end") ## + ##EditPrintSelection(e) ## + sel := EditSortSelection(copy(e.selection)) + row1 := sel.r1 + col1 := sel.c1 + row2 := sel.r2 + col2 := sel.c2 + scroller := e.scroller + w := scroller.w + rows := e.rows + fwidth := WAttrib(w,"fwidth") + cols := e.columns - (scroller.width + fwidth - 1) / fwidth + scroll := scroller.value + text := e.text + # + # Provide argument defaults. + # + if not (\fromLine >= 1) then fromLine := 1 + if not (\toLine <= rows) then toLine := rows + # + # Paint lines backward so underlining doesn't get overwritten. + # + screenLine := toLine + 1 + every i := scroll + toLine - 1 to scroll + fromLine - 1 by -1 do { + GotoRC(w,screenLine -:= 1,1) + if 1 <= screenLine <= rows then { + if str := text[i] then { + ## if line := EditExpandText(e,str := text[i]) then { + if not (row1 <= i <= row2) then { + # + # If line not selected + # + EditWrites(w,left(EditExpandText(e,str),cols)) + } + else if i = row1 then { + if i = row2 then { + if col1 = col2 then { + # + # If selection is insertion point in this line. + # + EditWrites(w,left(EditExpandText(e,str),cols)) + } + else { + # + # If selection starts and finishes in this line. + # + t1 := EditExpandText(e,str,col1,1) + EditWrites(w,t1[1:(cols >= *t1 | cols) + 1]) + WAttrib(w,"reverse=on") + t2 := EditExpandText(e,str,col2,2) + EditWrites(w, + t2[(cols >= *t1) + 1:(cols >= *t2 | cols) + 1 ]) + WAttrib(w,"reverse=off") + EditWrites(w, + left(EditExpandText(e,str,,3)[*t2 + 1:0], + 0 < cols - *t2)) + } + } + else { + # + # If selection starts in this but finishes beyond. + # + t1 := EditExpandText(e,str,col1,1) + EditWrites(w,t1[1:(cols >= *t1 | cols) + 1]) + WAttrib(w,"reverse=on") + EditWrites(w, + left(EditExpandText(e,str,,3)[*t1 + 1:0], + 0 < cols - *t1)) + WAttrib(w,"reverse=off") + } + } + else if row1 < i < row2 then { + # + # If this line is all included in selection. + # + WAttrib(w,"reverse=on") + EditWrites(w,left(EditExpandText(e,str),cols)) + WAttrib(w,"reverse=off") + } + else { # i = row2 + # + # Selection starts before but finishes in this line. + # + WAttrib(w,"reverse=on") + t1 := EditExpandText(e,str,col2,1) + EditWrites(w,t1[1:(cols >= *t1 | cols) + 1]) + WAttrib(w,"reverse=off") + EditWrites(w, + left(EditExpandText(e,str,,3)[*t1 + 1:0],0 < cols - *t1)) + } + } + else { + # + # Write lines that follow the valid text. + # + if i = *text + 1 then + writes(w,right("",cols,EditEOFStr)) + else + writes(w,\ender | (ender := repl(" ",cols))) + } + } + } + off := EditGetScreenOffset(e,text[row1],col1) | 1 + GotoRC(w,(e.columns < off,300000) | row1 - scroll + 1,off) + return w +end + + +procedure EditNonPos(i,len,def) + /i := def + if i <= 0 then i +:= len + 1 + if 1 <= i <= len + 1 then return i +end + + +procedure EditExpandText(e,line,col,part) + local p + col := EditNonPos(col,*line,0) | { + write(&errout, "EditNonPos failed unexpectedly: *line = ", *line) + runerr(500) + } + /part := 0 + p := if \e.buf.image then EditExpandImageLine + else EditExpandNormalLine + return p(e,line,col,part) | { + write(&errout, "p failed unexpectedly:") + runerr(500) + } +end + + +procedure EditExpandImageLine(e,line,col,part) + return ( + image(line[1:col])[1: + if part = (0 | 3) then 0 else -1]) + ## image(line)[2:-1] ? { + ## line := "" + ## while line ||:= tab(find("\\\"")) do move(1) + ## line ||:= tab(0) + ## } + ## return line +end + + +procedure EditExpandNormalLine(e,line,col) + static hiChars + initial hiChars := cset(&cset[129:0]) + if upto(EditFunnyChars,line,,col + 2 | 0) then { + line ? { + line := "" + while &pos < col do { + line ||:= + if ="_\b" then char(ord(move(1)) + 128) + else if ="\b" then line[-1] := "" + else if ="\e" then move(1) + else if any(EditFunnyChars) then image(move(1))[2:-1] + else move(1) + } + } + } + else line[col:0] := "" + return detab(line,Tabs) + ## ## col := find("_\b",line,1 <= col - 2 | 1,col + (2 | 1)) + 3 + ## line := line[1:col] + ## if upto(EditFunnyChars,line) then { + ## # + ## # Remove characters that are unprintable and change underlined + ## # characters by setting their high order bit. + ## # + ## line ? { + ## line := "" + ## while line ||:= tab(upto(EditFunnyChars)) do { + ## case move(1) of { + ## "\b": { + ## if line[-1] == "_" then line[-1] := char(ord(move(1)) + 128) + ## else line[-1] := "" + ## } + ## "\r": line := "" + ## } + ## } + ## line ||:= tab(0) + ## } + ## } + ## return detab(line,Tabs) +end + + +procedure EditGetStringOffset(e,s,screenOffset) + local i + /screenOffset := 1 + screenOffset -:= 1 + if *EditExpandText(e,s) <= screenOffset then { + return *s + 1 + } + i := 0 + while *EditExpandText(e,s,i +:= 1,1) < screenOffset + return i +end + + +procedure EditGetScreenOffset(e,s,stringOffset) + return *EditExpandText(e,s,stringOffset | 0,1) + 1 +end + + +procedure EditWrites(w,s[]) + local t,p + static loChars,hiChars,hiCharSet + initial { + loChars := string(&ascii) + hiChars := &cset[129:0] + hiCharSet := cset(hiChars) + } + every t := !s do t ? { + while writes(w,tab(upto(hiCharSet))) do { + p := [WAttrib(w,"x"),WAttrib(w,"y") + 2] + writes(w,map(tab(many(hiCharSet)),hiChars,loChars)) + p := p ||| [WAttrib(w,"x"),WAttrib(w,"y") + 2] + DrawLine!([w] ||| p) + } + writes(w,tab(0)) + } + return +end + + +procedure EditScrolled(scroller,evt,data,oldValue) + return EditScroll(data,scroller.value,oldValue) +end + + +procedure EditScroll(e,newValue,oldValue) + local dy,ady,w,fw,fh,wid,hi + if /oldValue then {EditPaintLines(e) ; return} + dy := newValue - oldValue + if \CopyAreaBug & not (-1 <= dy <= 1) then {EditPaintLines(e) ; return} + ady := abs(dy) + w := e.w + fw := WAttrib(w,"fwidth") + fh := WAttrib(w,"fheight") + wid := (e.columns - (e.scroller.width + fw - 1) / fw) * fw + hi := (e.rows - ady) * fh + if dy < 0 then { + CopyArea(w,w, + 0,0, + wid,hi, + 0,fh * ady) + EditPaintLines(e,1,ady) + } + else { + CopyArea(w,w, + 0,ady * fh, + wid,hi, + 0,0) + #EditPaintLines(e,e.rows - dy + 1,e.rows) + EditPaintLines(e,e.rows - dy,e.rows) + } + return +end + + +procedure EditHighlightSelection(e,oldSel) + local rows,sel + sel := e.selection + rows := sort([sel.r1,sel.r2,oldSel.r1,oldSel.r2]) + if rows[3] <= rows[2] + 1 then + EditPaintLines(e,EditScreenLine(e,rows[1]),EditScreenLine(e,rows[4])) + else { + EditPaintLines(e,EditScreenLine(e,rows[3]),EditScreenLine(e,rows[4])) + EditPaintLines(e,EditScreenLine(e,rows[1]),EditScreenLine(e,rows[2])) + } + return +end + + +## procedure EditPrintSelection(e,tag,sel) + ## /sel := e.selection + ## return write(\tag || " -- " | "", + ## "Selection = {",sel.r1,",",sel.c1,",",sel.r2,",",sel.c2,"}") +## end + + +## procedure EditPrintClip() + ## local f + ## write(">>> Clipboard:") + ## if f := open(e.tempDir || EditClipboard) then { + ## every write(image(!f)) + ## close(f) + ## } + ## return +## end + + +##procedure EditPrintUndo(e) + ## local sep,x,y,z + ## every y := ["Undo",e.buf.undoList] | ["Redo",e.buf.redoList] do { + ## write("\n",y[1],":") + ## every x := !y[2] do { + ## writes(image(x.proc),"(") + ## sep := "" + ## if \x.args then { + ## every z := !x.args do { + ## writes(sep,image(z)) + ## sep := "," + ## } + ## } + ## else writes("e") + ## write(")") + ## EditPrintSelection(e,,x.selection) + ## if x.proc === EditReplace & type(x.args[2]) == "list" then { + ## write(" -- Text:") + ## every write(" ",image(!x.args[2])) + ## } + ## } + ## } + ## return +## end + + +procedure EditReplace(e,s,sel) + local col1,col2,extended,firstReplLine,firstSelLine,lastReplLine, + lastSelLine,line,middleReplLines,oldSel,oldText,row1,row2,t,text + # + # Save prior text and selection for undo. + # + /sel := e.selection + oldText := [] + every put(oldText,EditSelectionLines(e,sel)) + oldSel := copy(sel) + # + # Put data in convenient locations. + # + EditSortSelection(sel) + row1 := sel.r1 + col1 := sel.c1 + row2 := sel.r2 + col2 := sel.c2 + text := e.text + # + # Provide defaults for the replacement string. + # + /s := "" + if type(s) == "string" then s := [s] + else if *s = 0 then put(s,"") + # + # Break the replacement string into separate lines if it contains + # "returns". + # + t := [] + every line := !s do line ? { + while put(t,tab(upto('\n\r'))) do move(1) + put(t,tab(0)) + } + s := t + # + # Perform the text replacement. + # + if row2 > *text then extended := put(text,"") + if *s = 1 & row1 = row2 then { + # + # Handle special case of single line selected and replacement is + # a single line. + # + t := !s + line := text[row1] + text[row1] := line[1:col1] || t || line[col2:0] + sel.c2 := sel.c1 +:= *t + } + else { + # + # Sort out the selection and replacement text. + # + firstReplLine := s[1] + lastReplLine := if *s > 1 then s[-1] + middleReplLines := if *s > 2 then s[2:-1] + firstSelLine := text[row1] + lastSelLine := if row1 ~= row2 then text[row2] + # + # Construct modified text. + # + firstReplLine := firstSelLine[1:col1] || firstReplLine + (\lastReplLine | firstReplLine) ||:= (\lastSelLine | firstSelLine)[col2:0] + t := \middleReplLines | [] + push(t,firstReplLine) + put(t,\lastReplLine) + e.text := e.buf.text := text := text[1:row1] ||| t ||| text[row2 + 1:0] + ## row1 := sel.r2 := sel.r1 +:= *s - 1 + sel.r2 := sel.r1 +:= *s - 1 + sel.c2 := sel.c1 := ((\lastReplLine,1) | sel.c1) + (*s[-1] | 0) + if \extended & *text[row1] == 0 then pull(text) + e.scroller.maxValue := *text + DrawScroller(e.scroller) + } + EditAddUndo(e,EditReplace,[e,oldText],EditSelection(row1,col1,sel.r2,sel.c2), + oldSel) + EditAdjustMarks(e,oldSel,s) + return text +end + + +procedure EditAddUndo(e,prc,args,sel,oldSel) + local lst,t,oldVersion + if type(args) == "EditSelection" then { + t := [] + every put(t,EditSelectionLines(e,args)) + args := [e,t] + } + /sel := e.selection + if sel === e.selection then sel := copy(sel) + /oldSel := sel + oldVersion := e.buf.version + if e.undoStatus === "undoing" then { + lst := e.buf.redoList + e.buf.version -:= 1 + } + else { + lst := e.buf.undoList + if /e.undoStatus then e.buf.redoList := [] + if *lst >= MaxUndo then pull(lst) + e.buf.version +:= 1 + } + push(lst,EditUndoRec(prc,args,sel,oldSel,oldVersion)) + ##EditPrintUndo(e) + return +end + + +procedure EditIsEmptySelection(e) + local sel + sel := e.selection + return sel.c1 = sel.c2 & sel.r1 = sel.r2 & &null +end + + +## procedure wim(s[]) + ## every writes(" ",image(!s)) + ## write() + ## return s[-1] | &null +## end + + +procedure EditSortSelection(sel) + if sel.r2 < sel.r1 then { + sel.r1 :=: sel.r2 + sel.c1 :=: sel.c2 + } + else if sel.r2 = sel.r1 & sel.c2 < sel.c1 then + sel.c1 :=: sel.c2 + return sel +end + + +procedure EditSetScroll(e,v) + Scroll_SetValue(e.scroller,v) + DrawScroller(e.scroller) + return +end + + +procedure EditExecuteIcon(e) + local line,trailer,fn,ifn,xfn,f,t,getLine + if /System then fail + if EditIsEmptySelection(e) then { + EditNoteState(e) + EditSelectWholeLines(e) + EditRefreshScreen(e) + } + fn := EditMakeTmp(e) + ifn := fn || ".icn" + xfn := case System of {default: fn ; "OS2": fn || ".icx"} + if f := open(ifn,"w") then { + t := [] + getLine := create EditSelectionLines(e) + while line := @getLine do line ? { + put(t,line) + tab(many(Space)) + if ="#" | pos(0) then {} + else { + if not (=("procedure" | "link" | "record" | "global") & + any(Space) | pos(0)) then { + writes(f,"procedure main(); every write(image({") + trailer := "})); end" + } + write(f,line) + break + } + } + while line := @getLine do { + put(t,line) + write(f,line) + } + write(f,\trailer) + close(f) + f := open("icont 2>&1 -s -o " || fn || " " || fn || " -x","rp") + while put(t,read(f)) + close(f) + remove(xfn) + remove(ifn) + put(t,"") + EditNoteState(e) + EditReplace(e,t) + EditRefreshAndScroll(e) + } + else EditRefreshScreen(e) + return +end + + +procedure EditSelectedTag(e,refresh) + local sel + EditNoteState(e) + if EditIsEmptySelection(e) then { + sel := EditSortSelection(e.selection) + if not any(WordSet,e.text[sel.r1],sel.c1) then { + if sel.c1 > 1 then {sel.c1 -:= 1 ; sel.c2 -:= 1} + } + EditSelectWord(e) + EditRefreshScreen(e) + } + return EditGoToTag(e,EditSelectionLines(e),refresh) +end + + +procedure EditReverseText(e) + local s + s := EditSelectionLines(e) + if type(s) == "string" then { + EditNoteState(e) + EditReplace(e,reverse(s)) + EditRefreshScreen(e) + } + return +end + +procedure EditGoToTag(e,tagKey,operation) + local f,tagRec,oldSel,oldBuf + static tagTable + case operation of { + "refresh": { + tagTable := &null + EditMessage(e,"Tags","Tags table discarded") + } + "size": return *\tagTable | 0 + } + if /tagKey then return + # + # If necessary, read the "tags" file and construct a tag table. + # + if /tagTable then { + if f := open("tags") then { + tagTable := table() + while read(f) ? { + tagTable[tab(find("\t"))] := EditTag((move(1),tab(find("\t"))), + (move(1),tab(0))) + &null # make sure scan succeeds so loop is controlled by read() + } + close(f) + } + } + # + # Find the tag. + # + if /tagTable then { + EditErrorMessage(e,"No tags file") + fail + } + (tagRec := \tagTable[tagKey]) | { + EditErrorMessage(e,"Tag ",image(tagKey)," not in tags file") + fail + } + oldSel := copy(e.selection) + oldBuf := e.buf + EditFindTag(e,tagRec) | fail + EditAddTrail(e,oldSel,oldBuf) + return +end + + +procedure EditFindTag(e,tagRec) + local fn,pattern,lineNbr + fn := tagRec.fileName + if fn == e.buf.saveFileName | EditOpen(e,fn) then { + pattern := tagRec.pattern + return { + if lineNbr := integer(pattern) then { + # + # If the pattern is an integer, interpret it as a line number. + # + EditScrollToLine(e,lineNbr,"wholeLine") + } + else { + # + # Fix up the pattern so it doesn't have any conflicts with + # regular expression special characters. + # + pattern ? { + pattern := "" + while pattern ||:= tab(upto('()[]*+?{}|')) do + pattern ||:= "\\" || move(1) + pattern ||:= tab(0) + } + EditFind(e,pattern,,"forward") + } + } + } +end + + +procedure EditCursorBox(e) + local w,fheight,fwidth,x,y,sel + if EditIsEmptySelection(e) then { + if EditScrollToSelectionIfOffScreen(e) then + EditPaintLines(e) + w := XBind(e.w,"linewidth=4") + sel := e.selection + fheight := WAttrib(w,"fheight") + fwidth := WAttrib(w,"fwidth") + x := (*EditExpandText(e,e.text[sel.r1][1:sel.c1]) | 0) * + fwidth + fwidth / 2 + y := (sel.r1 - e.scroller.value) * fheight + fheight / 2 + XDrawArc(w,x - 30,y - 30,60,60) + e.boxShowing := 1 + } + return +end + + +procedure EditChanged(e,buf) + /buf := e.buf + return buf.version ~= buf.saveVersion +end + + +procedure EditCreateMark(e,mName,sel,buf) + /mName := "*Last Place*" + /sel := e.selection + /buf := e.buf + EditSortSelection(sel) + if sel === e.selection then sel := copy(sel) + buf.markTable[mName] := sel + return mName +end + + +procedure EditCreateMarkCmd(e) + local mName + mName := EditSelectionLines(e) + mName[64:0] := "" + mName := EditGetTextDialog(e,"Create Mark","Name for mark?\n(default ", + image(mName),")\n") + EditCreateMark(e,mName) + return +end + + +procedure EditGoToMarkCmd(e) + local buf,maxwid,mName,dw,markSort,n,mark,resp,t + buf := e.buf + t := buf.markTable + maxwid := 0 + every mName := key(t) do maxwid <:= *mName + maxwid := Max(64,maxwid + 10) + dw := EditCreateMsgBox(e,"Go To Mark",maxwid,*t + 8) + write(dw,"List of Marks") + write(dw,"-------------") + markSort := sort(t) + n := 0 + every mark := (!markSort) do + write(dw,n +:= 1,". ",mark[1]) + write(dw, + "\n(Enter a number or mark name, or -number or -* to delete)_ + \nWhich mark?\n") + resp := read(dw) + close(dw) + if resp == "" then return + if resp[1] == "-" then { + if resp[2] == "*" then buf.markTable := table() + else { + resp[1] := "" + mName := markSort[integer(resp)][1] | resp + EditDeleteMark(e,mName) + } + } + else { + mName := markSort[integer(resp)][1] | resp + EditGoToMark(e,mName) + } + return +end + + +procedure EditDeleteMark(e,mName) + local t + t := e.buf.markTable + return delete(t, member(t,integer(mName) | mName)) +end + + +procedure EditGoToMark(e,mName) + local buf,selCopy + buf := e.buf + if buf.selection := copy(\buf.markTable[integer(mName) | mName]) then { + # + # The buffer's selection has been changed. The following two + # lines, which require the old selection, access the copy of the + # selection that remains in the EditRec, so work okay. + # + EditNoteState(e) + EditCreateMark(e) + # + # Now synchronize the EditRec copy of the selection with + # the new one from the mark. + # + e.selection := buf.selection + + EditRefreshAndScroll(e) + return + } +end + + +procedure EditAdjustMarks(e,sel,s) + local buf,t,mName,mark,d + buf := e.buf + t := buf.markTable + every mName := key(t) do { + mark := t[mName] + if mark.r2 >= sel.r1 then { # if mark is affected at all + d := (*s - 1) - (sel.r2 - sel.r1) + mark.r2 +:= d + if mark.r1 >= sel.r2 then { # if whole mark moved vertically + mark.r1 +:= d + } + if mark.r1 = sel.r2 then { # end of selection on same line as mark + d := (*s[1] + (*s[1 ~= *s] | 0)) - (sel.c2 - sel.c1) + mark.c2 +:= d + if mark.c1 >= sel.c2 then mark.c1 +:= d + } + } + EditValidateSelection(e,mark) + } +end + + +record EditTrailRec(bufName,markName) + +procedure EditAddTrail(e,sel,buf,trailList) + local mName + static markSerial + initial markSerial := 0 + /buf := e.buf + /trailList := e.backTrail + mName := "~Trail " || (markSerial +:= 1) + EditCreateMark(e,mName,copy(sel),buf) + push(trailList,EditTrailRec(buf.saveFileName,mName)) + #if trailList === e.backTrail then EditDeleteTrail(e,e.foreTrail) + return +end + + +procedure EditBackTrail(e) + local tr + if tr := pop(e.backTrail) then { + EditAddTrail(e,,,e.foreTrail) + (EditOpen(e,tr.bufName) & EditGoToMark(e,tr.markName)) | fail + delete(e.buf.markTable,tr.markName) + return + } + else EditBeep(e) +end + + +procedure EditForeTrail(e) + local tr + if tr := pop(e.foreTrail) then { + EditAddTrail(e) + (EditOpen(e,tr.bufName) & EditGoToMark(e,tr.markName)) | fail + delete(e.buf.markTable,tr.markName) + return + } + else EditBeep(e) +end + + +procedure EditDeleteTrail(e,trList) + local tr,buf + while tr := pop(trList) do { + if buf := \e.bufferTable[tr.bufName] then { + delete(buf.markTable,tr.markName) + } + } + return +end + + +procedure EditClearTrail(e) + every EditDeleteTrail(e,e.foreTrail | e.backTrail) + return +end + + +procedure EditDupAtLastClick(e) + EditCopy(e) + EditGoToMark(e,"*Last Click*") + EditPaste(e) + return +end + + +procedure EditRuler(e) + local sel,numbers,ruler,cols + sel := e.selection + EditSortSelection(sel) + sel.r2 := sel.r1 + sel.c1 := sel.c2 := 1 + numbers := "" + cols := e.columns * 2 + every numbers ||:= right(1 to cols / 10,10) + ruler := right("",cols,"----+----|") + EditNoteState(e) + EditReplace(e,[numbers,ruler,""]) + EditRefreshScreen(e) + return +end diff --git a/ipl/gpacks/htetris/Makefile b/ipl/gpacks/htetris/Makefile new file mode 100755 index 0000000..8a0167c --- /dev/null +++ b/ipl/gpacks/htetris/Makefile @@ -0,0 +1,8 @@ +htetris: + icont -s htetris + +Iexe: htetris + cp htetris ../../iexe/ + +Clean: + rm -f htetris diff --git a/ipl/gpacks/htetris/brickdata.icn b/ipl/gpacks/htetris/brickdata.icn new file mode 100644 index 0000000..92a1cff --- /dev/null +++ b/ipl/gpacks/htetris/brickdata.icn @@ -0,0 +1,126 @@ +############################################################################ +# +# File : editor.icn +# Author: Henrik Sandin +# Date : May 3, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains a procedure which creates and initializes a table of +# records of the type 'brick'. +# Those records contains data for the standard bricks which are always +# a part of the game. +# +############################################################################ + +############################################################################ +# +# Procedure: init_bricks +# Arguments: None. +# Returns : standard_bricks - A table containing standard brick data. +# +# This procedure initializes the seven standard bricks used in the game +# and puts them in a table which is returned. +# +############################################################################ + +procedure init_bricks() + + brick1 := + brick( "blue", + 0, + [init_positions( stom( "2,2;11;11")), + init_positions( stom( "2,2;11;11")), + init_positions( stom( "2,2;11;11")), + init_positions( stom( "2,2;11;11"))], + ["40,c1,jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWW", + "40,c1,jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWW", + "40,c1,jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWW", + "40,c1,jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjWjjjjjjjjjjjjjjjjjjjWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjJJJJJJJJJJJJJJJJWWjjWWWWWWWWWWWWWWWWWWjjWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWWjWWWWWWWWWWWWWWWWWWW"]) + + brick2 := + brick( "red", + 2, + [init_positions( stom( "4,1;1;1;1;1")), + init_positions( stom( "1,4;1111")), + init_positions( stom( "4,1;1;1;1;1")), + init_positions( stom( "1,4;1111"))], + ["20,c1,aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNN", + "80,c1,aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaaaaaaaaaaaaaaaaaaNaaaaaaaaaaaaaaaaaaaNaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaaNNNNNNNNNNNNNNNNNNaaNNNNNNNNNNNNNNNNNNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNN", + "20,c1,aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNN", + "80,c1,aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaNaaaaaaaaaaaaaaaaaaaNaaaaaaaaaaaaaaaaaaaNaaaaaaaaaaaaaaaaaaaNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaAAAAAAAAAAAAAAAANNaaNNNNNNNNNNNNNNNNNNaaNNNNNNNNNNNNNNNNNNaaNNNNNNNNNNNNNNNNNNaaNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNNaNNNNNNNNNNNNNNNNNNN"]) + + brick3 := + brick( "magenta", + 1, + [init_positions( stom( "3,2;11;10;10")), + init_positions( stom( "2,3;100;111")), + init_positions( stom( "3,2;01;01;11")), + init_positions( stom( "2,3;111;001"))], + ["40,c1,lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllYlllllllllllllllllllYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllYYYYYYYYYYYYYYYYYYllYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYYllllllllllllllllllll~~~~~~~~~~~~~~~~~~~~lllllllllllllllllllY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~lYYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~llllllllllllllllllll~~~~~~~~~~~~~~~~~~~~lllllllllllllllllllY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~lYYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~", + "60,c1,llllllllllllllllllll~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~lllllllllllllllllllY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~lYYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllYlllllllllllllllllllYlllllllllllllllllllYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllYYYYYYYYYYYYYYYYYYllYYYYYYYYYYYYYYYYYYllYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYY", + "40,c1,~~~~~~~~~~~~~~~~~~~~llllllllllllllllllll~~~~~~~~~~~~~~~~~~~~lllllllllllllllllllY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~lYYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~llllllllllllllllllll~~~~~~~~~~~~~~~~~~~~lllllllllllllllllllY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~llYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~lYYYYYYYYYYYYYYYYYYYlllllllllllllllllllllllllllllllllllllllllllllllllllllllllllYlllllllllllllllllllYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllYYYYYYYYYYYYYYYYYYllYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYY", + "60,c1,lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllYlllllllllllllllllllYlllllllllllllllllllYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllLLLLLLLLLLLLLLLLYYllYYYYYYYYYYYYYYYYYYllYYYYYYYYYYYYYYYYYYllYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYYlYYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llllllllllllllllllll~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~lllllllllllllllllllY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llLLLLLLLLLLLLLLLLYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~llYYYYYYYYYYYYYYYYYY~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~lYYYYYYYYYYYYYYYYYYY"]) + + brick4 := + brick( "yellow", + 1, + [init_positions( stom( "3,2;11;01;01")), + init_positions( stom( "2,3;111;100")), + init_positions( stom( "3,2;10;10;11")), + init_positions( stom( "2,3;001;111"))], + ["40,c1,dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddQdddddddddddddddddddQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddQQQQQQQQQQQQQQQQQQddQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddd~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dQQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddd~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dQQQQQQQQQQQQQQQQQQQ", + "60,c1,dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddQdddddddddddddddddddQdddddddddddddddddddQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddQQQQQQQQQQQQQQQQQQddQQQQQQQQQQQQQQQQQQddQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQdddddddddddddddddddd~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~dQQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~", + "40,c1,dddddddddddddddddddd~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dQQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddd~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~ddQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dQQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddQdddddddddddddddddddQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddQQQQQQQQQQQQQQQQQQddQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQ", + "60,c1,~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddd~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~dddddddddddddddddddQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddDDDDDDDDDDDDDDDDQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ddQQQQQQQQQQQQQQQQQQ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~dQQQQQQQQQQQQQQQQQQQdddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddQdddddddddddddddddddQdddddddddddddddddddQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddDDDDDDDDDDDDDDDDQQddQQQQQQQQQQQQQQQQQQddQQQQQQQQQQQQQQQQQQddQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQdQQQQQQQQQQQQQQQQQQQ"]) + + brick5 := + brick( "green", + -1, + [init_positions( stom( "2,3;011;110")), + init_positions( stom( "3,2;10;11;01")), + init_positions( stom( "2,3;011;110")), + init_positions( stom( "3,2;10;11;01"))], + ["60,c1,~~~~~~~~~~~~~~~~~~~~ffffffffffffffffffffffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffSfffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSSffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSSffffffffffffffffffffffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffSfffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSSffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~", + "40,c1,ffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffSfffffffffffffffffffSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffSSSSSSSSSSSSSSSSSSffSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~ffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSS", + "60,c1,~~~~~~~~~~~~~~~~~~~~ffffffffffffffffffffffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffSfffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSSffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSSffffffffffffffffffffffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffSfffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSSffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~", + "40,c1,ffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffSfffffffffffffffffffSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffFFFFFFFFFFFFFFFFSSffSSSSSSSSSSSSSSSSSSffSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSSfSSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~ffffffffffffffffffff~~~~~~~~~~~~~~~~~~~~fffffffffffffffffffS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffFFFFFFFFFFFFFFFFSS~~~~~~~~~~~~~~~~~~~~ffSSSSSSSSSSSSSSSSSS~~~~~~~~~~~~~~~~~~~~fSSSSSSSSSSSSSSSSSSS"]) + + brick6 := + brick( "cyan", + -1, + [init_positions( stom( "2,3;110;011")), + init_positions( stom( "3,2;01;11;10")), + init_positions( stom( "2,3;110;011")), + init_positions( stom( "3,2;01;11;10"))], + ["60,c1,hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhUhhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUUhhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhUhhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUUhhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUU", + "40,c1,~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUUhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhUhhhhhhhhhhhhhhhhhhhUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhUUUUUUUUUUUUUUUUUUhhUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUUhhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~", + "60,c1,hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhUhhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUUhhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhUhhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUUhhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUU", + "40,c1,~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUUhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhUhhhhhhhhhhhhhhhhhhhUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhHHHHHHHHHHHHHHHHUUhhUUUUUUUUUUUUUUUUUUhhUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUUhUUUUUUUUUUUUUUUUUUUhhhhhhhhhhhhhhhhhhhh~~~~~~~~~~~~~~~~~~~~hhhhhhhhhhhhhhhhhhhU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhHHHHHHHHHHHHHHHHUU~~~~~~~~~~~~~~~~~~~~hhUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~hUUUUUUUUUUUUUUUUUUU~~~~~~~~~~~~~~~~~~~~"]) + + brick7 := + brick( "orange", + 1, + [init_positions( stom( "3,2;10;11;10")), + init_positions( stom( "2,3;010;111")), + init_positions( stom( "3,2;01;11;01")), + init_positions( stom( "2,3;111;010"))], + ["40,c1,bbbbbbbbbbbbbbbbbbbb~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bOOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbObbbbbbbbbbbbbbbbbbbObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbOOOOOOOOOOOOOOOOOObbOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOObbbbbbbbbbbbbbbbbbbb~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bOOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~", + "60,c1,~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbb~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bOOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbObbbbbbbbbbbbbbbbbbbObbbbbbbbbbbbbbbbbbbObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbOOOOOOOOOOOOOOOOOObbOOOOOOOOOOOOOOOOOObbOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOO", + "40,c1,~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbb~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bOOOOOOOOOOOOOOOOOOObbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbObbbbbbbbbbbbbbbbbbbObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbOOOOOOOOOOOOOOOOOObbOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbb~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~bbOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bOOOOOOOOOOOOOOOOOOO", + "60,c1,bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbObbbbbbbbbbbbbbbbbbbObbbbbbbbbbbbbbbbbbbObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbBBBBBBBBBBBBBBBBOObbOOOOOOOOOOOOOOOOOObbOOOOOOOOOOOOOOOOOObbOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOObOOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbb~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbbbbbbbbbbbbbbbbbbO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbBBBBBBBBBBBBBBBBOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bbOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~bOOOOOOOOOOOOOOOOOOO~~~~~~~~~~~~~~~~~~~~"]) + + standard_bricks := table() + standard_bricks["brick_1"] := brick1 + standard_bricks["brick_2"] := brick2 + standard_bricks["brick_3"] := brick3 + standard_bricks["brick_4"] := brick4 + standard_bricks["brick_5"] := brick5 + standard_bricks["brick_6"] := brick6 + standard_bricks["brick_7"] := brick7 + return standard_bricks +end diff --git a/ipl/gpacks/htetris/brickio.icn b/ipl/gpacks/htetris/brickio.icn new file mode 100644 index 0000000..cb6e629 --- /dev/null +++ b/ipl/gpacks/htetris/brickio.icn @@ -0,0 +1,342 @@ +############################################################################ +# +# File : brickio.icn +# Author: Henrik Sandin +# Date : May 3, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures for reading and writing bricks to disk. +# The file format for a brick is as follows: +# +# *.brk* +# <color> +# <matrix string corresponding to imagestring1> +# <matrix string corresponding to imagestring2> +# <matrix string corresponding to imagestring3> +# <matrix string corresponding to imagestring4> +# <imagestring1> +# <imagestring2> +# <imagestring3> +# <imagestring4> +# +############################################################################ + +############################################################################ +# +# Procedure: wait_message +# Arguments: parent_window - Parent window of this message window. +# message - Message to display. +# Returns : wait_window - The new message window. +# +# This procedure creates and returns a window containig the given message. +# Its position is set relative to its parent window. +# +############################################################################ + +procedure wait_message( parent_window, message) + + if wait_window := + WOpen( "label=" || WAttrib( parent_window, "label"), "size=350,160", + "posx=" || WAttrib( parent_window, "posx")-60, + "posy=" || WAttrib( parent_window, "posy")+60, + "bg=gray-white") then { + + Font( wait_window, Font( parent_window)) + CenterString( wait_window, + WAttrib( wait_window, "width")/2, 30, + message) + DrawRectangle( wait_window, 75, 60, 200, 30) + CenterString( wait_window, + WAttrib( wait_window, "width")/2, 130, + "0% done.") + } + else write( "Could not open wait-message window.") + return wait_window +end + +############################################################################ +# +# Procedure: work_done +# Arguments: wait_window - An io waiting window. +# percentage - An integer between 0 and 100. +# Returns : Nothing. +# +# This procedure updates an io waiting windows percentage display to +# the given percentage. +# +############################################################################ + +procedure work_done( wait_window, percentage) + + FillRectangle( wait_window, 75, 60, (percentage/100.0)*200, 30) + EraseArea( wait_window, 140, 120, 70, 20) + CenterString( wait_window, + WAttrib( wait_window, "width")/2, 130, + string( percentage) || "% done.") + return +end + +############################################################################ +# +# Procedure: save_prompt +# Arguments: parent_window - The window of the calling application.. +# Returns : Nothing. +# +# This procedure shows a dialog box with buttons "Yes" and "No", asking the +# user if he/she wants to save the current brick. +# If "Yes" is pressed, the brick is saved. +# +############################################################################ + +procedure save_prompt( parent_window) + + button_pressed := + TextDialog( parent_window, + ["Save current brick first?"], + [], + [], + [], + ["Yes", "No"]) + + case button_pressed of { + "Yes" : { + save_brick( parent_window) + } + } + return +end + +############################################################################ +# +# Procedure: scan_filename +# Arguments: name - A filename. +# Returns : filename - The same filename possibly altered. +# +# This procedure checks if the given filename contains the substring ".brk" +# and in that case discards the characters following ".brk". +# If it does not contain ".brk", that is appended to the end of the name +# string. +# +############################################################################ + +procedure scan_filename( name) + + name ? { + if position := find( ".brk") then + filename := tab( position) || ".brk" + else + filename := dialog_value || ".brk" + } + return filename +end + +############################################################################ +# +# Procedure: load +# Arguments: request_window - The window of the calling application. +# filename - A filename. +# Returns : A 'brick' record containing the data of the loaded brick file. +# +# This procedure opens a file with the given filename if it can be opened +# and reads its contents into varibles stored in a record of type 'brick' +# which is returned. If the file is not on the expected format, an error +# message is displayed and the load is aborted. +# +############################################################################ + +procedure load( request_window, filename) + + brickfile := open( filename) | { + Notice( request_window, "Could not open '" || filename || "'.") + return + } + + header := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + if header ~== "*.brk*" then { + Notice( request_window, "File format not recognized.") + return + } + + color := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + if invalid( color) then { + Notice( request_window, "File format not recognized.") + return + } + + matrix_string := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + matrix1 := stom( matrix_string) + matrix_string := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + matrix2 := stom( matrix_string) + matrix_string := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + matrix3 := stom( matrix_string) + matrix_string := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + matrix4 := stom( matrix_string) + + image1 := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + image2 := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + image3 := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + image4 := read( brickfile) | { + Notice( request_window, "File format not recognized.") + return + } + close( brickfile) + return brick( color, + &null, + [matrix1, matrix2, matrix3, matrix4], + [image1, image2, image3, image4]) +end + +############################################################################ +# +# Procedure: open_brick +# Arguments: request_window - The window of the calling application. +# Returns : brick_data - A record of type brick. +# +# This procedure shows an open dialog box with buttons "Ok" and "Cancel", +# where the user is asked to enter the name of a brick to open from a file. +# The filename is scanned and possibly have ".brk" appended to it, then +# checked if it was empty. If there was no filename, the open dialog re- +# appears until the user enters a filename or cancel is pressed. The same +# thing happens if the brick data could not be loaded correctly due to a +# file on the wrong format. +# If the brick data was successfully loaded, they are returned as a record +# of type 'brick'. +# +############################################################################ + +procedure open_brick( request_window) + + button_pressed := OpenDialog( request_window, "Open brick. Enter filename:") + case button_pressed of { + "Okay" : { + filename := scan_filename( dialog_value) + + if filename == ".brk" then { + Notice( request_window, "File must have a name.") + return open_brick( request_window) + } + if /(brick_data := load( request_window, filename)) then + return open_brick( request_window) + } + } + return brick_data +end + +############################################################################ +# +# Procedure: save +# Arguments: request_window - The window of the calling application. +# filename - A filename. +# brick_data - A record of type 'brick'. +# Returns : Nothing. +# +# This procedure opens a file with the given filename if it can be opened +# and writes the contents of the 'brick' record to the file. +# It fails if the file could not be opened. +# +############################################################################ + +procedure save( request_window, filename, brick_data) + + brickfile := open( filename, "ct") | { + Notice( request_window, "Could not open or create '" || filename || "'.") + fail + } + write( brickfile, "*.brk*") + write( brickfile, brick_data.color) + write( brickfile, mtos( brick_data.matrices[1])) + write( brickfile, mtos( brick_data.matrices[2])) + write( brickfile, mtos( brick_data.matrices[3])) + write( brickfile, mtos( brick_data.matrices[4])) + write( brickfile, brick_data.images[1]) + write( brickfile, brick_data.images[2]) + write( brickfile, brick_data.images[3]) + write( brickfile, brick_data.images[4]) + close( brickfile) + return +end + +############################################################################ +# +# Procedure: save_brick +# Arguments: request_window - The window of the calling application. +# Returns : Nothing. +# +# This procedure shows a save dialog box with buttons "Yes", "No" and +# "Cancel", where the user is asked to enter the name of the brick to be +# saved to a file. +# The filename is scanned and possibly have ".brk" appended to it, then +# checked if it was empty. If there was no filename, the open dialog re- +# appears until the user enters a filename or cancel is pressed. The same +# thing happens if the brick data could not be saved correctly due to a +# file opening error. +# If the brick data was successfully saved, 'saved' is set to 'YES'. +# A waiting message is displayed during the saving. +# +############################################################################ + +procedure save_brick( request_window) + + button_pressed := SaveDialog( request_window, "Save brick. Enter filename:") + case button_pressed of { + "Yes" : { + filename := scan_filename( dialog_value) + + if filename == ".brk" then { + Notice( request_window, "File must have a name.") + save_brick( request_window) + return + } + wait_window := wait_message( request_window, + "Saving brick, please wait.") + + old_pointer := WAttrib( wait_window, "pointer") + if old_pointer == "left ptr" then + WAttrib( wait_window, "pointer=watch") + else + WAttrib( wait_window, "pointer=wait") + + brick_data := assemble_data( wait_window) + if not save( request_window, filename, brick_data) then { + save_brick( request_window) + return + } + work_done( wait_window, 100) + WAttrib( wait_window, "pointer=" || old_pointer) + if \wait_window then WClose( wait_window) + } + } + return +end diff --git a/ipl/gpacks/htetris/docstartpage.html b/ipl/gpacks/htetris/docstartpage.html new file mode 100644 index 0000000..3439fd2 --- /dev/null +++ b/ipl/gpacks/htetris/docstartpage.html @@ -0,0 +1,23 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<!--NewPage--> +<html> +<head> +<title>htetris documentation</title> +</head> +<body> +<h1> +<center>User Manual For htetris Version 1.0</center> +<center>Henrik Sandin 1999</center> +</h1> +<hr> +<font size="5"> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/howto.html"><b>How to play.</b></a><br> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/interface.html"><b>The graphical user interface.</b></a><br> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/menus.html"><b>Menu items and features.</b></a><br> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/editor.html"><b>Brick editor.</b></a><br> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/implement.html"><b>Implementation details.</b></a><br> +</font> +<br> +Send bug reports and questions <a href="mailto:henriks@optima.CS.arizona.EDU">here.</a> +</body> +</html> diff --git a/ipl/gpacks/htetris/editor.html b/ipl/gpacks/htetris/editor.html new file mode 100644 index 0000000..5b5fde0 --- /dev/null +++ b/ipl/gpacks/htetris/editor.html @@ -0,0 +1,94 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<!--NewPage--> +<html> +<head> +<title>htetris documentation</title> +</head> +<body> +<h1> +<center>User Manual For htetris Version 1.0</center> +<center>Henrik Sandin 1999</center> +</h1> +<hr> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/htetrisdoc.html">Main page</a> +<h2>The brick editor</h2><br> +<font size="5"> +<b>htetris</b> includes a brick editor where the user can create his/hers own +bricks and include them when playing the game. +A brick consists of squares, or tiles, which is the basic unit of measurement +for a brick. A brick must be at least one square and at most ten by ten squares +in size. Any rectangular format in between is allowed.<br> +The editor interface consists of an area where bricks are edited, a menu bar +with three menus and two buttons as shown below.<br> +<br> +<img src="http://lww.CS.Arizona.EDU:80/~henriks/editscreen.gif" alt="Editor screenshot."> +<br> +<br> +To fill a square on the edit pane, the user points the mouse at that square +and clicks the left mouse button. The right mouse button is used to erase +a filled square. Only one color per brick can be used.<br> +The upper left corner of the currently edited brick resides in the upper left +corner of the edit pane. It is not possible to fill a square outside the +bounds of the current brick. There is a grid which shows the bounds when it +is shown. The grid can be switched on and off by pressing the +<b>Toggle grid</b> button on the interface. The <b>Clear</b> button clears +whatever filled squares there are but does not affect the grid. +A brick can take on any shape, even unconnected regions in the same brick.<br> +A brick can be saved to file and previously saved bricks can be opened and +re-edited. All features are described in detail below. +</font> + +<h2>Menu items and features</h2><br> +<font size="5"> +<ul type="square"> +<li>The <b>File</b> menu<br><br> +<ul type="disc"> +<li><b>New</b><br> +Lets the user start editing a new brick of the chosen size and color. +A brick must be at least one by one and at most ten by ten in size.<br> +Valid colors are: yellow, red, blue, green, orange, magenta, cyan and brown.<br> +When the user clicks <b>Okay</b> in the dialog box, an empty grid of the given +size shows up on the edit pane. +<li><b>Open</b><br> +If <b>Open</b> is selected, a dialog appears which prompts the user for the +filename of a previously saved brick. Brick files always have the extension +<b>.brk</b> but this is not necessary to include, although it is perfectly +alright to do so.<br> +If the file is valid and could be opened successfully, the editor resets itself +to the measurements and color of the loaded brick and the brick appears with +the grid on. +<li><b>Save</b><br> +The user enters a filename in the shown dialog box and the brick is saved +under that name. If the extension <b>.brk</b> is not added to the name, the +editor automaticly adds it before saving. If the user enter a name with +characters after <b>.brk</b>, those are discarded. Saving can not be performed +if there are no filled squares. If not all rows and columns are used for the +brick to be saved, the brick is stripped of such empty rows and columns before +it is saved. This does not apply to empty rows and columns between filled +squares, only "edge" rows and columns are stripped off. +<li><b>Quit</b><br> +This closes the brick editor and returns focus to the htetris application. +</ul> +<br> +<li>The <b>Brick</b> menu<br><br> +<ul type="disc"> +<li><b>Change color</b><br> +This changes the color of the currently edited brick in place. From now on, +this color is used to fill squares unless color is changed again, a brick is +loaded from file or a new brick is started.<br> +The same colors as mentioned above under <b>New</b> are valid. +</ul> +<br> +<li>The <b>Help</b> menu<br><br> +<ul type="disc"> +<li><b>How to edit</b><br> +This option basicly displays the same information as the first section of this +document. +<li><b>Menus</b><br> +This option basicly displays the same information as the this section of this +document. +</ul> +</ul> +</font> +</body> +</html> diff --git a/ipl/gpacks/htetris/editor.icn b/ipl/gpacks/htetris/editor.icn new file mode 100644 index 0000000..fdf8e0e --- /dev/null +++ b/ipl/gpacks/htetris/editor.icn @@ -0,0 +1,981 @@ +############################################################################ +# +# File : editor.icn +# Author: Henrik Sandin +# Date : May 3, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures to handle user actions in the brick editor. +# An edited brick can be up to 10 x 10 sqares in size which is the width +# of the htetris playing field. A square is 20 by 20 pixels. +# A brick being edited is represented by a matrix, containing ones for +# colored squares and zeros for non-colored (black) squares. +# The editor is invoked and closed by the htetris module simply by changing +# the "canvas" attribute of the editor window. +# +############################################################################ + +############################################################################ +# +# Global varibles used by both htetris.icn and editor.icn. +# +############################################################################ + +global editor_window # The editor window, initially hidden. +global editor_vidgets # The table of widgets in the editor interface. + +############################################################################ +# +# Global varibles used by editor.icn only. +# +# edit_pane - The editing area, which is 200 by 200 pixels. +# grid_width - Current width of the grid (the active drawing area within +# the edit pane). +# grid_height - Current height of the grid (the active drawing area within +# the edit pane). +# grid_status - Flag determining whether the grid is visible or not. +# mutable_grid_color - Mutable color of grid if mutable colors are used. +# mutable_brick_color - Mutable base color of a brick. +# mutable_brick_color_light - Mutable light shade for 3D-effect on bricks. +# mutable_brick_color_dark - Mutable dark shade for 3D-effect on bricks. +# brick_color - Color of brick on string format. +# brick_matrix - Twodimensional matrix representing the current brick. +# mutables - Flag determining whether mutable colors are used or not. +# saved - Flag determining whether the current brick is saved or not. +# +############################################################################ + +global edit_pane +global mutable_grid_color # Color of grid used if mutable colors are in use. +global grid_width +global grid_height +global grid_status # Status of grid, 'ON' or 'OFF'. +global brick_color # Current non-mutable color of brick. +global mutable_brick_color # Color of brick used if mutable colors are in use. +global mutable_brick_color_light +global mutable_brick_color_dark +global brick_matrix # The matrix representation of the current brick. +global mutables # Flag indicating if mutable colors are used or not. +global saved # Flag indicating if current brick is saved or not. + +$define OFF 0 # Constant representing the grid state off. +$define ON 1 # Constant representing the grid state on. +$define NO 0 # Constant representing the semantics of no. +$define YES 1 # Constant representing the semantics of yes. +$define BLACK 0 # Constant representing a black square on the edit pane. +$define COLORED 1 # Constant representing a colored square. + +############################################################################ +# +# Procedure: start_editor +# Arguments: None. +# Returns : Nothing. +# +# This procedure starts up the brick editor in a hidden window. +# The editing area is initialized and it is determined if mutable colors +# are to be used or not. +# On a slow machine, mutable colors might make the updating of the edit +# pane look better. +# Also, since no brick has been edited yet, 'saved' is set to 'YES'. +# This is only performed once when the htetris application is started. +# +############################################################################ + +procedure start_editor() + + atts := put( editor_atts(), "canvas=hidden") + + (editor_window := WOpen ! atts) | { + Notice( htetris_window, + "Editor can not be used because", + "its window could not be opened.") + fail + } + + editor_vidgets := editor( editor_window) + pane_width := editor_vidgets["edit"].uw + pane_height := editor_vidgets["edit"].uh + edit_pane := Clone( editor_window, "bg=black", + "dx=" || editor_vidgets["edit"].ux, + "dy=" || editor_vidgets["edit"].uy) + + Clip( edit_pane, 0, 0, pane_width, pane_height) + EraseArea( edit_pane, 0, 0, pane_width, pane_height) + + mutable_brick_color := NewColor() + mutable_brick_color_light := NewColor() + mutable_brick_color_dark := NewColor() + mutable_grid_color := NewColor() + + if (mutable_brick_color === &null | + mutable_brick_color_light === &null | + mutable_brick_color_dark === &null | + mutable_grid_color === &null) then + mutables := NO + else + mutables := YES + + saved := YES + return +end + +############################################################################ +# +# Procedure: kill_editor +# Arguments: None. +# Returns : Nothing. +# +# This procedure closes down the editor, freeing mutable color if they are +# used and closing the editor window. +# This is only performed when the htetris application is closed. +# +############################################################################ + +procedure kill_editor() + + if mutables = YES then { + FreeColor( mutable_brick_color) + FreeColor( mutable_brick_color_light) + FreeColor( mutable_brick_color_dark) + FreeColor( mutable_grid_color) + } + WClose( editor_window) + return +end + +############################################################################ +# +# Procedure: edit +# Arguments: None. +# Returns : Nothing. +# +# This is the event loop for the editor which is entered by the htetris +# application when the editor is to be used. +# +############################################################################ + +procedure edit() + + while (*Pending( editor_window) > 0) do + ProcessEvent( root) + + return +end + +############################################################################ +# +# Procedure: reset_editor +# Arguments: matrix - A matrix representing a new brick (possibly empty). +# new_color - New color. +# Returns : Nothing. +# +# This procedure resets the editor using the matrix and the given color. +# The edit pane is cleared and the grid is shown. +# +############################################################################ + +procedure reset_editor( matrix, new_color) + + grid_width := *matrix[1] # Number of columns. + grid_height := *matrix # Number of rows. + brick_color := new_color + brick_matrix := matrix + + if mutables = YES then { + Color( mutable_brick_color, new_color) + Color( mutable_brick_color_light, "light-" || new_color) + Color( mutable_brick_color_dark, "dark-" || new_color) + Color( mutable_grid_color, "white") + } + + EraseArea( edit_pane, 0, 0, + editor_vidgets["edit"].uw, editor_vidgets["edit"].uh) + + if mutables = YES then + draw_grid( mutable_grid_color) + else + draw_grid( "white") + + grid_status := ON + return +end + +############################################################################ +# +# Procedure: draw_brick +# Arguments: window - The window in which to draw the brick. +# color - Color in which to draw the brick. +# matrix - The matrix representation of the brick. +# Returns : Nothing. +# +# This procedure draws a brick in a specified window using the specified +# color andbrick matrix. +# For every colored element in the matrix a square is drawn in the given +# color if mutable colors aren't used. Otherwise the current mutable brick +# color is used. +# +############################################################################ + +procedure draw_brick( window, color, matrix) + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + if matrix[r][c] = COLORED then + if mutables = YES then + draw_mutable_square( r, c, window) + else + draw_square( r, c, window, color) + return +end + +############################################################################ +# +# Procedure: draw_grid +# Arguments: color - Grid color. +# Returns : Nothing. +# +# This procedure redraws the grid in in all non-colored squares in the +# specified grid color which is either white, black or the mutable grid- +# color. +# +############################################################################ + +procedure draw_grid( color) + + Fg( edit_pane, color) + every r := 1 to grid_height do + every c := 1 to grid_width do + if brick_matrix[r][c] = BLACK then + DrawSegment( edit_pane, + (c-1)*20, (r-1)*20, (c-1)*20, (r-1)*20+19, + (c-1)*20, (r-1)*20, (c-1)*20+19, (r-1)*20) + + DrawSegment( edit_pane, 0, grid_height*20, grid_width*20, grid_height*20, + grid_width*20, 0, grid_width*20, grid_height*20) + return +end + +############################################################################ +# +# Procedure: remove_grid +# Arguments: None. +# Returns : Nothing. +# +# This procedure removes the grid from the edit pane by setting its +# color where it is shown to black, either by changing the mutable color +# or calling draw_grid. +# +############################################################################ + +procedure remove_grid() + + if mutables = YES then + Color( mutable_grid_color, "black") + else + draw_grid( "black") + return +end + +############################################################################ +# +# Procedure: apply_grid +# Arguments: None. +# Returns : Nothing. +# +# This procedure shows the grid on the edit pane by setting its +# color where it is shown to white, either by changing the mutable color +# or calling draw_grid. +# +############################################################################ + +procedure apply_grid() + + if mutables = YES then + Color( mutable_grid_color, "white") + else + draw_grid( "white") + return +end + +############################################################################ +# +# Procedure: ctop +# Arguments: coordinate - An x or y coordinate in the pixel coordinate system. +# Returns : The corresponding row or column position on the edit pane. +# +# This procedure converts an x or y pixel coordinate on the edit pane to +# the corresponding row or column number. +# Row and column numbers starts at 1 and are 20 pixels in height and width +# respectively. +# +############################################################################ + +procedure ctop( coordinate) + + while coordinate % 20 ~= 0 do coordinate := coordinate-1 + + return coordinate/20+1 +end + +############################################################################ +# +# Procedure: invalid +# Arguments: color - A color on string format. +# Returns : Succseeds if the color is not a valid brick color, fails +# otherwise. +# +# This procedure determines whether the given color is invalid as a brick +# color. +# +############################################################################ + +procedure invalid( color) + + valid_colors := set(["yellow", "red", "blue", "green", "orange", + "magenta", "cyan", "brown"]) + + return not member( valid_colors, color) +end + +############################################################################ +# +# Procedure: out_of_bounds +# Arguments: width - An integer width. +# height - An integer height. +# Returns : Succseeds if width and height are not between 1 and 10 inclusive, +# fails otherwise. +# +# This procedure determines whether the given width and height are invalid +# brick measurements. A brick must be between 1 x 1 and 10 x 10 squares. +# +############################################################################ + +procedure out_of_bounds( width, height) + + return width > 10 | width < 1 | height > 10 | height < 1 +end + +############################################################################ +# +# Procedure: edit_new +# Arguments: None. +# Returns : Nothing. +# +# This procedure shows a text dialog box with buttons "Ok" and "Cancel", +# where the user is asked to enter width, height and color of a new brick. +# The three input values are checked for validity and if they are correct, +# the editor is reset with the new values and 'saved' is set to 'YES'. +# If they are not correct, an error message is given and the dialog +# reappears until the user enters valid values or cancel is pressed. +# +############################################################################ + +procedure edit_new() + + button_pressed := + TextDialog( editor_window, + ["Enter properties of the brick."], + ["Width:", "Height:", "Color:"], + [], + [2, 2, 20]) + + case button_pressed of { + "Okay" : { + width := integer( dialog_value[1]) + height := integer( dialog_value[2]) + color := dialog_value[3] + + if (width === &null | height === &null) | + (out_of_bounds( width, height)) then { + Notice( editor_window, + "Width and height must be between 1 and 10.") + edit_new() + return + } + else if invalid( color) then { + Notice( editor_window, + "Color must be one of the following:", + "yellow, red, blue, green, orange,", + "magenta, cyan or brown.") + edit_new() + return + } + else { + reset_editor( new_matrix( height, width), color) + saved := YES + } + } + } + return +end + +############################################################################ +# +# Procedure: edit_open +# Arguments: None. +# Returns : Nothing. +# +# Brick data are obtained by a call to 'open_brick'. +# If they were successfully returned, appropriate elements of them are +# extracted to reset the editor according to the attributes of the +# loaded brick and draw it on the edit pane. 'saved' is set to 'YES'. +# +############################################################################ + +procedure edit_open() + + old_pointer := WAttrib( editor_window, "pointer") + if old_pointer == "left ptr" then + WAttrib( editor_window, "pointer=watch") + else + WAttrib( editor_window, "pointer=wait") + + if /(brick_data := open_brick( editor_window)) then + return + + reset_editor( brick_data.matrices[1], brick_data.color) + draw_brick( edit_pane, brick_color, brick_matrix) + WAttrib( editor_window, "pointer=" || old_pointer) + saved := YES + return +end + +############################################################################ +# +# Procedure: empty_pane +# Arguments: None. +# Returns : One of the constants YES or NO. +# +# This procedure determines if the edit pane is empty by traversing the +# grid matrix. 'YES' is returned if all elements in the matrix were black. +# If at least one element is colored, 'NO' is returned. +# +############################################################################ + +procedure empty_pane() + + every r := 1 to grid_height do + every c := 1 to grid_width do + if brick_matrix[r][c] ~= BLACK then + return NO + return YES +end + +############################################################################ +# +# Procedure: save_temp_window +# Arguments: width - Width of the temporary window. +# height - Height of the temporary window. +# Returns : temp_window - The temporary window. +# +# This procedure opens and returns a temporary hidden window of the given +# size. This is used to draw a brick temporarily when saving it. +# +############################################################################ + +procedure save_temp_window( width, height) + + temp_window := + WOpen( "width=" || width, + "height=" || height, + "bg=black", + "canvas=hidden") | { + Notice( editor_window, "Error while saving brick, save aborted.") + return + } + return temp_window +end + +############################################################################ +# +# Procedure: transparentify +# Arguments: spec - An icon imagestring specification. +# Returns : temp - The transformed specification. +# +# This procedure transforms and returns an imagestring with colors from +# the "c1" palette to a transparent imagestring, replacing all black pixels +# (zeros) with transparent pixels (~). +# +############################################################################ + +procedure transparentify( spec) + spec ? { + temp := tab( upto( ',')) || move( 1) || + tab( upto( ',')) || move( 1) + + while colored := tab( upto( '0')) do { + nr_black := many( '0') - &pos + tab( many( '0')) + transparent := repl( "~", nr_black) + temp := temp || colored || transparent + } + if temp := temp || move( 1) then + temp := temp || tab( many( cset( PaletteChars( "c1")) -- '0')) + } + return temp +end + +############################################################################ +# +# Procedure: assemble_data +# Arguments: None. +# Returns : A 'brick' record containing data of the current brick. +# +# This procedure assembles data for the current brick, which includes the +# color, four matrices and four corresponding image-strings. +# The first brick matrix must first be trimmed if all of the availible area +# on the edit pane has not been used. +# The trimmed brick matrix is then rotated and drawn in temporary windows +# which contents are captured as imagestrings. Each of the four image- +# strings produced are converted to transparent ones where all black pixels +# become transparent instead. +# A record of type 'brick' is returned with all fields but 'offset' +# filled in. +# +############################################################################ + +procedure assemble_data( wait_window) + + area_used := non_zero_limits( brick_matrix) + work_done( wait_window, 10) + + x := (area_used.min_col-1)*20 + y := (area_used.min_row-1)*20 + width := (area_used.max_col-area_used.min_col+1)*20 + height := (area_used.max_row-area_used.min_row+1)*20 + work_done( wait_window, 12) + + if /(temp_window1 := save_temp_window( height, width)) then fail + if /(temp_window2 := save_temp_window( width, height)) then fail + if /(temp_window3 := save_temp_window( height, width)) then fail + work_done( wait_window, 15) + + if grid_status = ON then remove_grid() + image1 := transparentify( Capture( edit_pane, "c1", x, y, width, height)) + if grid_status = ON then apply_grid() + work_done( wait_window, 30) + + matrix1 := trim_matrix( brick_matrix) + work_done( wait_window, 40) + + if mutables = YES then + color := mutable_brick_color + else + color := brick_color + work_done( wait_window, 42) + + draw_brick( temp_window1, color, matrix2 := rotate_matrix( matrix1)) + image2 := transparentify( Capture( temp_window1, "c1", 0, 0, height, width)) + work_done( wait_window, 58) + + draw_brick( temp_window2, color, matrix3 := rotate_matrix( matrix2)) + image3 := transparentify( Capture( temp_window2, "c1", 0, 0, width, height)) + work_done( wait_window, 74) + + draw_brick( temp_window3, color, matrix4 := rotate_matrix( matrix3)) + image4 := transparentify( Capture( temp_window3, "c1", 0, 0, height, width)) + work_done( wait_window, 90) + + WClose( temp_window1) + WClose( temp_window2) + WClose( temp_window3) + work_done( wait_window, 95) + + return brick( brick_color, + &null, + [matrix1, matrix2, matrix3, matrix4], + [image1, image2, image3, image4]) +end + +############################################################################ +# +# Procedure: edit_save +# Arguments: None. +# Returns : Nothing. +# +# This procedure saves the current brick to disk, first checking if the +# edit pane is empty. +# +############################################################################ + +procedure edit_save() + + if empty_pane() = YES then + Notice( editor_window, "Edit pane is empty, save aborted.") + else { + save_brick( editor_window) + saved := YES + } + return +end + +############################################################################ +# +# Procedure: change_color +# Arguments: None. +# Returns : Nothing. +# +# This procedure shows a text dialog box with buttons "Ok" and "Cancel", +# asking the user to enter a new brick color. +# If the entered color is invalid, the dialog reappears until a valid +# color is entered or cancel is pressed. +# If the color was valid, the global variable 'brick_color' is updated and +# the squares currently colored on the edit pane are updated to the new +# color. +# +############################################################################ + +procedure change_color() + + button_pressed := + TextDialog( editor_window, + ["Enter new color."], + ["Color:"], + [], + [20]) + + case button_pressed of { + "Okay" : { + if invalid( dialog_value[1]) then { + Notice( editor_window, + "Color must be one of the following:", + "yellow, red, blue, green, orange,", + "magenta, cyan or brown.") + change_color() + return + } + else { + brick_color := dialog_value[1] + if mutables = YES then { + Color( mutable_brick_color, brick_color) + Color( mutable_brick_color_light, "light-" || brick_color) + Color( mutable_brick_color_dark, "dark-" || brick_color) + } + else + draw_brick( edit_pane, brick_color, brick_matrix) + } + } + } + return +end + +############################################################################ +# +# Procedure: draw_mutable_square +# Arguments: r - Row number of square to be drawn. +# c - Column number of square to be drawn. +# window - Window in which the square is to be drawn. +# Returns : Nothing. +# +# This procedure draws a square using the current mutable color in the +# given window. +# A lighter and a darker shade of the base color is used to create a +# 3 dimensional effect. +# +############################################################################ + +procedure draw_mutable_square( r, c, window) + + Fg( window, mutable_brick_color) + FillRectangle( window, (c-1)*20, (r-1)*20, 20, 20) + Fg( window, mutable_brick_color_light) + DrawLine( window, (c-1)*20, (r-1)*20, (c*20)-1, (r-1)*20) + DrawLine( window, (c-1)*20, (r-1)*20+1, (c*20)-1, (r-1)*20+1) + DrawLine( window, (c-1)*20, (r-1)*20, (c-1)*20, (r*20)-1) + DrawLine( window, (c-1)*20+1, (r-1)*20, (c-1)*20+1, (r*20)-2) + Fg( window, mutable_brick_color_dark) + DrawLine( window, (c*20)-1, (r*20)-1, (c*20)-1, (r-1)*20+1) + DrawLine( window, (c*20)-2, (r*20)-1, (c*20)-2, (r-1)*20+2) + DrawLine( window, (c*20)-1, (r*20)-1, (c-1)*20+1, (r*20)-1) + DrawLine( window, (c*20)-1, (r*20)-2, (c-1)*20+2, (r*20)-2) + return +end + +############################################################################ +# +# Procedure: draw_square +# Arguments: r - Row number of square to be drawn. +# c - Column number of square to be drawn. +# window - Window in which the square is to be drawn. +# color - Color of square. +# Returns : Nothing. +# +# This procedure draws a square using the given color in the given window. +# A lighter and a darker shade of the base color is used to create a +# 3 dimensional effect. +# +############################################################################ + +procedure draw_square( r, c, window, color) + + Fg( window, color) + FillRectangle( window, (c-1)*20, (r-1)*20, 20, 20) + Fg( window, "light-" || color) + DrawLine( window, (c-1)*20, (r-1)*20, (c*20)-1, (r-1)*20) + DrawLine( window, (c-1)*20, (r-1)*20+1, (c*20)-1, (r-1)*20+1) + DrawLine( window, (c-1)*20, (r-1)*20, (c-1)*20, (r*20)-1) + DrawLine( window, (c-1)*20+1, (r-1)*20, (c-1)*20+1, (r*20)-2) + Fg( window, "dark-" || color) + DrawLine( window, (c*20)-1, (r*20)-1, (c*20)-1, (r-1)*20+1) + DrawLine( window, (c*20)-2, (r*20)-1, (c*20)-2, (r-1)*20+2) + DrawLine( window, (c*20)-1, (r*20)-1, (c-1)*20+1, (r*20)-1) + DrawLine( window, (c*20)-1, (r*20)-2, (c-1)*20+2, (r*20)-2) + return +end + +############################################################################ +# +# Procedure: erase_square +# Arguments: r - Row number of square to be erased. +# c - Column number of square to be erased. +# Returns : Nothing. +# +# This procedure is called when a square on the edit pane is to be erased +# due to a right button mouse-click event on it. +# The matrix of the current brick is updated, the appropriate foreground +# color for the grid is selected depending on if mutable colors are in use +# or not and the square is erased and the grid in that square is redrawn. +# +############################################################################ + +procedure erase_square( r, c) + + if mutables = YES then + Fg( edit_pane, mutable_grid_color) + else + Fg( edit_pane, "white") + + EraseArea( edit_pane, (c-1)*20, (r-1)*20, 20, 20) + if grid_status = ON then + DrawSegment( edit_pane, + (c-1)*20, (r-1)*20, (c-1)*20, (r-1)*20+19, + (c-1)*20, (r-1)*20, (c-1)*20+19, (r-1)*20) + return +end + +################################ CALLBACKS ################################# + +############################################################################ +# +# Procedure: edit_cb +# Arguments: vidget - Edit pane region. +# event - Event on the edit pane region. +# x - Mouse x-coordinate. +# y - Mouse y-coordinate. +# Returns : Nothing. +# +# This procedure is called if an event has occured on the edit pane region. +# Only left and right mouse-button press events are handled. +# The x and y coordinate are transformed into row and column numbers and +# checked if they are whithin the current brick size area (the area covered +# by the grid) on the edit pane. If not nothing happens. +# If they are valid, a square is colored as an effect of a left button +# press, and erased as an effect of a right button press. +# In either case, the current brick matrix is updated accordingly. +# 'saved' is set to 'NO' since the current brick has now changed. +# +############################################################################ + +procedure edit_cb( vidget, event, x, y) + + x := x-WAttrib( edit_pane, "dx")-1 + y := y-WAttrib( edit_pane, "dy")-1 + r := ctop( y) + c := ctop( x) + + if (r <= grid_height & c <= grid_width) then { + case event of { + &lpress : { + brick_matrix[r][c] := COLORED + if mutables = YES then + draw_mutable_square( r, c, edit_pane) + else + draw_square( r, c, edit_pane, brick_color) + } + &rpress : { + brick_matrix[r][c] := BLACK + erase_square( r, c) + } + } + saved := NO + } + return +end + +############################################################################ +# +# Procedure: editor_help_cb +# Arguments: vidget - Vidget id. +# value - A list, the menu item selected. +# Returns : Nothing. +# +# This procedure is called when a menu item on the help menu of the editor +# is selected. +# +############################################################################ + +procedure editor_help_cb( vidget, value) + + case value[1] of { + "How to edit" : how_to_edit() + "Menus" : file_menu() + } + return +end + +############################################################################ +# +# Procedure: file_cb +# Arguments: vidget - Vidget id. +# value - A list, the menu item selected. +# Returns : Nothing. +# +# This procedure is called when a menu item on the file menu of the editor +# is selected. +# If "New" was selected, a new brick dialog is shown, possibly prompting to +# save the current brick first. +# If "Open" was selected, an open brick dialog is shown, possibly prompting +# to save the current brick first. +# If "Save" was selected, a save brick dialog is shown. +# If "Quit" was selected, possibly prompting to save the current brick +# first, saved is unconditionally set to "YES" since when the editor is +# run the next time it is to be "brand new". Then, the stream of events +# are switched over to the htetris window which pending events are discarded. +# Then the editor window is hidden. +# +############################################################################ + +procedure file_cb( vidget, value) + + case value[1] of { + "New" : { + if saved = NO then save_prompt( editor_window) + edit_new() + } + "Open" : { + if saved = NO then save_prompt( editor_window) + edit_open() + } + "Save" : edit_save() + "Quit" : { + if saved = NO then save_prompt( editor_window) + saved := YES + root := htetris_vidgets["root"] + while get( Pending( htetris_window)) + WAttrib( editor_window, "canvas=hidden") + } + } + return +end + +############################################################################ +# +# Procedure: brick_cb +# Arguments: vidget - Vidget id. +# value - A list, the menu item selected. +# Returns : Nothing. +# +# This procedure is called when a menu item on the brick menu of the editor +# is selected. +# The only item is "Change color" so the color of the current brick is +# changed. +# +############################################################################ + +procedure brick_cb( vidget, value) + + case value[1] of { + "Change color" : change_color() + } + return +end + +############################################################################ +# +# Procedure: clear_cb +# Arguments: vidget - Vidget id. +# value - A list, the menu item selected. +# Returns : Nothing. +# +# This procedure is called when the button with the label "Clear" has been +# pressed. +# The brick matrix is reset by creating a new one of the same size. +# Then the whole edit pane is erased and if the grid was previously shown, +# it is redrawn in the appropriate foreground color. +# +############################################################################ + +procedure clear_cb( vidget, value) + + brick_matrix := new_matrix( grid_height, grid_width) + + EraseArea( edit_pane, 0, 0, + editor_vidgets["edit"].uw, editor_vidgets["edit"].uh) + + if grid_status = ON then + if mutables = YES then + draw_grid( mutable_grid_color) + else + draw_grid( "white") + else + if mutables = YES then + draw_grid( mutable_grid_color) + else + draw_grid( "black") + return +end + +############################################################################ +# +# Procedure: toggle_cb +# Arguments: vidget - Vidget id. +# value - A list, the menu item selected. +# Returns : Nothing. +# +# This procedure is called when the button with the label "Toggle grid" has +# been pressed. +# The grid is toggled by calling the appropriate procedure and update the +# global variable 'grid_status' accordingly depending on whether the grid +# is currently shown or not. +# +############################################################################ + +procedure toggle_cb( vidget, value) + + if grid_status == ON then { + remove_grid() + grid_status := OFF + } + else { + apply_grid() + grid_status := ON + } + return +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure editor_atts() + return ["size=216,276", "bg=gray-white", "label=Brick editor"] +end + +procedure editor(win, cbk) +return vsetup(win, cbk, + ["editor:Sizer:::0,0,216,276:Brick editor",], + ["brick:Menu:pull::36,0,43,21:Brick",brick_cb, + ["Change color"]], + ["clear:Button:regular::6,240,90,30:Clear",clear_cb], + ["editor_help:Menu:pull::79,0,36,21:Help",editor_help_cb, + ["How to edit","Menus"]], + ["editor_menubar:Line:::0,22,212,22:",], + ["file:Menu:pull::0,0,36,21:File",file_cb, + ["New","Open","Save","Quit"]], + ["toggle:Button:regular::119,240,90,30:Toggle grid",toggle_cb], + ["edit:Rect:raised::6,30,204,204:",edit_cb], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/htetris/help.icn b/ipl/gpacks/htetris/help.icn new file mode 100644 index 0000000..467313a --- /dev/null +++ b/ipl/gpacks/htetris/help.icn @@ -0,0 +1,340 @@ +############################################################################ +# +# File : htetris.icn +# Author: Henrik Sandin +# Date : May 3, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedure for displaying the help texts in the +# htetris application and the brick editor. +# +############################################################################ + +procedure game_menu() + + button_pressed := + TextDialog( htetris_window, + ["The Game menu.", + "", + " New game:", + " Starts a new game regardless of whether a game is already", + " in progress or not. This can also be acheived by the", + " keyboard shortcut meta-n or by pressing the New game button", + " on the interface. If a game is in progress, a possible", + " highscore is lost.", + "", + " Stop game:", + " Stops a game in progress. This can also be acheived by the", + " keyboard shortcut meta-s or by pressing the Stop game", + " button on the interface. A possible highscore is lost.", + "", + " Pause:", + " Pauses a game in progress. This can also be acheived by the", + " keyboard shortcut meta-p or by pressing the Pause button on", + " the interface. The game is resumed by repeating this action.", + "", + " Speed factor:", + " This option lets the user specify a number between -10 and", + " 10 which makes the application run faster or slower.", + " A negative number makes the application slow down and a", + " positive number makes the application go faster.", + " This can be used if the current hardware is too fast or too slow.", + " This option is not availible when a game is in progress.", + "", + " Pick level:", + " This option lets the user specify a difficulty level between", + " one and fifteen at which the next game is to be started.", + " This option is not availible when a game is in progress.", + "", + " Quit:", + " This exits the htetris application. This can also be", + " acheived by the keyboard shortcut meta-q or by pressing the", + " Quit button on the interface. If a game is in progress, a", + " possible highscore is lost."], + [], + [], + [], + ["Previous", "Next", "Exit"], + 0) + + case button_pressed of { + "Previous" : htetris_help_menu() + "Next" : controls_menu() + } + return +end + +procedure controls_menu() + + button_pressed := + TextDialog( htetris_window, + ["The Controls menu.", + "", + " Set keys:", + " This option lets the user specify which keys to use for game", + " control. Valid keys are: Any character or any special key", + " which synonym is displayed in the separate popup window.", + " Any of these synonyms can be specified.", + "", + " Current keys:", + " This option shows which keys are currently used for game", + " control."], + [], + [], + [], + ["Previous", "Next", "Exit"], + 0) + + case button_pressed of { + "Previous" : game_menu() + "Next" : bricks_menu() + } + return +end + +procedure bricks_menu() + + button_pressed := + TextDialog( htetris_window, + ["The Bricks menu.", + "", + " Add brick:", + " This option lets the user add a user defined brick to the", + " game by loading it from a file created with the editor which", + " is described in Brick editor. This can also be acheived by", + " the keyboard shortcut meta-a. If the brick is added", + " successfully, the user is given an id for the brick which", + " should be used if the brick is going to be removed from the", + " game again. The added brick will appear in every game from", + " here on until it is removed or the application is closed.", + "", + " Remove brick:", + " If any user defined bricks are currently in the game, this", + " option lets the user remove such bricks. This means that", + " they are not going to appear in any game from here on unless", + " they are added again by selecting Add brick.", + " This can also be acheived by the keyboard shortcut meta-r.", + "", + " Bricks in use:", + " This option lets the user display user defined bricks in", + " play if there are any. The user is prompted to enter one of", + " the listed brick id's and in doing so, that brick is", + " displayed in a popup window. The dialog reappears until", + " Cancel is pressed. Thus, several user bricks can be viewed", + " simultanously.", + "", + " Brick editor:", + " This starts up the brick editor in which a user can create", + " his/hers own bricks to use in the game. This can also be", + " acheived by the keyboard shortcut meta-e. The editor is", + " described in detail in Brick editor."], + [], + [], + [], + ["Previous", "Next", "Exit"], + 0) + + case button_pressed of { + "Previous" : controls_menu() + "Next" : htetris_help_menu() + } + return +end + +procedure htetris_help_menu() + + button_pressed := + TextDialog( htetris_window, + ["The Help menu.", + "", + " How to play:", + " This option displays information about how to play htetris.", + "", + " Menus:", + " This option displays the current information.", + "", + " About:", + " This option displays information about the application and", + " the author."], + [], + [], + [], + ["Previous", "Next", "Exit"], + 0) + + case button_pressed of { + "Previous" : bricks_menu() + "Next" : game_menu() + } + return +end + +procedure how_to_play() + + Notice( htetris_window, + "The game is a single player game and is played by moving differently", + "shaped bricks into positions so that they form an area as compact as", + "possible.", + "The bricks are falling down and can be moved left or right, rotated", + "counter clockwise and put directly into place in the current hori-", + "zontal position without waiting for them to fall all the way down.", + "The goal of the game is to acheive as many points as possible.", + "Points are gained by completing rows. That is, to place the bricks", + "so that rows without \"gaps\" are created. Twenty points are earned", + "for each completed row. If more than one row is completed by placing", + "a single brick, five poits extra per additional row are obtained.", + "A filled row disappears and everything built above it is shifted", + "down one row. The game is lost when the top of the building pane is", + "reached in such a way that the next upcoming brick can not be placed", + "in its initial position.", + "To help the player a little bit, the next upcoming brick is always", + "shown during a game in progress.", + "There is also a notion of difficulty levels which ranges from 1 to 15.", + "The higher the level number, the faster the bricks fall. The game", + "starts by default at level one and increases the level after twenty", + "rows have been completed.", + "A game can at any time be stopped, paused or restarted. If the current", + "score happens to be higher than the highscore, the highscore is not", + "updated. Also, the application can be closed at any time during a game.") + return +end + +procedure about_htetris() + + Notice( htetris_window, + "htetris v1.0 Copyright © 1999 Henrik Sandin, all rights reserved.", + "", + "This is the first version of htetris, a variant of the game Tetris.", + "It can be freely distributed without any kind of licence or", + "agreement with the author.") + Return +end + +procedure file_menu() + + button_pressed := + TextDialog( htetris_window, + ["The File menu.", + "", + " New:", + " Lets the user start editing a new brick of the chosen size", + " and color. A brick must be at least one by one and at most", + " ten by ten in size. Valid colors are: yellow, red, blue,", + " green, orange, magenta, cyan and brown.", + " When the user clicks Okay in the dialog box, an empty grid", + " of the given size shows up on the edit pane.", + "", + " Open:", + " If Open is selected, a dialog appears which prompts the user", + " for the filename of a previously saved brick. Brick files", + " always have the extension \".brk\" but this is not necessary", + " to include, although it is perfectly alright to do so.", + " If the file is valid and could be opened successfully, the", + " editor resets itself to the measurements and color of the", + " loaded brick and the brick appears with the grid on", + "", + " Save:", + " The user enters a filename in the shown dialog box and the", + " brick is saved under that name. If the extension .brk is not", + " added to the name, the editor automaticly adds it before", + " saving. If the user enter a name with characters after", + " \".brk\", those are discarded. Saving can not be performed", + " if there are no filled squares. If not all rows and columns", + " are used for the brick to be saved, the brick is stripped of", + " such empty rows and columns before it is saved. This does", + " not apply to empty rows and columns between filled squares,", + " only \"edge\" rows and columns are stripped off.", + "", + " Quit:", + " This closes the brick editor and returns focus to the", + " htetris application."], + [], + [], + [], + ["Previous", "Next", "Exit"], + 0) + + case button_pressed of { + "Previous" : editor_help_menu() + "Next" : brick_menu() + } + return +end + +procedure brick_menu() + + button_pressed := + TextDialog( htetris_window, + ["The Brick menu.", + "", + " Change color:", + " This changes the color of the currently edited brick in", + " place. From now on, this color is used to fill squares", + " unless color is changed again, a brick is loaded from file", + " or a new brick is started.", + " The same colors as mentioned above under New are valid."], + [], + [], + [], + ["Previous", "Next", "Exit"], + 0) + + case button_pressed of { + "Previous" : file_menu() + "Next" : editor_help_menu() + } + return +end + +procedure editor_help_menu() + + button_pressed := + TextDialog( htetris_window, + ["The Help menu.", + "", + " How to edit:", + " This option displays information on how to use the editor.", + "", + " Menus:", + " This option displays the current information."], + [], + [], + [], + ["Previous", "Next", "Exit"], + 0) + + case button_pressed of { + "Previous" : brick_menu() + "Next" : file_menu() + } + return +end + +procedure how_to_edit() + + Notice( htetris_window, + "htetris includes a brick editor where the user can create his/hers", + "own bricks and include them when playing the game. A brick consists", + "of squares, or tiles, which is the basic unit of measurement for a", + "brick. A brick must be at least one square and at mostten by ten", + "squares in size. Any rectangular format in between is allowed.", + "To fill a square on the edit pane, the user points the mouse at that", + "square and clicks the left mouse button. The right mouse button is used", + "to erase a filled square. Only one color per brick can be used.", + "The upper left corner of the currently edited brick resides in the upper", + "left corner of the edit pane. It is not possible to fill a square", + "outside the bounds of the current brick.", + "There is a grid which shows the bounds when it is shown. The grid can", + "be switched on and off by pressing the Toggle grid button on the", + "interface. The Clear button clears whatever filled squares there are,", + "but does not affect the grid. A brick can take on any shape, even", + "unconnected regions in the same brick.", + "A brick can be saved to file and previously saved bricks can be opened", + "and re-edited.") + return +end diff --git a/ipl/gpacks/htetris/highscore.dat b/ipl/gpacks/htetris/highscore.dat new file mode 100644 index 0000000..573541a --- /dev/null +++ b/ipl/gpacks/htetris/highscore.dat @@ -0,0 +1 @@ +0 diff --git a/ipl/gpacks/htetris/howto.html b/ipl/gpacks/htetris/howto.html new file mode 100644 index 0000000..a4021fd --- /dev/null +++ b/ipl/gpacks/htetris/howto.html @@ -0,0 +1,42 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<!--NewPage--> +<html> +<head> +<title>htetris documentation</title> +</head> +<body> +<h1> +<center>User Manual For htetris Version 1.0</center> +<center>Henrik Sandin 1999</center> +</h1> +<hr> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/htetrisdoc.html">Main page</a> +<h2>How to play</h2><br> +<font size="5"> +<b>htetris</b> is a variant of the old and well known game tetris. +The game is a single player game and is played by moving differently shaped +bricks into positions so that they form an area as compact as possible. +The bricks are falling down and can be moved left or right, rotated counter +clockwise and put directly into place in the current horizontal position +without waiting for them to fall all the way down.<br> +The goal of the game is to acheive as many points as possible. Points are +gained by completing rows. That is, to place the bricks so that rows without +"gaps" are created. Twenty points are earned for each completed row. +If more than one row is completed by placing a single brick, five poits +extra per additional row are obtained.<br> +A filled row disappears and everything built above it is shifted down one row. +The game is lost when the top of the building pane is reached in such a way +that the next upcoming brick can not be placed in its initial position. +To help the player a little bit, the next upcoming brick is always +shown during a game in progress.<br> +There is also a notion of difficulty levels which ranges from 1 to 15. +The higher the level number, the faster the bricks fall. The game starts +by default at level one and increases the level after twenty rows have +been completed.<br> +A game can at any time be stopped, paused or restarted. If the current +score happens to be higher than the highscore, the highscore is not +updated. Also, the application can be closed at any time during a game.<br> +<br> +</font> +</body> +</html> diff --git a/ipl/gpacks/htetris/htetris.icn b/ipl/gpacks/htetris/htetris.icn new file mode 100644 index 0000000..a7611db --- /dev/null +++ b/ipl/gpacks/htetris/htetris.icn @@ -0,0 +1,1783 @@ +############################################################################ +# +# File : htetris.icn +# Author: Henrik Sandin +# Date : May 3, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Implements htetris, which is a version of the game tetris. +# The interface is built using the tool VIB. +# Bricks and the game pane are represented by two dimensional matrices. +# Conceptually, the brick matrices moves on top of the pane matrix. +# At every position, a brick matrix contains information on where on the +# pane matrix it is. +# An element of a matrix correspons to a 20 by 20 pixel square on the +# game pane. The game pane is 200 pixels wide and 600 pixels high, but its +# matrix has 12 colums and 31 rows. The extra row and columns are conceptually +# outside the game pane and serves as boundaries used to determine if a brick +# can move or rotate in some situations. +# An element in the pane matrix has the value 'FILLED' if there is a colored +# square belonging to a brick permanently stuck there. Otherwise it has the +# value 'EMPTY'. +# A brick can not move onto a position on the pane corresponding to an +# element in the pane matrix that has the value 'FILLED'. +# +############################################################################ +# +# Requires: keysyms.icn, brickdata.icn, matrix.icn, brickio.icn, +# editor.icn, help.icn +# +############################################################################ +# +# Links: random, numbers, vsetup +# +############################################################################ + +link random +link numbers +link vsetup + +############################################################################ +# +# Global varibles used by both htetris.icn and editor.icn. +# +############################################################################ + +global htetris_window +global htetris_vidgets + +############################################################################ +# +# Global varibles used by htetris.icn only. +# +# game_pane - The game playing area, which is 200 by 600 pixels. +# next_pane - The pane showing the next brick about to come up. +# anim_pane - The area where the initial animation is performed. +# score_pane - The current score area. +# highscore_pane - The highscore area. +# level_pane - The area showing the current level of difficulty. +# The showed level is either the most recently played level +# or the most recently picked starting level. +# brick_table - A table containing the bricks currently in play. +# The keys are unique names as strings. +# next_brick - The next brick to come up in a game. +# current_matrices - List containing the four matrices of the currently +# falling brick. +# current_images - List containing the four images of the currently +# falling brick. +# pane_matrix - A 12 by 32 matrix representing the game area. There are one +# extra row (bottom) and two extra columns used as edge markers. +# top_row - The currently highest (smallest row number) non-empty row +# in the pane matrix. +# rows_completed - The number of full rows achieved in the current game. +# flip_offset - A brick-specific integer which is used to calculate the +# new top-left corner position of a brick when it is flipped. +# start_speed - The level-depending speed which the next game is going to +# start at. +# speed - The current level-depending speed. +# speed_factor - Integer used to speed up the game on a slow computer. +# score - Current score. +# highscore - Highscore so far. +# next_id - Used to construct id's for added userdefined bricks. +# editor_on - Flag determining whether the editor was started or not. +# game_on - Flag determining whether a game is currently going on. +# pause - Flag determining whether a game is paused or not. +# cheated - TRUE if the player just cheated. Reset to false after cheat. +# cheating - TRUE if a cheating brick is currently falling. +# record_highscore - FALSE if the player has cheated during the current game. +# special_keys - A list of the possible special keys availible as controls. +# current_keys - current keys to control the game. +# root - The currently active interface root (htetris or editor). +# +############################################################################ + +global game_pane +global next_pane +global anim_pane +global score_pane +global highscore_pane +global level_pane +global brick_table +global current_matrices +global current_images +global next_brick +global next_id +global pane_matrix +global top_row +global rows_completed +global flip_offset +global start_speed +global speed +global speed_factor +global score +global highscore +global editor_on +global game_on +global pause +global cheated +global cheating +global record_highscore +global special_keys +global current_keys +global root + +$define MAX_SCORE 999999999 # Defines the maximum score. +$define MIDDLE 6 # Defines the middle column of the game pane. +$define FALSE 0 +$define TRUE 1 +$define EMPTY 0 # The status of a square on the game pane. +$define FILLED 1 # The status of a square on the game pane. +$define WIDTH 12 # The width of the game pane matrix. +$define HEIGHT 31 # The height of the game pane matrix. +$define RIGHT_EDGE 12 # The rightmost column of the game pane matrix. +$define BOTTOM 31 # The bottom row of the game pane matrix. +$define RIGHT 1 # Move brick to the right. +$define LEFT 2 # Move brick to the left. +$define ROTATE 3 # Rotate brick. +$define SLAM 4 # Bring brick down instantly. +$define SPEED_UP 10 # The speedup when a new level is begun. +$define THRESH_HOLD 20 # Number of rows to complete before level switch. +$define ANIM_DELAY 20 # Delay in initial animation. +$define MIN_SPEED 150 # Minimum game speed (level 1). +$define MAX_SPEED 10 # Maximum game speed (level 15). + +$include "keysyms.icn" +$include "brickdata.icn" +$include "matrix.icn" +$include "brickio.icn" +$include "movement.icn" +$include "help.icn" +$include "editor.icn" + +############################################################################ +# +# Record: brick +# Fields: color - The color of the brick in string format. +# offset - The rotation offset of this brick. +# matrices - The four matrices of this brick. +# images - The four imagestrings of this brick. +# +# This record represents a brick and stores data to use it in a game. +# The rotation offset depends on the shape of the brick and determines +# where, relative to the current upper-left corner, the new upper-left +# corner is going to be when the brick is rotated. +# 'matrices' and 'images' are two lists containing corresponding matrices +# and image strings. +# +############################################################################ + +record brick( color, offset, matrices, images) + +############################################################################ +# +# Record: position +# Fields: row_nr - Row number within the game pane matrix. +# col_nr - Column number within the game pane matrix. +# transparent - Flag determining if this square is transparent or not. +# +# This record represents the position and status of each square in a brick on +# the game pane. When a brick is falling, its matrix consists of 'position'- +# records describing where within the larger game pane matrix each one of its +# squares are positioned at the moment. +# +############################################################################ + +record position( row_nr, col_nr, transparent) + +############################################################################ +# +# Procedure: main +# Arguments: None. +# Returns : Nothing. +# +# This procedure starts the htetris application and the brick editor. +# If the brick editor could not be started properly it won't be used. +# The the event loop is entered. The htetris and the brick editor are +# "mutually exclusive". If the editor is in use, htetris does not +# accept any user events and when htetris is in use, the editor is +# not availible. +# +############################################################################ + +procedure main() + + start_htetris() + if start_editor() then + editor_on := TRUE + else + editor_on := FALSE + + repeat { + if root === htetris_vidgets["root"] then + game() + else + edit() + } +end + +############################################################################ +# +# Procedure: start_htetris +# Arguments: None. +# Returns : Nothing. +# +# This procedure starts the htetris application. +# Its window is opened and the different regions on the interface are +# initialized. +# Event root vidget is set to the htetris window. +# The original bricks are initialized by calling 'init_bricks' and put +# them in a global table. +# A Control keys table is created and initialized with the arrow keys. +# A global list of synonyms for valid special control keys is also +# initialized. +# Then the game pane matrix is created and various status variables used +# when playing the game are initialized. +# The score and highscore are written on the interface, the highscore +# possibly read from a file. The highscore is set to zero if the file +# could not be opened. +# The level display pane is initialized as well. +# Last of all, an initial animation is performed on the animation pane. +# +############################################################################ + +procedure start_htetris() + + randomize() + + (htetris_window := WOpen ! htetris_atts()) | + stop( "Can't open htetris window.") + htetris_vidgets := htetris( htetris_window) + + game_pane := Clone( htetris_window, "bg=black", + "dx=" || htetris_vidgets["playfield"].ux, + "dy=" || htetris_vidgets["playfield"].uy) + next_pane := Clone( htetris_window, + "dx=" || htetris_vidgets["next"].ux, + "dy=" || htetris_vidgets["next"].uy) + anim_pane := Clone( htetris_window, + "dx=" || htetris_vidgets["animation"].ux, + "dy=" || htetris_vidgets["animation"].uy) + score_pane := Clone( htetris_window, + "dx=" || htetris_vidgets["score"].ux, + "dy=" || htetris_vidgets["score"].uy) + highscore_pane := Clone( htetris_window, + "dx=" || htetris_vidgets["highscore"].ux, + "dy=" || htetris_vidgets["highscore"].uy) + level_pane := Clone( htetris_window, + "dx=" || htetris_vidgets["level"].ux, + "dy=" || htetris_vidgets["level"].uy) + + Clip( game_pane, 0, 0, + htetris_vidgets["playfield"].uw, htetris_vidgets["playfield"].uh) + Clip( next_pane, 0, 0, + htetris_vidgets["next"].uw, htetris_vidgets["next"].uh) + Clip( anim_pane, 0, 0, + htetris_vidgets["animation"].uw, htetris_vidgets["animation"].uh) + Clip( score_pane, 0, 0, + htetris_vidgets["score"].uw, htetris_vidgets["score"].uh) + Clip( highscore_pane, 0, 0, + htetris_vidgets["highscore"].uw, htetris_vidgets["highscore"].uh) + Clip( level_pane, 0, 0, + htetris_vidgets["level"].uw, htetris_vidgets["level"].uh) + + EraseArea( game_pane) + + root := htetris_vidgets["root"] + + brick_table := init_bricks() + next_id := "1" + + current_keys := table() + current_keys[RIGHT] := Key_Right + current_keys[LEFT] := Key_Left + current_keys[ROTATE] := Key_Up + current_keys[SLAM] := Key_Down + special_keys := + ["print screen","scroll lock","pause","insert","home","page up","end", + "page down","arrow left","arrow up","arrow right","arrow down","F1", + "F2","F3","F4","F5","F6","F7","F8","F9","F10","F11","F12","backspace", + "delete","escape","form feed","line feed","newline","return","tab", + "vertical space"] + + pane_matrix := new_matrix( HEIGHT, WIDTH) + game_on := FALSE + pause := FALSE + start_speed := MIN_SPEED + speed_factor := 1 + + Font( level_pane, "lucidasanstypewriter-bold-24") + Font( score_pane, "lucidasanstypewriter-bold-24") + Font( highscore_pane, "lucidasanstypewriter-bold-24") + + DrawString( score_pane, 2, 20, "000000000") + highscore_file := open( "highscore.dat") + if /highscore_file then { + highscore := 0 + DrawString( highscore_pane, 2, 20, "000000000") + } + else if not integer( highscore_string := read( highscore_file)) | + *highscore_string > 9 then { + + highscore := 0 + DrawString( highscore_pane, 2, 20, "000000000") + close( highscore_file) + } + else { + highscore := integer( highscore_string) + DrawString( highscore_pane, 2, 20, right( highscore_string, 9, "0")) + close( highscore_file) + } + + DrawString( level_pane, 2, 20, + right( string( (MIN_SPEED - start_speed)/10 + 1), 2, "0")) + animate() + return +end + +############################################################################ +# +# Procedure: close_htetris +# Arguments: None. +# Returns : Nothing. +# +# This procedure closes down the brick editor if it was started, possibly +# saving the highscore to a file, closes the htetris application window and +# exits the program altogether. +# +############################################################################ + +procedure close_htetris() + + if editor_on = TRUE then kill_editor() + + highscore_file := open( "highscore.dat", "ct") + if /highscore_file then + Notice( htetris_window, + "Could not open highscore-file, highscore unsaved.") + else + write( highscore_file, string( highscore)) + + close( highscore_file) + WClose( htetris_window) + exit() +end + +############################################################################ +# +# Procedure: game +# Arguments: None. +# Returns : Nothing. +# +# This is the game loop that plays the game. +# If the flag 'game_on' equals 'TRUE', and there are events pending, events +# corresponding to the current control keys are checked for and appropriate +# procedures are called in case of such an event. If a cheating brick is +# currently falling, move right, left and rotating will not work. +# If no control event was found, other events are processed and the current +# brick keeps falling. +# If the 'game_on' flag equals 'FALSE', events in general are processed +# and the procedure returns. +# If a certain amount of rows has been completed, the game speeds up +# ie. advances one level. +# +############################################################################ + +procedure game() + + while game_on = TRUE do { + every 1 to ceil(speed / speed_factor) do { + if (*Pending( htetris_window) > 0) then { + event := pop( Pending()) + value1 := pop( Pending()) + value2 := pop( Pending()) + case event of { + current_keys[RIGHT] : { + if cheating = FALSE & + can_move_right( current_matrices[1]) then + move_right( game_pane, current_matrices[1]) + } + current_keys[LEFT] : { + if cheating = FALSE & + can_move_left( current_matrices[1]) then + move_left( game_pane, current_matrices[1]) + } + current_keys[ROTATE] : { + if cheating = FALSE then + flip() + } + current_keys[SLAM] : { + slam() + if game_on = FALSE then break next + } + default : { + push( Pending(), value2, value1, event) + ProcessEvent( root, , shortcuts) + } + } + } + } + while pause = TRUE do ProcessEvent( root, , shortcuts) + if game_on = FALSE then next + fall() + if rows_completed > THRESH_HOLD & speed > MAX_SPEED then { + speed := speed - SPEED_UP + rows_completed := 0 + EraseArea( level_pane) + DrawString( level_pane, 2, 20, + right( string( (MIN_SPEED - speed)/10 + 1), 2, "0")) + } + } + ProcessEvent( root, , shortcuts) + return +end + +############################################################################ +# +# Procedure: set_positions +# Arguments: matrix - Matrix to be initialized. +# first_row - Row of "background" matrix. +# first_col - Column of "background" matrix. +# Returns : matrix - Updated matrix. +# +# This procedure initializes a brick matrix with pane matrix "background" +# positions, by traversing the given matrix. The top left element is set +# to the given row, column position and all other elements are initialized +# from there. +# +############################################################################ + +procedure set_positions( matrix, first_row, first_col) + + new_row := first_row + every r := 1 to *matrix do { + new_col := first_col + every c := 1 to *matrix[r] do { + matrix[r][c].row_nr := new_row + matrix[r][c].col_nr := new_col + new_col := new_col+1 + } + new_row := new_row+1 + } + return matrix +end + +############################################################################ +# +# Procedure: animate_brick +# Arguments: brick_rec - Data of brick to be moved. +# index - Index of matrix and image to be used. +# start_row - Start row of upper left brick square. +# start_col - Start column of upper left brick square. +# steps - The number of steps to move the brick. +# move_func - Function to move the brick with. +# Returns : Nothing. +# +# This procedure moves a given brick in the given direction the given +# number of steps on the animation pane, starting at the given position. +# The moving function can be 'move_left', 'move_right', 'move_down' or +# 'move_up'. +# Copies are made of the appropriate image and matrix which is then +# initialized. +# Although the brick matrix is initialized, there is no "background" matrix +# representing the animation pane. This is not needed since a brick is only +# to be moved a fixed number of steps and does not have to have a stop +# criterion depending on what is already on the pane. +# +############################################################################ + +procedure animate_brick( brick_rec, index, + start_row, start_col, steps, move_func) + + current_images := [brick_rec.images[index]] + current_matrices := [copy_matrix( brick_rec.matrices[index])] + matrix := set_positions( current_matrices[1], start_row, start_col) + DrawImage( anim_pane, + (matrix[1][1].col_nr-2)*20, + (matrix[1][1].row_nr-1)*20, + current_images[1]) + every 1 to steps do { + move_func( anim_pane, matrix) + WDelay( ANIM_DELAY) + } + return +end + +############################################################################ +# +# Procedure: animate +# Arguments: None. +# Returns : Nothing. +# +# This procedure performs an initial animation when htetris is started. +# +############################################################################ + +procedure animate() + + animate_brick( brick_table["brick_4"], 2, 7, 15, 7, move_left) + animate_brick( brick_table["brick_7"], 1, 7, 0, 6, move_right) + animate_brick( brick_table["brick_2"], 1, -2, 7, 6, move_down) + animate_brick( brick_table["brick_1"], 1, 5, 0, 5, move_right) + animate_brick( brick_table["brick_1"], 1, 4, 15, 7, move_left) + animate_brick( brick_table["brick_6"], 2, 8, 0, 4, move_right) + animate_brick( brick_table["brick_3"], 1, 14, 8, 5, move_up) + animate_brick( brick_table["brick_5"], 1, 5, 15, 6, move_left) + animate_brick( brick_table["brick_1"], 1, 14, 5, 4, move_up) + animate_brick( brick_table["brick_7"], 1, 6, 0, 4, move_right) + animate_brick( brick_table["brick_3"], 4, 0, 10, 4, move_down) + animate_brick( brick_table["brick_2"], 1, 14, 7, 5, move_up) + animate_brick( brick_table["brick_5"], 1, 9, 15, 6, move_left) + animate_brick( brick_table["brick_3"], 2, 11, -1, 5, move_right) + animate_brick( brick_table["brick_4"], 2, 4, -1, 5, move_right) + animate_brick( brick_table["brick_2"], 2, 8, 15, 6, move_left) + animate_brick( brick_table["brick_5"], 1, 14, 8, 3, move_up) + animate_brick( brick_table["brick_6"], 2, 9, 15, 4, move_left) + animate_brick( brick_table["brick_4"], 4, 14, 10, 3, move_up) + animate_brick( brick_table["brick_1"], 1, 6, 15, 4, move_left) + + shades := ["gray","dark-gray","black"] + every 1 to 3 do { + Fg( anim_pane, pop( shades)) + FillRectangle( anim_pane, 120, 100, 20, 20) + WDelay( 4*ANIM_DELAY) + } + return +end + +############################################################################ +# +# Procedure: full_row +# Arguments: r - A row number in the game pane matrix. +# Returns : Nothing. +# +# This procedure determines if a matrix row is the game pane matrix is +# filled or not. If it's not, the procedure fails. +# +############################################################################ + +procedure full_row( r) + + every c := 2 to 11 do + if pane_matrix[r][c] = EMPTY then + fail + return +end + +############################################################################ +# +# Procedure: erase_row +# Arguments: r - A row number in the game pane matrix. +# Returns : Nothing. +# +# This procedure erases the given matrix row on the game pane by drawing +# 20 consecutive black lines. +# +############################################################################ + +procedure erase_row( r) + + first_line := (r-1)*20 # Calculate start pixel line from matrix row. + Fg( game_pane, "black") + + every line := first_line to first_line+19 do { + DrawLine( game_pane, 0, line, 199, line) + WDelay() + } + return +end + +############################################################################ +# +# Procedure: shift_pane_matrix +# Arguments: erased_row - A row number in the game pane matrix. +# Returns : Nothing. +# +# This procedure shifts the game pane matrix by moving all rows above the +# given row up to the top row one step "down". A blank row is inserted +# as replacement for the previous top row. +# +############################################################################ + +procedure shift_pane_matrix( erased_row) + + every r := erased_row to top_row+1 by -1 do + pane_matrix[r] := pane_matrix[r-1] + + blank := list( WIDTH, EMPTY) + blank[1] := FILLED + blank[RIGHT_EDGE] := FILLED + pane_matrix[top_row] := blank + return +end + +############################################################################ +# +# Procedure: shift_pane +# Arguments: r - A row number in the game pane matrix. +# Returns : Nothing. +# +# This procedure shifts the game pane down graphically by copying the area +# above the given matrix row up to and including the top row, down 20 pixels +# which is the height of one row. The previous top row is erased. +# +############################################################################ + +procedure shift_pane( r) + + upper_limit := (top_row-1)*20 + + CopyArea( game_pane, game_pane, + 0, upper_limit, 200, (r-1)*20 - upper_limit, + 0, upper_limit+20) + EraseArea( game_pane, 0, upper_limit, 200, 20) + return +end + +############################################################################ +# +# Procedure: add_score +# Arguments: nr_rows - Number of filled rows to get score from. +# Returns : Nothing. +# +# This procedure calculates and adds the score for the given number of +# simultanously filled rows to the total score. +# The score is 20 points per row, plus 5 bonus points for each extra row +# if there are more than one. +# The score "wraps around" at maximum score. +# The score showed on the interface is updated. +# +############################################################################ + +procedure add_score( nr_rows) + + score := score + nr_rows*20 + (nr_rows-1)*5 + + if score > MAX_SCORE then + score := score - MAX_SCORE + + score_string := right( score, 9, "0") + + EraseArea( score_pane) + DrawString( score_pane, 2, 20, score_string) + return +end + +############################################################################ +# +# Procedure: eliminate_rows +# Arguments: None. +# Returns : Nothing. +# +# This procedure determines how many rows that were filled by the last +# brick to get stuck by traversing the pane matrix top-down from the top +# row to the (conceptual) bottom. For each filled row, it is erased, and the +# pane matrix and the pane are shifted. +# If there were any filled rows, the total number of completed rows is up- +# dated and points are added to the current score. +# +############################################################################ + +procedure eliminate_rows() + + nr_full_rows := 0 + + every r := top_row to 30 do + if full_row( r) then { + nr_full_rows := nr_full_rows+1 + erase_row( r) + shift_pane_matrix( r) + shift_pane( r) + top_row := top_row+1 + } + if nr_full_rows > 0 then { + rows_completed := rows_completed + nr_full_rows + add_score( nr_full_rows) + } + return +end + +############################################################################ +# +# Procedure: get_stuck +# Arguments: None. +# Returns : Nothing. +# +# This procedure makes a brick stick to the pane and eliminates any rows +# that were filled as a consequence of this. +# If the position of the upper left square of the brick is higher than the +# current top row, the top row is updated. +# Then, for each element in the brick's matrix (which holds the position +# it is occupying in the pane matrix) the corresponding element in the +# pane matrix is set to the value 'FILLED'. This 'glues' the brick to the +# pane graphically and is reflected in the pane matrix. +# +############################################################################ + +procedure get_stuck() + + matrix := current_matrices[1] + + if matrix[1][1].row_nr < top_row then + top_row := matrix[1][1].row_nr + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + if matrix[r][c].transparent = FALSE then + pane_matrix[matrix[r][c].row_nr][matrix[r][c].col_nr] := FILLED + + eliminate_rows() + cheating := FALSE + return +end + +############################################################################ +# +# Procedure: create_cheat_matrix +# Arguments: None. +# Returns : Nothing. +# +# This procedure creates and returns a matrix representing a "cheat brick". +# This brick covers every empty square upto and one row above 'top row'. +# Only vertically connected empty squares are considered. +# The matrix is initialized with the appropriate game pane matrix positions. +# +############################################################################ + +procedure create_cheat_matrix() + + cheat_string := ";1111111111" + done := FALSE + + r := top_row + while done = FALSE do { + temp := ";" + every c := 2 to 11 do + if pane_matrix[r][c] = EMPTY & + cheat_string[(11*(r-top_row))+c] = 1 then + temp := temp || "1" + else + temp := temp || "0" + if temp == ";0000000000" then + done := TRUE + else { + cheat_string := cheat_string || temp + r := r+1 + } + } + cheat_matrix := stom( string( r-top_row+1) || ",10" || cheat_string) + + return set_positions( init_positions( cheat_matrix), 1, 2) +end + +############################################################################ +# +# Procedure: cheat +# Arguments: None. +# Returns : Nothing. +# +# This procedure sets 'current_matrices' and 'current_images' to the matrix +# and image of a dynamicly created "cheat brick" by creating a hidden window +# and draw the "cheat brick" in it by using the matrix and then transform it +# into a transparent imagestring. +# +############################################################################ + +procedure cheat() + + cheat_matrix := create_cheat_matrix() + if /(cheat_window := WOpen( "canvas=hidden", "bg=black", + "width=" || (*cheat_matrix[1])*20, + "height=" || (*cheat_matrix)*20)) then + write( "No cheating today, sucker!") + else { + old_pointer := WAttrib( htetris_window, "pointer") + if old_pointer == "left ptr" then + WAttrib( htetris_window, "pointer=watch") + else + WAttrib( htetris_window, "pointer=wait") + + every r := 1 to *cheat_matrix do + every c := 1 to *cheat_matrix[r] do + if cheat_matrix[r][c].transparent = EMPTY then + draw_square( r, c, cheat_window, "gray") + + current_matrices := [cheat_matrix, + cheat_matrix, + cheat_matrix, + cheat_matrix] + cheat_image := + transparentify( Capture( cheat_window, "c1", 0, 0, + WAttrib( cheat_window, "width"), + WAttrib( cheat_window, "height"))) + current_images := [cheat_image, + cheat_image, + cheat_image, + cheat_image] + WClose( cheat_window) + WAttrib( htetris_window, "pointer=" || old_pointer) + } + return +end + +############################################################################ +# +# Procedure: fetch_next +# Arguments: None. +# Returns : Nothing. +# +# This procedure fetches the next upcoming brick by setting the current +# matrices and images to those of the next brick. +# If the user has cheated, a dynamicly created "cheat brick" is fetched +# instead of the regular one which is fetched at the next call to +# 'fetch_next' providing the user did not cheat again. +# If the user hasn't cheated, the global variable 'next_brick' is updated +# with a randomly picked brick from the global brick table and that one is +# displayed on the "next pane". +# The start positions of every square of the next brick is checked against +# the pane matrix and if it is to be placed so that any filled square in it +# will cover a position in the pane matrix which value is 'FILLED' (another +# already stuck brick resides there) the game is over. +# Even when cheating the game might be over if a brick is stuck so that its +# top row is in the first row of the game pane because a cheating brick +# always has at least one row ten squares wide. +# If the game is over the highscore is possibly updated depending if the +# user cheated or not, the game pane is cleared and the procedure returns. +# If the game is not over, the next brick is drawn in its initial position. +# +############################################################################ + +procedure fetch_next() + + if cheated = TRUE then { + cheated := FALSE + cheat() + cheating := TRUE + } + else { + current_matrices := copy_matrices( next_brick.matrices) + current_images := copy( next_brick.images) + flip_offset := next_brick.offset + + next_brick := ?brick_table + width := *(next_brick.matrices[1][1]) + height := *(next_brick.matrices[1]) + + if width % 2 = 0 then + startx := (MIDDLE - width/2 - 1)*20 + else + startx := (MIDDLE - width/2 - 2)*20 + if height % 2 = 0 then + starty := (MIDDLE - height/2 - 1)*20 + else + starty := (MIDDLE - height/2 - 2)*20 + + EraseArea( next_pane) + DrawImage( next_pane, startx, starty, next_brick.images[1]) + } + matrix := current_matrices[1] + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + if matrix[r][c].transparent = FALSE & + pane_matrix[matrix[r][c].row_nr][matrix[r][c].col_nr] = + FILLED then { + if score > highscore & record_highscore = TRUE then { + highscore := score + EraseArea( highscore_pane) + DrawString( highscore_pane, 2, 20, + right( string( highscore), 9, "0")) + } + game_on := FALSE + black_out() + EraseArea( next_pane) + return + } + startx := (current_matrices[1][1][1].col_nr - 2)*20 + DrawImage( game_pane, startx, 0, current_images[1]) + return +end + +############################################################################ +# +# Procedure: init_pane_matrix +# Arguments: None. +# Returns : Nothing. +# +# This procedure initializes the game pane matrix. +# The leftmost and rightmost as well as the bottom row get all their +# elements set to 'FILLED'. This row and columns are conceptually "outside" +# the actual pane. This is convenient to make the falling bricks not to go +# off the pane graphically. +# All "interior" elements within the u-shaped border of 'FILLED' elements +# are set to 'EMPTY'. +# +############################################################################ + +procedure init_pane_matrix() + + every r := 1 to HEIGHT do + every c := 1 to WIDTH do + if r = BOTTOM | c = 1 | c = RIGHT_EDGE then + pane_matrix[r][c] := FILLED + else + pane_matrix[r][c] := EMPTY + return +end + +############################################################################ +# +# Procedure: black_out +# Arguments: None. +# Returns : Nothing. +# +# This procedure blanks out the game pane by drawing smaller and smaller +# gray and black rectangles until the middle is reached. +# The The whole pane is erased since the last drawn gray rectangle is on +# the pane. +# +############################################################################ + +procedure black_out() + + every x := 0 to htetris_vidgets["playfield"].uw/2 do { + Fg( game_pane, "dark-gray") + DrawRectangle( game_pane, x+1, x+1, + htetris_vidgets["playfield"].uw-2*(x+1), + htetris_vidgets["playfield"].uh-2*(x+1)) + Fg( game_pane, "black") + DrawRectangle( game_pane, x, x, + htetris_vidgets["playfield"].uw-2*x, + htetris_vidgets["playfield"].uh-2*x) + WDelay( game_pane) + } + EraseArea( game_pane) + return +end + +############################################################################ +# +# Procedure: valid_synonym +# Arguments: key_string - A synonym for a special key. +# Returns : Nothing. +# +# This procedure determines if a given synonym corresponds to a valid +# special key. +# +############################################################################ + +procedure valid_synonym( key_string) + + case key_string of { + special_keys[1] : return Key_PrSc + special_keys[2] : return Key_ScrollLock + special_keys[3] : return Key_Pause + special_keys[4] : return Key_Insert + special_keys[5] : return Key_Home + special_keys[6] : return Key_PgUp + special_keys[7] : return Key_End + special_keys[8] : return Key_PgDn + special_keys[9] : return Key_Left + special_keys[10] : return Key_Up + special_keys[11] : return Key_Right + special_keys[12] : return Key_Down + special_keys[13] : return Key_F1 + special_keys[14] : return Key_F2 + special_keys[15] : return Key_F3 + special_keys[16] : return Key_F4 + special_keys[17] : return Key_F5 + special_keys[18] : return Key_F6 + special_keys[19] : return Key_F7 + special_keys[20] : return Key_F8 + special_keys[21] : return Key_F9 + special_keys[22] : return Key_F10 + special_keys[23] : return Key_F11 + special_keys[24] : return Key_F12 + special_keys[25] : return "\b" + special_keys[26] : return "\d" + special_keys[27] : return "\e" + special_keys[28] : return "\f" + special_keys[29] : return "\l" + special_keys[30] : return "\n" + special_keys[31] : return "\r" + special_keys[32] : return "\t" + special_keys[33] : return "\v" + } + return +end + +############################################################################ +# +# Procedure: ktos +# Arguments: key_value - The value returned from a keypress event. +# Returns : Nothing. +# +# This procedure returns a string representation of the given key value. +# +############################################################################ + +procedure ktos( key_value) + + case key_value of { + Key_PrSc : return special_keys[1] + Key_ScrollLock : return special_keys[2] + Key_Pause : return special_keys[3] + Key_Insert : return special_keys[4] + Key_Home : return special_keys[5] + Key_PgUp : return special_keys[6] + Key_End : return special_keys[7] + Key_PgDn : return special_keys[8] + Key_Left : return special_keys[9] + Key_Up : return special_keys[10] + Key_Right : return special_keys[11] + Key_Down : return special_keys[12] + Key_F1 : return special_keys[13] + Key_F2 : return special_keys[14] + Key_F3 : return special_keys[15] + Key_F4 : return special_keys[16] + Key_F5 : return special_keys[17] + Key_F6 : return special_keys[18] + Key_F7 : return special_keys[19] + Key_F8 : return special_keys[20] + Key_F9 : return special_keys[21] + Key_F10 : return special_keys[22] + Key_F11 : return special_keys[23] + Key_F12 : return special_keys[24] + } + key_string := string( key_value) + case key_string of { + "\b" : return special_keys[25] + "\d" : return special_keys[26] + "\e" : return special_keys[27] + "\f" : return special_keys[28] + "\l" : return special_keys[29] + "\n" : return special_keys[30] + "\r" : return special_keys[31] + "\t" : return special_keys[32] + "\v" : return special_keys[33] + } + return key_string +end + +############################################################################ +# +# Procedure: key_value +# Arguments: None. +# Returns : specials - A window. +# +# This procedure opens and returns a window containing a list of synonyms +# for valid special keys. Null is returned if the window could not be +# opened. +# +############################################################################ + +procedure specials_window() + + if specials := WOpen( "label=htetris", "size=120,550", + "posx=" || WAttrib( htetris_window, "posx")-60, + "posy=" || WAttrib( htetris_window, "posy")+60, + "bg=gray-white") then { + + Font( specials, Font( htetris_window)) + DrawString( specials, 10, 20, "Special keys:") + y := 60 + every special := 1 to *special_keys do { + DrawString( specials, 10, y, special_keys[special]) + y := y+15 + } + } + else write( "List of special keys could not be shown.") + return specials +end + +############################################################################ +# +# Procedure: select_keys +# Arguments: None. +# Returns : Nothing. +# +# This procedure shows a text dialog with buttons "Okay" and "Cancel", which +# prompts for new control keys to be entered. Valid keys are any charachter +# or a synonym from the 'special_keys' list. +# If one or more of the enterd values are invalid, an error message is +# shown and the dialog reappears. If cancel is pressed the dialog dis- +# appears. +# The global variables containing the current key settings are updated. +# +############################################################################ + +procedure select_keys() + + button_pressed := + TextDialog( htetris_window, + ["Enter control keys."], + ["Move right:", "Move Left:", "Rotate:", "Slam down:"], + [], + [14, 14, 14, 14]) + + case button_pressed of { + "Okay" : { + if *dialog_value[1] = 1 then + right_value := dialog_value[1] + else { + right_value := valid_synonym( dialog_value[1]) + if /right_value then { + Notice( htetris_window, + "Invalid key specification \"" || + dialog_value[1] || + "\".") + select_keys() + return + } + } + + if *dialog_value[2] = 1 then + left_value := dialog_value[2] + else { + left_value := valid_synonym( dialog_value[2]) + if /left_value then { + Notice( htetris_window, + "Invalid key specification \"" || + dialog_value[2] || + "\".") + select_keys() + return + } + } + + if *dialog_value[3] = 1 then + rotate_value := dialog_value[3] + else { + rotate_value := valid_synonym( dialog_value[3]) + if /rotate_value then { + Notice( htetris_window, + "Invalid key specification \"" || + dialog_value[3] || + "\".") + select_keys() + return + } + } + + if *dialog_value[4] = 1 then + slam_value := dialog_value[4] + else { + slam_value := valid_synonym( dialog_value[4]) + if /slam_value then { + Notice( htetris_window, + "Invalid key specification \"" || + dialog_value[4] || + "\".") + select_keys() + return + } + } + + current_keys[RIGHT] := right_value + current_keys[LEFT] := left_value + current_keys[ROTATE] := rotate_value + current_keys[SLAM] := slam_value + } + } + return +end + +############################################################################ +# +# Procedure: pick_level +# Arguments: None. +# Returns : Nothing. +# +# This procedure shows a text dialog with buttons "Okay" and "Cancel", which +# prompts for a new starting level. +# If the entered level was valid, the starting speed and the level pane +# are updated. Else, the dialog reappears until the user enters a valid +# level or presses cancel. +# +############################################################################ + +procedure pick_level() + + if game_on = FALSE then { + button_pressed := + TextDialog( htetris_window, + ["Enter starting level (1 - 15)."], + ["Level:"], + [string( (MIN_SPEED - start_speed)/10 + 1)], + [2]) + + case button_pressed of { + "Okay" : { + level := integer( dialog_value[1]) + if /level | level < 1 | level > 15 then { + Notice( htetris_window, "Invalid level specification.") + pick_level() + return + } + start_speed := (MIN_SPEED - (level-1)*10) + EraseArea( level_pane) + DrawString( level_pane, 2, 20, right( string( level), 2, "0")) + } + } + } + return +end + +############################################################################ +# +# Procedure: change_speed_factor +# Arguments: None. +# Returns : Nothing. +# +# This procedure shows a text dialog with buttons "Okay" and "Cancel", which +# prompts for a new speed factor between -10 and 10. A negative number slows +# the application down while a positive number speeds it up. If 0 was entered, +# the speed factor is set to 1. +# I the entered factor was valid, the global variable 'speed_factor' is +# updated. Else, the dialog reappears until the user enters a valid speed +# factor or presses cancel. +# +############################################################################ + +procedure change_speed_factor() + + if game_on = FALSE then { + button_pressed := + TextDialog( htetris_window, + ["Enter new speed factor (-10 - 10)."], + ["Speed factor:"], + [], + [3]) + + case button_pressed of { + "Okay" : { + factor := dialog_value[1] + if not integer( factor) | + factor < -10 | + factor > 10 then { + + Notice( htetris_window, "Invalid speed factor.") + change_speed_factor() + return + } + if factor = 0 then + speed_factor = 1 + else if factor < 0 then + speed_factor := 1.0/(-factor) + else + speed_factor := factor + } + } + } + return +end + +############################################################################ +# +# Procedure: new_game +# Arguments: None. +# Returns : Nothing. +# +# This procedure starts a new game at the current starting speed. +# The game pane is cleared and initialized and the next brick is fetched. +# Setting the global variable 'game_on' to 'TRUE' makes the program go into the +# game loop after this procedure has returned. +# +############################################################################ + +procedure new_game() + + EraseArea( game_pane) + EraseArea( score_pane) + EraseArea( level_pane) + DrawString( score_pane, 2, 20, "000000000") + DrawString( level_pane, 2, 20, + right( string( (MIN_SPEED - start_speed)/10 + 1), 2, "0")) + init_pane_matrix() + randomize() + speed := start_speed + rows_completed := 0 + score := 0 + game_on := TRUE + pause := FALSE + cheated := FALSE + cheating := FALSE + record_highscore := TRUE + top_row := BOTTOM + next_brick := ?brick_table + fetch_next() + return +end + +############################################################################ +# +# Procedure: stop_game +# Arguments: None. +# Returns : Nothing. +# +# This procedure stops a running game and blanks out the game pane. +# If no game is running, nothing happens. +# +############################################################################ + +procedure stop_game() + + if game_on = FALSE then + return + + game_on := FALSE + black_out() + EraseArea( next_pane) + return +end + +############################################################################ +# +# Procedure: pause_game +# Arguments: None. +# Returns : Nothing. +# +# This procedure pauses a running game. If the game is paused, it is resumed. +# If a game is not in progress, nothing happens. +# +############################################################################ + +procedure pause_game() + + if game_on = TRUE then + if pause = TRUE then + pause := FALSE + else + pause := TRUE + return +end + +############################################################################ +# +# Procedure: add_brick +# Arguments: None. +# Returns : Nothing. +# +# This procedure prompts for a brick to be opened from file and adds it +# to the currently used bricks. The opened brick gets a unique id which is +# used if the user wants to remove it or display it. +# If a game is in progress, nothing happens. +# +############################################################################ + +procedure add_brick() + + if game_on = FALSE then { + if /(added := open_brick( htetris_window)) then + return + added.matrices[1] := init_positions( added.matrices[1]) + added.matrices[2] := init_positions( added.matrices[2]) + added.matrices[3] := init_positions( added.matrices[3]) + added.matrices[4] := init_positions( added.matrices[4]) + + matrix := added.matrices[1] + + if *matrix = *matrix[1] then + added.offset := 0 + else if *matrix > *matrix[1] then + added.offset := ceil( abs( *matrix-*matrix[1])/2) + else + added.offset := -(ceil( abs( *matrix-*matrix[1])/2)) + + brick_table["user_" || next_id] := added + Notice( htetris_window, + "Brick successfully added.", + "Brick id is 'user_" || next_id ||"'.") + next_id := string( integer( next_id) + 1) + } + return +end + +############################################################################ +# +# Procedure: standard +# Arguments: None. +# Returns : Nothing. +# +# This procedure determines if a brick id entered by a user in a dialog +# is the name of one of the standard brick. +# This is a security check so that none of the original bricks get removed +# and all brick names stay unique. +# +############################################################################ + +procedure standard( brick_id) + + standard_bricks := set( ["brick_1","brick_2","brick_3","brick_4", + "brick_5","brick_6","brick_7"]) + + return member( standard_bricks, brick_id) +end + +############################################################################ +# +# Procedure: remove_brick +# Arguments: None. +# Returns : Nothing. +# +# If there are user defined bricks in play (the total number is greater +# than seven), this procedure shows a text dialog box with buttons "Okay" +# and "Cancel", prompting the user to enter a user defined brick to be +# removed from the game. +# If no brick with the specified id is in use, the dialog reappears until +# the user enters a valid one or presses cancel. +# If a brick with the entered id is in use, it is deleted from the global +# table of bricks. +# If a game is in progress, nothing happens. +# +############################################################################ + +procedure remove_brick() + + if game_on = FALSE then { + if *brick_table = 7 then { + Notice( htetris_window, "No user defined bricks in play.") + return + } + button_pressed := + TextDialog( htetris_window, + ["Enter id of brick to remove."], + ["Id:"], + [], + [20]) + + case button_pressed of { + "Okay" : { + id := dialog_value[1] + if standard( id) | /brick_table[id] then { + Notice( htetris_window, + "Brick '" || id || "' is not in use.") + remove_brick() + return + } + delete( brick_table, id) + Notice( htetris_window, "Brick '" || id || "' removed.") + } + } + } + return +end + +############################################################################ +# +# Procedure: display_bricks +# Arguments: None. +# Returns : Nothing. +# +# If there are any user defined bricks in play, their ids are shown in a +# text dialog box with buttons "Okay" and "Cancel", prompting the user +# to enter one of the ids displayed. +# If this is done correctly, the brick corresponding to the given id is +# displayed in a popup window. +# The popup windows are open and the dialog reappears until the user +# presses cancel. Thus, several user bricks can be viewed simultanously. +# If a game is in progress, nothing happens. +# +############################################################################ + +procedure display_bricks() + + if game_on = FALSE then { + user_bricks := "" + every user_brick := key( brick_table) do + if not standard( user_brick) then + user_bricks := user_bricks || user_brick || "," + + if user_bricks == "" then { + Notice( htetris_window, "No user defined bricks in play.") + return + } + button_pressed := + TextDialog( htetris_window, + ["The following user bricks are in play:", + user_bricks, + "enter id of brick to view."], + ["Id:"], + [], + [20]) + + case button_pressed of { + "Okay" : { + id := dialog_value[1] + if standard( id) | /brick_table[id] then { + Notice( htetris_window, + "Brick '" || id || "' is not in use.") + display_bricks() + return + } + else { + brick := brick_table[id] + temp_window := + WOpen( "width=" || (*brick.matrices[1][1])*20, + "height=" || (*brick.matrices[1])*20, + "bg=black") | { + Notice( htetris_window, + "Image window could not be opened.") + return + } + DrawImage( temp_window, 0, 0, brick.images[1]) + display_bricks() + WClose( temp_window) + return + } + } + } + } + return +end + +############################################################################ +# +# Procedure: edit_bricks +# Arguments: None. +# Returns : Nothing. +# +# This procedure displays the brick editor initializes it and transfers +# event handling to its window. +# No events from the htetris application window are now accepted. +# If a game is in progress, nothing happens. +# +############################################################################ + +procedure edit_bricks() + + if game_on = FALSE then + if editor_on = TRUE then { + reset_editor( new_matrix( 3, 3), "yellow") + WAttrib( editor_window, "canvas=normal") + root := editor_vidgets["root"] + while get( Pending( editor_window)) + } + return +end + +############################################################################ +# +# Procedure: shortcuts +# Arguments: event - An event. +# Returns : Nothing. +# +# This procedure catches and processes keyboard shortcut events. +# +############################################################################ + +procedure shortcuts( event) + + if &meta then + case map( event) of { + "n" : new_game() + "s" : stop_game() + "p" : pause_game() + "q" : close_htetris() + "a" : add_brick() + "e" : edit_bricks() + } + return +end + +################################ CALLBACKS ################################# + +############################################################################ +# +# Procedure: game_cb +# Arguments: None. +# Returns : Nothing. +# +# This procedure handles events from the "Game" menu. +# +############################################################################ + +procedure game_cb( vidget, value) + + case value[1] of { + "New game @N" : new_game() + "Stop game @S" : stop_game() + "Pause @P" : pause_game() + "Speed factor" : change_speed_factor() + "Pick level" : pick_level() + "Quit @Q" : close_htetris() + } + return +end + +############################################################################ +# +# Procedure: controls_cb +# Arguments: None. +# Returns : Nothing. +# +# This procedure handles events from the "Controls" menu. +# If the "Set keys" item was selected, a window displaying valid special +# control keys and a dialog are opened. +# If the "Current keys" item was selected, the current key settings are +# displayed in a notice dialog. +# If a game is in progress, nothing happens. +# +############################################################################ + +procedure controls_cb( vidget, value) + + if game_on = FALSE then + case value[1] of { + "Set keys" : { + specials := specials_window() + select_keys() + if \specials then WClose( specials) + } + "Current keys" : { + Notice( htetris_window, + "Current key settings:", + "", + "Move right: " || ktos( current_keys[RIGHT]) || ".", + "Move left: " || ktos( current_keys[LEFT]) || ".", + "Rotate: " || ktos( current_keys[ROTATE]) || ".", + "Slam down: " || ktos( current_keys[SLAM]) || ".") + } + } + return +end + +############################################################################ +# +# Procedure: bricks_cb +# Arguments: None. +# Returns : Nothing. +# +# This procedure handles events from the "Bricks" menu. +# If a game is in progress, nothing happens. +# +############################################################################ + +procedure bricks_cb( vidget, value) + + if game_on = FALSE then + case value[1] of { + "Add brick @A" : add_brick() + "Remove brick @R" : remove_brick() + "Bricks in use" : display_bricks() + "Brick editor @E" : edit_bricks() + } + return +end + +############################################################################ +# +# Procedure: htetris_help_cb +# Arguments: None. +# Returns : Nothing. +# +# This procedure handles events from the "Help" menu of the htetris +# application window. +# If a game is in progress, nothing happens. +# +############################################################################ + +procedure htetris_help_cb( vidget, value) + + if game_on = FALSE then + case value[1] of { + "How to play" : how_to_play() + "Menus" : game_menu() + "About" : about_htetris() + } + return +end + +############################################################################ +# +# Procedure: buttons_cb +# Arguments: None. +# Returns : Nothing. +# +# This procedure handles events from the four convenience buttons on the +# interface. +# +############################################################################ + +procedure buttons_cb( vidget, value) + + case vidget.id of { + "new_game" : new_game() + "stop_game" : stop_game() + "pause" : pause_game() + "quit" : close_htetris() + } + return +end + +############################################################################ +# +# Procedure: animation_cb +# Arguments: None. +# Returns : Nothing. +# +# This procedure handles events from the animation region. +# Only left mouse button clicks on a certain square are handled. +# If the user clicks there during a game, a cheat is going to take place +# instead of the next upcoming brick. +# +############################################################################ + +procedure animation_cb( vidget, event, x, y) + + if game_on = TRUE then { + x := x-WAttrib( anim_pane, "dx")-1 + y := y-WAttrib( anim_pane, "dy")-1 + r := ctop( y) + c := ctop( x) + + if (r = 6 & c = 7) then + case event of { + &lpress : { + cheated := TRUE + record_highscore := FALSE + } + } + } + return +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure htetris_atts() + return ["size=520,640", "bg=gray-white", "label=htetris"] +end + +procedure htetris(win, cbk) +return vsetup(win, cbk, + ["htetris:Sizer:::0,0,520,640:htetris",], + ["bricks:Menu:pull::100,0,50,21:Bricks",bricks_cb, + ["Add brick @A","Remove brick @R","Bricks in use","Brick editor @E"]], + ["controls:Menu:pull::36,0,64,21:Controls",controls_cb, + ["Set keys","Current keys"]], + ["game:Menu:pull::0,0,36,21:Game",game_cb, + ["New game @N","Stop game @S","Pause @P","Speed factor","Pick level", + "Quit @Q"]], + ["highscore_label:Label:::90,312,70,13:Highscore:",], + ["htetris_help:Menu:pull::150,0,36,21:Help",htetris_help_cb, + ["How to play","Menus","About"]], + ["level_label:Label:::27,191,42,13:Level:",], + ["menubar:Line:::0,22,520,22:",], + ["new_game:Button:regular::6,30,75,30:New game",buttons_cb], + ["next_label:Label:::150,30,77,13:Next brick:",], + ["pause:Button:regular::6,102,75,30:Pause",buttons_cb], + ["quit:Button:regular::6,138,75,30:Quit",buttons_cb], + ["score_label:Label:::118,274,42,13:Score:",], + ["stop_game:Button:regular::6,66,75,30:Stop game",buttons_cb], + ["level:Rect:sunken::29,216,36,26:",], + ["highscore:Rect:sunken::164,306,134,26:",], + ["score:Rect:sunken::164,268,134,26:",], + ["next:Rect:grooved::94,51,204,204:",], + ["animation:Rect:invisible::25,356,260,260:",animation_cb], + ["playfield:Rect:raised::310,30,204,604:",], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/htetris/implement.html b/ipl/gpacks/htetris/implement.html new file mode 100644 index 0000000..9392390 --- /dev/null +++ b/ipl/gpacks/htetris/implement.html @@ -0,0 +1,63 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<!--NewPage--> +<html> +<head> +<title>htetris documentation</title> +</head> +<body> +<h1> +<center>User Manual For htetris Version 1.0</center> +<center>Henrik Sandin 1999</center> +</h1> +<hr> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/htetrisdoc.html">Main page</a> +<h2>Implementation details</h2><br> +<font size="5"> +The bricks are represented with matrix structures in the game as well as +the editor. An element in such a matrix represents one square in a brick. +A matrix is never larger than the actual rectangle which constitutes the +size of a brick which is measured in number of squares wide and high +respectively.<br> +In the editor, a brick-matrix consists of ones and zeros where a one +represents a colored square and a zero represents an uncolored (black, since +the backgroud of the edit pane is black) square. +A string representation of such matrices is used when they are saved to file.<br> +When a brick is used in the game, the brick-matrix elements plays a different +role. The area where the bricks fall also has a matrix representation where +every element, just like the brick matrices in the editor context contains +one or zero, one representing a position where a brick-square is permanently +stuck and zero representing a position that is "free".<br> +<br> +When a brick is shown and falling, its matrix conceptually resides on top of +the background matrix. At all times a brick-matrix keeps updated information +on where a particular square is as well as if that square is colored or not. +A brick-matrix element contains a record which in turn contains information +about the current row and column coordinates of the background matrix and +whether that square is colored or should be drawn transparent (not drawn). +When a brick changes position (falls one step or is moved to the left or +to the right), its matrix is updated accordingly.<br> +When a brick is considered to be stuck somewhere, the background matrix is +updated by looking at the current information in the current brick-matrix. +The determining of whether a brick is stuck or can/can not be moved, is done +by looking at the surrounding elements relative to a brick's current +position in the background matrix. +An element in a brick matrix which is market as "colored" can never be +located "on top" of an element in the background matrix which contains a one.<br> +<br> +The actual drawing and erasing of the bricks is based on the background matrix +indeces where a brick currently resides. +A brick square has a constant width and height, so it is only a matter of +multiplying that constant number of pixels by the matrix row or column number +to determining where the brick image should be drawn.<br> +<br> +Graphically, a brick is a rectangular image(string) which is drawn using the +procedure <b>DrawImage()</b> which support transparency in drawing. +This is useful since bricks are shaped as they are.<br> +Erasing of a brick is done by a series of <b>EraseArea()</b> calls each of +which is erasing one square of the brick. This is a little bit slow but is +necessary to prevent already stuck bricks from being overwritten. +This might happen if a falling brick is erased by clearing one single rectangle +covering the whole brick when it is close enough to already stuck ones. +</font> +</body> +</html> diff --git a/ipl/gpacks/htetris/interface.html b/ipl/gpacks/htetris/interface.html new file mode 100644 index 0000000..1998a13 --- /dev/null +++ b/ipl/gpacks/htetris/interface.html @@ -0,0 +1,57 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<!--NewPage--> +<html> +<head> +<title>htetris documentation</title> +</head> +<body> +<h1> +<center>User Manual For htetris Version 1.0</center> +<center>Henrik Sandin 1999</center> +</h1> +<hr> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/htetrisdoc.html">Main page</a> +<h2>The interface</h2><br> +<font size="5"> +The graphical user interface of this application has several parts. +These include:<br> +<ol type="1"> +<li>The game playing area.<br> +This is the rectangular area to the far right on the interface. This is +where the bricks fall and the action resides during a game. +<li>The next brick display.<br> +During a game, the next brick to come up is showed here. That way the player +has an opportunity of planning ahead one step. +<li>Convenience buttons.<br> +These are the four functions that are applicable when a game is in progress. +They are also availible in the <b>Game</b> menu and as keyboard shortcuts. +<li>Level of difficulty display.<br> +This shows the current level if a game is in progress. If a game is not in +progress it shows the most recently played level or, if the <b>Pick level</b> +option described in <a href="http://lww.CS.Arizona.EDU:80/~henriks/menus.html"><b>Menu items and features</b></a>. +has been used, the level at which the next game will start. +<li>Current score display.<br> +This shows the current score if a game is in progress. If a game is not in +progress it shows the final score of the most recently played game. +<li>Highscore display.<br> +If the application is ran for the first time from the current directory or +if the file <b>highscore.dat</b> has been deleted, the initial highscore is +zero. Otherwise, the highscore is read from the above mentioned file. If a +game results in a score higher than the current highscore, the highscore +display is updated and the new highscore is saved to file. This does not +happen if a game is stopped, a new game is started or the application is +closed when a game is in progress. +<li>The menu bar.<br> +There are five menus on the menu bar, each of which holds a category of +options and features. The menus are named after the category they contain. +Each menu and its different menu items are described in detail in +<a href="http://lww.CS.Arizona.EDU:80/~henriks/menus.html"><b>Menu items and features</b></a>. +<li>Initial animation area.<br> +When the <b>htetris</b> application is started, an animation of bricks is +performed here. This is just for show and has no other function. +</ol> +<br> +</font> +<img src="http://lww.CS.Arizona.EDU:80/~henriks/screenshot.gif" alt="htetris screenshot."> +</body> +</html> diff --git a/ipl/gpacks/htetris/matrix.icn b/ipl/gpacks/htetris/matrix.icn new file mode 100644 index 0000000..00b1076 --- /dev/null +++ b/ipl/gpacks/htetris/matrix.icn @@ -0,0 +1,331 @@ +############################################################################ +# +# File : matrix.icn +# Author: Henrik Sandin +# Date : May 3, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures for creating and manipulate a two- +# dimensional matrix structure. +# A matrix is represented with a list of lists and an element is accessed +# in the same way as with lists, row first and column second. +# For example my_matrix[3][4] is the fourth element in the third row +# of my_matrix. +# +############################################################################ + +$define POS_INF 11 +$define NEG_INF 0 +$define NO_VALUE -1 + +############################################################################ +# +# Record: non_zero +# Fields: min_row - The first row with non-zero elements in it. +# max_row - The last row with non-zero elements in it. +# min_col - The first column with non-zero elements in it. +# max_col - The last column with non-zero elements in it. +# +# This record represents the smallest rectangular area within a matrix that +# covers all non-zero elements. It contains the top and bottom row numbers +# and left and right column numbers for such an area. +# +############################################################################ + +record non_zero( min_row, max_row, min_col, max_col) + +############################################################################ +# +# Procedure: new_matrix +# Arguments: nr_rows - The number of rows in the new matrix. +# nr_columns - The number of columns in the new matrix. +# Returns : matrix - A new matrix structure. +# +# This procedure constructs and returns a new matrix structure with +# 'nr_rows' rows and 'nr_columns' columns. +# The new matrix is filled with zeroes. +# +############################################################################ + +procedure new_matrix( nr_rows, nr_columns) + + matrix := list( nr_rows, &null) + every r := 1 to nr_rows do + matrix[r] := list( nr_columns, 0) + + return matrix +end + +############################################################################ +# +# Procedure: rotate_matrix +# Arguments: matrix - The matrix to be rotated. +# Returns : rotated - A new rotated matrix structure. +# +# This procedure constructs and returns a new matrix structure that is +# the argument matrix rotated 90 degrees counter-clockwise. +# The number of rows in the new matrix is the number of columns in the +# original and vice versa. +# +############################################################################ + +procedure rotate_matrix( matrix) + + old_width := *matrix[1] + old_height := *matrix + + rotated := list( old_width, &null) + every r := 1 to *rotated do + rotated[r] := list( old_height, &null) + + every r := 1 to old_height do + every c := old_width to 1 by -1 do + rotated[old_width-c+1][r] := matrix[r][c] + + return rotated +end + +############################################################################ +# +# Procedure: non_zero_limits +# Arguments: matrix - The matrix to be analyzed. +# Returns : A used_area structure. +# +# This procedure analyzes the elements of the given matrix and determines +# the limits of the smallest rectangular area covering all the non-zero +# elements in it in terms of a used_area structure. +# +############################################################################ + +procedure non_zero_limits( matrix) + + rows := [] + min_col := POS_INF + max_col := NEG_INF + + every r := 1 to *matrix do { + new_min_col := NO_VALUE + new_max_col := NO_VALUE + + every c := 1 to *matrix[1] do + if matrix[r][c] ~= 0 then { + new_min_col := c + break + } + every c := *matrix[1] to 1 by -1 do + if matrix[r][c] ~= 0 then { + new_max_col := c + break + } + if new_min_col ~= NO_VALUE & new_max_col ~= NO_VALUE then { + if new_min_col < min_col then + min_col := new_min_col + if new_max_col > max_col then + max_col := new_max_col + put( rows, r) + } + } + if *rows = 1 then { + min_row := get( rows) + max_row := min_row + } + else { + min_row := get( rows) + max_row := pull( rows) + } + return non_zero( min_row, max_row, min_col, max_col) +end + +############################################################################ +# +# Procedure: trim_matrix +# Arguments: matrix - The matrix to be trimmed. +# Returns : trimmed - A new trimmed matrix. +# +# This procedure peels off possibly unused outer rows and columns. +# A row or column is concidered unused if it contains only zeros. +# A new matrix with a possibly smaller size and the contents of the +# non-zero rows and columns in the original is constructed and returned. +# +############################################################################ + +procedure trim_matrix( matrix) + + non_zero_area := non_zero_limits( matrix) + + trimmed := new_matrix( non_zero_area.max_row-non_zero_area.min_row+1, + non_zero_area.max_col-non_zero_area.min_col+1) + trimmed_row := 1 + every matrix_row := non_zero_area.min_row to non_zero_area.max_row do { + trimmed_col := 1 + every matrix_col := non_zero_area.min_col to non_zero_area.max_col do { + trimmed[trimmed_row][trimmed_col] := matrix[matrix_row][matrix_col] + trimmed_col := trimmed_col+1 + } + trimmed_row := trimmed_row+1 + } + return trimmed +end + +############################################################################ +# +# Procedure: mtos +# Arguments: matrix - A matrix containing only ones and zeros. +# Returns : matrix_string - Its string representation. +# +# This procedure returns the string representation of the given matrix. +# It has the following format: +# <nr rows>,<nr columns>;<row 1>;...;<row n> +# Where nr rows and nr columns are integers and row i is a string of ones +# and/or zeros. +# +############################################################################ + +procedure mtos( matrix) + + matrix_string := *matrix || "," || *matrix[1] || ";" + + every r := 1 to *matrix do { + every c := 1 to *matrix[1] do + matrix_string := matrix_string || matrix[r][c] + + if r < *matrix then + matrix_string := matrix_string || ";" + } + return matrix_string +end + +############################################################################ +# +# Procedure: stom +# Arguments: matrix_string - String representation of a matrix. +# Returns : matrix - The corresponding matrix. +# +# This procedure returns a matrix corresponding to the given string +# representation which represents a matrix containing only ones and zeros. +# +############################################################################ + +procedure stom( matrix_string) + + matrix_string ? { + rows := integer( tab( upto( ','))) + move( 1) + columns := integer( tab( upto( ';'))) + matrix := new_matrix( rows, columns, 0) + move( 1) + every r := 1 to rows do { + row_string := tab( many( '01')) + row_string ? { + every c := 1 to columns do + matrix[r][c] := move( 1) + } + move( 1) + } + } + return matrix +end + +############################################################################ +# +# Procedure: copy_matrix +# Arguments: matrx - A matrix. +# Returns : new_mtx - A copy of the original list of matrices. +# +# This procedure constructs and returns a copy of a given matrix. +# Only the top-level of the elements (if they are structures) are copied. +# +############################################################################ + +procedure copy_matrix( matrix) + + new_mtx := list( *matrix, &null) + every r := 1 to *matrix do { + + new_r := list( *matrix[r], &null) + every c := 1 to *matrix[r] do { + + new_r[c] := copy( matrix[r][c]) + } + new_mtx[r] := new_r + } + return new_mtx +end + +############################################################################ +# +# Procedure: copy_matrices +# Arguments: matrices - A list of matrices. +# Returns : new_lst - A copy of the original list of matrices. +# +# This procedure constructs and returns a copu of a given list of matrices. +# +############################################################################ + +procedure copy_matrices( matrices) + + new_lst := list( *matrices, &null) + every matrix := 1 to *matrices do + new_lst[matrix] := copy_matrix( matrices[matrix]) + + return new_lst +end + +############################################################################ +# +# Procedure: init_positions +# Arguments: matrix - Matrix representing a brick which is to be initialized. +# Returns : Nothing. +# +# This procedure initializes a brick matrix with the starting positions in +# the game pane matrix. Each element is set to a record containing the +# row/column position of the game pane matrix and whether that square +# (of the brick) is transparent or not. +# +############################################################################ + +procedure init_positions( matrix) + + start_column := MIDDLE+1 - (*matrix[1])/2 + + init_row := 1 + every r := 1 to *matrix do { + init_column := start_column + every c := 1 to *matrix[r] do { + if matrix[r][c] = 0 then + matrix[r][c] := position( init_row, init_column, TRUE) + else + matrix[r][c] := position( init_row, init_column, FALSE) + init_column := init_column+1 + } + init_row := init_row+1 + } + return matrix +end + +############################################################################ +# +# Procedure: print_matrix +# Arguments: matrix - A matrix. +# Returns : Nothing. +# +# This procedure writes the given matrix to standard output, one row +# per line. Used for debugging. +# +############################################################################ + +procedure print_matrix( matrix) + + every r := 1 to *matrix do { + every c := 1 to *matrix[r] do + writes( image( matrix[r][c]) || " ") + write() + } + write() + return +end diff --git a/ipl/gpacks/htetris/menus.html b/ipl/gpacks/htetris/menus.html new file mode 100644 index 0000000..6a2f7a8 --- /dev/null +++ b/ipl/gpacks/htetris/menus.html @@ -0,0 +1,99 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<!--NewPage--> +<html> +<head> +<title>htetris documentation</title> +</head> +<body> +<h1> +<center>User Manual For htetris Version 1.0</center> +<center>Henrik Sandin 1999</center> +</h1> +<hr> +<a href="http://lww.CS.Arizona.EDU:80/~henriks/htetrisdoc.html">Main page</a> +<h2>Menu items and features</h2><br> +<font size="5"> +<ul type="square"> +<li>The <b>Game</b> menu<br><br> +<ul type="disc"> +<li><b>New game</b><br> +Starts a new game regardless of whether a game is already in progress or not. +This can also be acheived by the keyboard shortcut <b>meta-n</b> or by +pressing the <b>New game</b> button on the interface. If a game is in +progress, a possible highscore is lost. +<li><b>Stop game</b><br> +Stops a game in progress. This can also be acheived by the keyboard shortcut +<b>meta-s</b> or by pressing the <b>Stop game</b> button on the interface. +A possible highscore is lost. +<li><b>Pause</b><br> +Pauses a game in progress. This can also be acheived by the keyboard shortcut +<b>meta-p</b> or by pressing the <b>Pause</b> button on the interface. +The game is resumed by repeating this action. +<li><b>Speed factor</b><br> +This option lets the user specify a number between -10 and 10 which makes the +application run faster or slower. A negative number makes the application slow +down and a positive number makes the application go faster. This can be used if +the current hardware is too fast or too slow. +This option is not availible when a game is in progress. +<li><b>Pick level</b><br> +This option lets the user specify a difficulty level between one and fifteen +at which the next game is to be started. This option is not availible when +a game is in progress. +<li><b>Quit</b><br> +This exits the <b>htetris</b> application. This can also be acheived by the +keyboard shortcut <b>meta-q</b> or by pressing the <b>Quit</b> button on the +interface. If a game is in progress, a possible highscore is lost. +</ul> +<br> +<li>The <b>Controls</b> menu<br><br> +<ul type="disc"> +<li><b>Set keys</b><br> +This option lets the user specify which keys to use for game control. +Valid keys are: Any character or any special key which synonym is displayed +in the separate popup window. Any of these synonyms can be specified. +<li><b>Current keys</b><br> +This option shows which keys are currently used for game control. +</ul> +<br> +<li>The <b>Bricks</b> menu<br><br> +<ul type="disc"> +<li><b>Add brick</b><br> +This option lets the user add a user defined brick to the game by loading it +from a file created with the editor which is described in <a href="http://lww.CS.Arizona.EDU:80/~henriks/editor.html"><b>Brick editor</b></a>. +This can also be acheived by the keyboard shortcut <b>meta-a</b>. +If the brick is added successfully, the user is given an id for the brick +which should be used if the brick is going to be removed from the game again. +The added brick will appear in every game from here on until it is removed or +the application is closed. +<li><b>Remove brick</b><br> +If any user defined bricks are currently in the game, this option lets the +user remove such bricks. This means that they are not going to appear in any +game from here on unless they are added again by selecting <b>Add brick</b>. +This can also be acheived by the keyboard shortcut <b>meta-r</b>. +<li><b>Bricks in use</b><br> +This option lets the user display user defined bricks in play if there are any. +The user is prompted to enter one of the listed brick id's and in doing so, +that brick is displayed in a popup window. The dialog reappears until +<b>Cancel</b> is pressed. Thus, several user bricks can be viewed +simultanously. +<li><b>Brick editor</b><br> +This starts up the brick editor in which a user can create his/hers own bricks +to use in the game. This can also be acheived by the keyboard shortcut +<b>meta-e</b>. +The editor is described in detail in <a href="http://lww.CS.Arizona.EDU:80/~henriks/editor.html"><b>Brick editor</b></a>. +</ul> +<br> +<li>The <b>Help</b> menu<br><br> +<ul type="disc"> +<li><b>How to play</b><br> +This option basicly displays the same information as the <a href="http://lww.CS.Arizona.EDU:80/~henriks/howto.html"><b>How to play</b></a> +document. +<li><b>Menus</b><br> +This option basicly displays the same information as this document. +<li><b>About</b><br> +This option displays information about the application and the author. +</ul> +</ul> +</font> +</body> +</html> diff --git a/ipl/gpacks/htetris/movement.icn b/ipl/gpacks/htetris/movement.icn new file mode 100644 index 0000000..ccfbfe8 --- /dev/null +++ b/ipl/gpacks/htetris/movement.icn @@ -0,0 +1,383 @@ +############################################################################ +# +# File : movement.icn +# Author: Henrik Sandin +# Date : May 3, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures for brick movement. +# A brick can be moved on left, right, up and down on a pane. +# The procedures for determining if a brick can be moved in its current +# position in the underlying pane matrix, uses the values of the given +# brick matrix that represents the current state of the brick to be moved. +# A brick can also be "slammed down", it gets stuck instantly as far down +# as possible on the pane in its current horizontal position. +# +############################################################################ + +############################################################################ +# +# Procedure: can_move_right +# Arguments: matrix - Matrix of a brick. +# Returns : Nothing. +# +# This procedure determines if a brick can be moved to the right or not. +# The position in the pane matrix one column to the right of each far right, +# non-transparent element of the given brick matrix is examined. +# If one such element of the pane matrix is "filled", the brick represented +# by the given matrix can not be moved to the right and failure occurs. +# +############################################################################ + +procedure can_move_right( matrix) + + every r := 1 to *matrix do { + c := *matrix[1] + while matrix[r][c].transparent = TRUE do + c := c-1 + if pane_matrix[matrix[r][c].row_nr][matrix[r][c].col_nr+1] = FILLED then + fail + } + return +end + +############################################################################ +# +# Procedure: can_move_left +# Arguments: matrix - Matrix of a brick. +# Returns : Nothing. +# +# This procedure determines if a brick can be moved to the left or not. +# The position in the pane matrix one column to the left of each far left, +# non-transparent element of the given brick matrix is examined. +# If one such element of the pane matrix is "filled", the brick represented +# by the given matrix can not be moved to the left and failure occurs. +# +############################################################################ + +procedure can_move_left( matrix) + + every r := 1 to *matrix do { + c := 1 + while matrix[r][c].transparent = TRUE do + c := c+1 + if pane_matrix[matrix[r][c].row_nr][matrix[r][c].col_nr-1] = FILLED then + fail + } + return +end + +############################################################################ +# +# Procedure: can_move_down +# Arguments: matrix - Matrix of a brick. +# Returns : Nothing. +# +# This procedure determines if a brick can be moved down or not. +# The position in the pane matrix one row below of each bottom-edge, +# non-transparent element of the given brick matrix is examined. +# If one such element of the pane matrix is "filled", the brick represented +# by the given matrix can not be moved down and failure occurs. +# +############################################################################ + +procedure can_move_down( matrix) + + every c := 1 to *matrix[*matrix] do { + r := *matrix + while matrix[r][c].transparent = TRUE do + r := r-1 + if pane_matrix[matrix[r][c].row_nr+1][matrix[r][c].col_nr] = FILLED then + fail + } + return +end + +############################################################################ +# +# Procedure: can_flip +# Arguments: matrix - A matrix representing a rotated brick. +# Returns : Nothing. +# +# This procedure determines if a brick can be rotated or not. +# The argument is a matrix representing a brick after the intended rotation. +# If the "virtual" brick represented by this matrix can be drawn in its +# current position, the original brick can be rotated accordingly. +# Failure occurs if the given matrix covers any "filled" element in the +# pane matrix, since the not yet rotated brick then can not be rotated +# without crossing another, already stuck brick. +# +############################################################################ + +procedure can_flip( matrix) + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do { + element := matrix[r][c] + if element.col_nr < 1 | + pane_matrix[element.row_nr][element.col_nr] = FILLED then + fail + } + return +end + +############################################################################ +# +# Procedure: move_right +# Arguments: pane - Pane to update. +# matrix - Matrix of a brick. +# Returns : Nothing. +# +# This procedure moves a brick on the given pane to the right by updating +# its matrix and graphicaly the pane. +# +############################################################################ + +procedure move_right( pane, matrix) + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + matrix[r][c].col_nr := (matrix[r][c].col_nr)+1 + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + if matrix[r][c].transparent = FALSE then + EraseArea( pane, + (matrix[r][c].col_nr-3)*20, + (matrix[r][c].row_nr-1)*20, + 20, 20) + DrawImage( pane, + (matrix[1][1].col_nr-2)*20, + (matrix[1][1].row_nr-1)*20, + current_images[1]) + return +end + +############################################################################ +# +# Procedure: move_left +# Arguments: pane - Pane to update. +# matrix - Matrix of a brick. +# Returns : Nothing. +# +# This procedure moves a brick on the given pane to the left by updating +# its matrix and graphicaly the pane. +# +############################################################################ + +procedure move_left( pane, matrix) + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + matrix[r][c].col_nr := (matrix[r][c].col_nr)-1 + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + if matrix[r][c].transparent = FALSE then + EraseArea( pane, + (matrix[r][c].col_nr-1)*20, + (matrix[r][c].row_nr-1)*20, + 20, 20) + DrawImage( pane, + (matrix[1][1].col_nr-2)*20, + (matrix[1][1].row_nr-1)*20, + current_images[1]) + return +end + +############################################################################ +# +# Procedure: move_down +# Arguments: pane - Pane to update. +# matrix - Matrix of a brick. +# Returns : Nothing. +# +# This procedure moves a brick on the given pane down by updating its +# matrix and graphicaly the pane. +# +############################################################################ + +procedure move_down( pane, matrix) + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + matrix[r][c].row_nr := (matrix[r][c].row_nr)+1 + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + if matrix[r][c].transparent = FALSE then + EraseArea( pane, + (matrix[r][c].col_nr-2)*20, + (matrix[r][c].row_nr-2)*20, + 20, 20) + DrawImage( pane, + (matrix[1][1].col_nr-2)*20, + (matrix[1][1].row_nr-1)*20, + current_images[1]) + return +end + +############################################################################ +# +# Procedure: move_up +# Arguments: pane - Pane to update. +# matrix - Matrix of a brick. +# Returns : Nothing. +# +# This procedure moves a brick on the given pane up by updating its +# matrix and graphicaly the pane. +# This procedure is only used in the initial animation and not in the game. +# +############################################################################ + +procedure move_up( pane, matrix) + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + matrix[r][c].row_nr := (matrix[r][c].row_nr)-1 + + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + if matrix[r][c].transparent = FALSE then + EraseArea( pane, + (matrix[r][c].col_nr-2)*20, + (matrix[r][c].row_nr)*20, + 20, 20) + DrawImage( pane, + (matrix[1][1].col_nr-2)*20, + (matrix[1][1].row_nr-1)*20, + current_images[1]) + return +end + +############################################################################ +# +# Procedure: flip +# Arguments: None. +# Returns : Nothing. +# +# This procedure rotates a brick. Bricks are rotated counter clockwise 90 +# degrees at a time. The matrix representing the current brick when it +# is rotated is updated with the current pane matrix positions using the +# flip offset and is then sent to 'can_flip' to check if it is possible +# to perform a rotation. +# If it is okay to rotate, the current matrix and image lists are rotated +# so that the matrix and image of the rotated brick comes first in the lists. +# When a brick is rotated, the flip offset must be negated, since the number +# of rows and columns of the current brick matrix switch roles. +# The previous (unrotated brick) is then erased, and the rotated brick +# is drawn in its new position (which has already been determined before +# the call to 'can_flip'). +# +############################################################################ + +procedure flip() + + prev_matrix := current_matrices[1] + matrix := current_matrices[2] + + new_row := prev_matrix[1][1].row_nr + flip_offset + every r := 1 to *matrix do { + new_col := prev_matrix[1][1].col_nr - flip_offset + every c := 1 to *matrix[r] do { + matrix[r][c].row_nr := new_row + matrix[r][c].col_nr := new_col + new_col := new_col+1 + } + new_row := new_row+1 + } + if can_flip( matrix) then { + flip_offset := -flip_offset + put( current_images, get( current_images)) + put( current_matrices, get( current_matrices)) + + EraseArea( game_pane, + (prev_matrix[1][1].col_nr-2)*20, + (prev_matrix[1][1].row_nr-1)*20, + (*prev_matrix[1])*20, + (*prev_matrix)*20) + DrawImage( game_pane, + (matrix[1][1].col_nr-2)*20, + (matrix[1][1].row_nr-1)*20, + current_images[1]) + } + return +end + +############################################################################ +# +# Procedure: fall +# Arguments: None. +# Returns : Nothing. +# +# This procedure determines if a brick can fall one row, and in that case +# moves it down. If the brick can't be moved down, it gets stuck and +# the next brick is fetched. +# +############################################################################ + +procedure fall() + + matrix := current_matrices[1] + + if can_move_down( matrix) then + move_down( game_pane, matrix) + else { + get_stuck() + fetch_next() + } + return +end + +############################################################################ +# +# Procedure: slam +# Arguments: None. +# Returns : Nothing. +# +# This procedure makes a falling brick get stuck directly as far down on +# the pane as possible in the same vertical line. +# A copy of the matrix is first made since it is modified by a series of +# "move down" operations. The copy is used to erase the brick at the +# position it was when slam was called. +# The original matrix is (conceptually) moved (and updated accordingly) down +# until 'can_move_down' fails and it has to get stuck (again, conceptually). +# Erasing of the brick on the actual pane is done 'square-by-square' rather +# than one rectangle covering the whole brick so that no part of another +# brick is erased by mistake. +# Finally, the brick is drawn in its final position. +# +############################################################################ + +procedure slam() + + matrix := current_matrices[1] + old_matrix := copy_matrix( matrix) + + while can_move_down( matrix) do + every r := 1 to *matrix do + every c := 1 to *matrix[r] do + matrix[r][c].row_nr := matrix[r][c].row_nr+1 + + every r := 1 to *old_matrix do + every c := 1 to *old_matrix[r] do + if old_matrix[r][c].transparent = FALSE then + EraseArea( game_pane, + (old_matrix[r][c].col_nr-2)*20, + (old_matrix[r][c].row_nr-1)*20, + 20, 20) + DrawImage( game_pane, + (matrix[1][1].col_nr-2)*20, + (matrix[1][1].row_nr-1)*20, + current_images[1]) + + get_stuck() + fetch_next() + return +end + diff --git a/ipl/gpacks/tiger/Makefile b/ipl/gpacks/tiger/Makefile new file mode 100644 index 0000000..f148917 --- /dev/null +++ b/ipl/gpacks/tiger/Makefile @@ -0,0 +1,31 @@ +# Makefile for TIGER mapping programs + + +IC = icont +IFLAGS = -us +DEST = /unspecified/destination/ + +PROGS = tgrprep tgrlink tgrmap tgrmerge tgrquant tgrtrack +SCRIPTS = tgrsort tgrstats tgrclean + + +.SUFFIXES: .icn +.icn: ; $(IC) $(IFLAGS) $< + + + +default: $(PROGS) + + +test: + + +install: $(PROGS) $(SCRIPTS) + cp $(PROGS) $(SCRIPTS) $(DEST) + +Iexe: + $(MAKE) DEST=../../iexe install + + +clean Clean: + rm -f $(PROGS) *.u[12] *.out* diff --git a/ipl/gpacks/tiger/README b/ipl/gpacks/tiger/README new file mode 100644 index 0000000..22a8134 --- /dev/null +++ b/ipl/gpacks/tiger/README @@ -0,0 +1,77 @@ +Tiger README file +Gregg M. Townsend and William S. Evans +July 31, 2000 + + +These programs draw road and street maps from the "TIGER/Line" data +files (1994 or later) of the U.S. Census Bureau. Two programs are key: + + tgrprep.icn reformats TIGER/Line data into smaller, more easily + displayed "line chain" files. + + tgrmap.icn reads line chain files and displays a map. Zooming + and other features are provided. A subset of the map + can be saved as either line chains or as a PostScript + file for printing. + +Other programs are useful, though not necessary: + + tgrlink.icn connects line chains to produce a smaller, faster version + of the same data + + trgmerge.icn merges data from multiple line chain files + + tgrtrack.icn creates a line chain file from a GPS track log. + + tgrquant.icn quantize line chain files to simulate a loss of precision. + +Four UNIX scripts also manipulate line chain files: + + tgrsort orders map data from least to most significant. + + tgrstats counts the occurrences of each type of feature. + + tgrclean removes insignificant features. + + tgrstrip removes even more features. + +There is a wealth of information in the TIGER files; only some of it is +displayed. In particular, street names are not displayed, and bounded +regions such as lakes are not filled in. + +The Census Bureau has a TIGER page on the World Wide Web: + http://www.census.gov/geo/www/tiger/ +They have an on-line mapping service that is somewhat more sophisticated +than these programs. + + +TIGER 1998 data is available on-line from the Census Bureau: + http://www.census.gov/geo/tigerline/tl_1998.html + +TIGER 1997 data is available by FTP from the Social Science +and Government Library of the University of California at Berkeley: + http://sunsite.berkeley.edu/GovData/info/tiger.html + +TIGER data is also available on CD-ROM; in the 1998 +version, seven discs ($70 each) cover the entire United States. See: + http://www.census.gov/mp/www/rom/msrom12l.html + +TIGER CD-ROM discs may also be available at your nearest Federal +Depository Library or other major library. Local data may also be +available from city or county planning offices and the like. + + + +The process of making a map goes something like this: + * find the appropriate data file; there is one for every county + * unzip the county file, producing about 17 separate files + * run tgrprep, using the first two of those files, to make a .lch file + * run tgrmap, reading the .lch file + * zoom in on the area of interest + * save that as a new and smaller .lch file + * optimize the .lch file using tgrlink [this step is optional] + +The final .lch file can be redisplayed, explored, printed, and so on. + + +These programs and scripts were developed and tested under UNIX. diff --git a/ipl/gpacks/tiger/tgrclean b/ipl/gpacks/tiger/tgrclean new file mode 100755 index 0000000..3522276 --- /dev/null +++ b/ipl/gpacks/tiger/tgrclean @@ -0,0 +1,11 @@ +#!/bin/sh +# +# tgrclean [file] -- remove details from line chain file +# +# Filters a line chain file to remove pipelines, powerlines, and minor +# boundaries, except when any of these coincides with a major boundary line. +# The effect of this is to produce a smaller file with less detail. + +sed ' + /^[CEF]..0/d +' $* diff --git a/ipl/gpacks/tiger/tgrlink.icn b/ipl/gpacks/tiger/tgrlink.icn new file mode 100644 index 0000000..7838b6b --- /dev/null +++ b/ipl/gpacks/tiger/tgrlink.icn @@ -0,0 +1,424 @@ +############################################################################ +# +# File: tgrlink.icn +# +# Subject: Program to combine TIGER line chains +# +# Authors: Gregg M. Townsend and William S. Evans +# +# Date: June 23, 2000 +# +############################################################################ +# +# Tgrlink connects records from a line chain file to produce a more +# compact file composed of fewer, longer chains. Chains having common +# endpoints and somewhat similar orientations are joined together. +# Then, wherever three consecutive points are collinear, or nearly so, +# the middle point is removed. +# +# Usage: tgrlink [-e maxerror] [-a maxangle] [file.lch] +# +# The maxerror parameter, measured in latitude units, sets the maximum +# distance the middle of three points can deviate from the line connecting +# its neighbors and still be considered "collinear". The default value +# is 4, which is generally large enough to cover quantization errors +# without introducing visible artifacts. +# +# The maxangle parameter, defaulting to 30 degrees, limits the change in +# angle of the chain path due to the removal of a middle point. This +# prevents narrow rectangles from turning into pointed triangles. +# +# The input file must be randomly seekable (a disk file, not a pipe). +# +############################################################################ +# +# The algorithm is effective but not perfect. It is designed to +# minimize memory to allow the handling of large input files. +# Processing the output data a second time may give a little more +# improvement. +# +# First, the input file is scanned and each chain is entered in a table. +# Chains are segregated by feature and boundary code (chains with +# different codes cannot be combined) and grouped by orientation. +# +# A table key is formed by concatenating latitude+longitude with +# latitude (only), using whichever endpoint gives a smaller sum. The +# table value for a chain is the chain's offset in the input file. +# If multiple chains share the same key, a list of offsets is entered +# in the table. +# +# Output is generated by iterating through all the codes from the +# "least important" to "most important" (so that those end up on top +# when the map is drawn). Within codes, vertically oriented lines +# come first, then horizontally oriented lines, followed by others. +# Within an orientation group, chains are sorted by key, with the +# effect that they are produced from upper left to lower right +# along a diagonally oriented wavefront. +# +# For each generated key, output proceeds as follows, given the file +# offset o associated with the key. If offset o has already been +# processed, as noted in the set "done", then do nothing further. +# Otherwise, add o to the set and continue. Seek the input file to +# offset o and read the chain data into memory. Calculate the far +# endpoint of the chain and the key associated with that. Check the +# tables for another unprocessed chain of similar orientation beginning +# there; if successful, append the path and mark that chain as processed. +# Repeat this as long as a successor chain can be found. +# +# Now go through the chain in memory and collapse collinear points within +# the limits permitted by the command options. Finally, calculate the +# maximum range of the chain from its starting point, and write it out. +# +# This all seems to work well in practice. One possible drawback, at +# in theory, is that chains heading slightly more north than east will +# not be connected to chains heading slightly more east than north. +# The sorting of keys by latitude+longitude means that no matter which +# chain is processed first, the wrong endpoint of the other one is in +# the key table and no connection will be seen. +# +############################################################################ +# +# Links: options +# +############################################################################ + + +link options + + +$define DefaultError 4 # default max error for removing point +$define DefaultAngle 30 # default max angle for removing point + +$define SECTORS 5 # number of different orientations + + +global ifile # input file +global maxerr, maxangle # point removal parameters + +global latsin # scaling factor: sin(latitude) + +global chtab # master chain table (keyed by code) +global done # set of offsets already output + +global xoff, yoff # lists of deltas in current chain + + +record crec(code, key, x1, x2, y1, y2, rev, aindex) # chain record data + + + +# main procedure + +procedure main(args) + local opts, w, hdr1, hdr2, e, k, l, latmin, latmax + + opts := options(args, "a.e.") # process command options + maxangle := \opts["a"] | DefaultAngle + maxerr := \opts["e"] | DefaultError + + if *args > 1 then + stop("usage: ", &progname, " file") + else if *args = 1 then + ifile := open(args[1]) | stop(&progname, ": can't open ", args[1]) + else + ifile := &input + + hdr1 := read(ifile) | stop(&progname, ": empty file") + hdr2 := read(ifile) | stop(&progname, ": file truncated") + + latmin := hdr1[16+:7] + latmax := hdr2[16+:7] + latsin := sin(((latmax + latmin) / 2.0) * (&pi / 9999999)) + + loadfile() # load table keys + + write(hdr1) + write(hdr2) + every dumpcode(kgen(chtab)) # dump chains in code order +end + + + +# loadfile() -- load input file keys into tables + +procedure loadfile() + local w, line, alist, t, l, r + + chtab := table() + repeat { + w := where(ifile) | stop(&progname, ": input file is not seekable") + line := read(ifile) | break + + r := crack(line) + + if /(alist := chtab[r.code]) then { + # first time for this code; make new tables. + alist := chtab[r.code] := list(SECTORS) + every !alist := table() + } + + t := alist[r.aindex] + + ((/t[r.key]) := w) | { + if type(l := t[r.key]) ~== "list" then + l := t[r.key] := [t[r.key]] + put(l, w) + } + + } + return +end + + + +# kgen(t) -- generate keys of t in better order, as in the "tgrsort" script + +procedure kgen(t) + local l, k + + l := list() + every k := key(t) do + put(l, map(k[1], "FHEABCDX", "ZYXWVUTS") || k) + l := sort(l) + while k := pull(l) do + suspend k[2:0] + fail +end + + + +# dumpcode(code) -- output all chains having a particular code + +procedure dumpcode(code) + local h, v, i, l, k, o, alist + + alist := chtab[code] + done := set() + + every l := sort(alist[aseq()], 3) do + while k := get(l) do { + o := get(l) + if type(o) == "list" then + every putchain(code, k, !o) + else + putchain(code, k, o) + } + return +end + + + +# aseq() -- generate the orientation table subscripts in proper order + +procedure aseq() + local v, h + + h := 1 + integer(0.25 * SECTORS) + v := 1 + integer(0.75 * SECTORS) + suspend h # sector that includes horizontal lines + suspend v # sector that includes vertical lines + suspend h+1 to v-1 # NW to SE quadrant + suspend 1 to h-1 # ENE to WSW + suspend v+1 to SECTORS # SSW to NNE + fail +end + + + +# putchain(code, k, o) -- output chain of given code, key, and offset + +procedure putchain(code, k, o) + local t, r, x, y, x1, y1, xmin, xmax, ymin, ymax, d, w + + if member(done, o) then # if already processed + return + insert(done, o) # mark as done + + k ? { # extract (x1, y1) from key + t := move(8) + x1 := integer(move(7)) + y1 := t - x1 + } + + xoff := [] # init list of deltas + yoff := [] + r := putdel(o) # add this chain's deltas + + while o := successor(r) do { # while a successor can be found + insert(done, o) # mark it as processed + r := putdel(o) # append its deltas + } + + collapse() # collapse collinear points + + x := xmin := xmax := x1 # find min/max x/y values + y := ymin := ymax := y1 + every x +:= !xoff do { + xmin >:= x + xmax <:= x + } + every y +:= !yoff do { + ymin >:= y + ymax <:= y + } + + d := x - xmin # find max deviation from x1 | y1 + d <:= xmax - x + d <:= y - ymin + d <:= ymax - y + d >:= 9999 # limit to four digits + + # output the resulting chain + + writes(code, right(d, 4), right(x1, 7), right(y1, 7)) + while x := get(xoff) & y := get(yoff) do + if x ~= 0 | y ~= 0 then + w := writes(right(5000 + x, 4), right(5000 + y, 4)) + if /w then + writes("50005000") # line had degenerated to a point + write() + return +end + + + +# putdel(o) -- record deltas (only) for chain at offset o in input file. + +procedure putdel(o) + local line, r, dy, mark + + # read the line located at offset o + seek(ifile, o) | stop(&progname, ": can't reposition input file") + line := read(ifile) | + stop(&progname, ": input file changed during processing") + # crack its data + r := crack(line) + + # append deltas + line ? { + move(4) + if ="|" then + tab(upto('|') + 1) # skip feature name + move(18) + + if /r.rev then # if endpoints were not reversed + while put(xoff, move(4) - 5000) do + put(yoff, move(4) - 5000) + else { + mark := &pos + tab(0) # if must start at far end + while (mark < &pos) & (put(yoff, 5000 - move(-4))) do { + put(xoff, 5000 - move(-4)) + } + } + } + return r # return cracked data +end + + + +# collapse() -- collapse collinear points in global xoff/yoff lists + +procedure collapse() + local maxsq, maxa, i, x1, y1, a1, x2, y2, a2, da, d, dx, dy + + if maxerr <= 0 then # if no collapsing allowed + return + maxsq := maxerr * maxerr # square of error (avoid sqrt later) + + maxa := maxangle * &pi / 180 + maxa >:= &pi # max angle in radians + + x2 := latsin * xoff[1] + y2 := yoff[1] + a2 := atan(y2, x2) + + every i := 2 to *xoff do { + x1 := x2 + y1 := y2 + a1 := a2 + x2 := latsin * xoff[i] + y2 := yoff[i] + a2 := atan(y2, x2) + + da := abs(a2 - a1) # change in angle if removed + if da > maxa then # if too big, forget it + next + + d := abs((x1 * x1 + y1 * y1) * sin(da)) # deviation from straight line + if d <= maxsq then { # if close enough + dx := xoff[i] + xoff[i-1] + dy := yoff[i] + yoff[i-1] + if abs(dx) < 5000 & abs(dy) < 5000 then { # if no overflow + xoff[i] := dx # set in curr deltas + yoff[i] := dy + xoff[i-1] := yoff[i-1] := 0 # zero previous deltas + } + } + } + return +end + + + +# successor(r) -- return offset of successor to chain given by crec record r + +procedure successor(r) + local k, alist, t, i, o, e + + alist := chtab[r.code] # list, by orientation, for code + k := right(r.x2 + r.y2, 8) || right(r.x2, 7) # successor's key would be this + every i := 0 | 1 | -1 do { # try same orientation first + t := alist[r.aindex + i] | next # table of offsets + if o := \t[k] then { # entry can be int or list + if type(o) ~== "list" then { + if not member(done, o) then { + return o + } + } + else if (e := !o) & not member(done, e) then + return e + } + } + fail +end + + +# crack(line) -- return crec record giving data about chain + +procedure crack(line) + local angle, x1, y1, x2, y2, a + static o + initial o := crec() + + line ? { + o.code := move(4) + if o.code ||:= ="|" then # if feature name present + o.code ||:= tab(upto('|') + 1) + + move(4) # skip old dimension measurement + + x1 := x2 := integer(move(7)) + y1 := y2 := integer(move(7)) + while x2 +:= move(4) - 5000 do + y2 +:= move(4) - 5000 + + if x1 + y1 > x2 + y2 then { # if far endpoint has smaller sum + o.rev := 1 # chain needs to be reversed + x1 :=: x2 + y1 :=: y2 + } + else + o.rev := &null + + o.key := right(x1 + y1, 8) || right(x1, 7) + o.x1 := x1 + o.y1 := y1 + o.x2 := x2 + o.y2 := y2 + a := atan(y2 - y1, latsin * (x2 - x1)) + o.aindex := 1 + integer(SECTORS * ((a / &pi) + 2.25)) % SECTORS + } + + return o +end diff --git a/ipl/gpacks/tiger/tgrmap.icn b/ipl/gpacks/tiger/tgrmap.icn new file mode 100644 index 0000000..b5dbbe2 --- /dev/null +++ b/ipl/gpacks/tiger/tgrmap.icn @@ -0,0 +1,978 @@ +############################################################################ +# +# File: tgrmap.icn +# +# Subject: Program to generate map from TIGER files +# +# Authors: Gregg M. Townsend and William S. Evans +# +# Date: July 29, 2000 +# +############################################################################ +# +# Tgrmap draws maps based on TIGER data files from the Census Bureau. +# Data files must be in "line chain" (.lch) format as written by the +# associated "tgrprep" program. +# +# Usage: tgrmap [file.lch ...] +# Input is zero or more files of chains created by "tgrprep.icn". +# +# All manipulation is done by mouse actions, keyboard shortcuts, or +# window resizing. There are no menus (although they would be nice +# to have.) +# +# Mouse actions: +# Sweeping an area with the left mouse button zooms the image +# to display that area better. To cancel a sweep, just reduce +# the swept height or width to less than 10 pixels. +# +# Clicking the center mouse button pops up the Layers dialog, +# which selects the categories of data to be shown or hidden. +# No other actions are accepted while the dialog box is up. +# (This only works on 8-bit displays, a vanishing breed.) +# +# Clicking the right mouse button when the cursor is on a line +# brings up a subwindow that shows the name and type of the +# line. +# +# Keyboard shortcuts: +# F find a feature by name +# L bring up the layers dialog +# M create PPM image +# O open a new file +# P create PostScript file for printing +# Q quit +# R refresh the display +# S save the displayed data to file +# + zoom in by a factor of 2 +# - zoom out by a factor of 2 +# 2-9 zoom to factor given +# 1 reset original map (centered and unzoomed) +# arrow arrow keys shift the center of the displayed area +# +# Window resizing is allowed. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: clipping, graphics, numbers, pscript, strings +# +############################################################################ + +# Ideas for future changes: +# Add menu alternatives to keyboard shortcuts +# Write *color* PostScript, at least as an option +# (the programming is easy; tuning the colors is the hard part) + +link clipping +link graphics +link numbers +link pscript +link strings + +$include "keysyms.icn" + +$ifndef _X_WINDOW_SYSTEM + $define Key_KP_Up Key_Up + $define Key_KP_Down Key_Down + $define Key_KP_Left Key_Left + $define Key_KP_Right Key_Right +$endif + +$define MARGIN 5 # margin around full-sized map +$define CLIP 2 # clipping margin, allowing for linewdth +$define SHIFTBY 32 # number of pixels to shift at once +$define PSSCALE 100 # scaling from pixels to PostScript +$define MAXDRAW 4000 # maximum (even) args to avoid error 301 +$define EPSILON 2.5 # how close is enough when clicking + +# file values +global ifileList, fnameList # input files and their names +global lonmin, lonmax, latmin, latmax # input range + +# windows +global wintbl # table of GCs by type +global msgwin # base window for notices +global title # window title +global tmpwin # temp window for PPM snapshots + +# window parameters +global dx, dy # current translation values +global fullx, fully # scaling for zoom-1 display + +# display parameters +global ctrlon, ctrlat # longitude/latitude of center +global curzoom, xscale, yscale # current zoom factor and scaling +global lonrange, latrange # distance from center to edge + +# inquiry parameters +global litName # string to match against feature name + + +# the classification list finds things based on line type +record class( # classification record + prefix, # CFCC prefix + psgray, # PostScript graylevel + pswidth, # PostScript linewidth + label, # label + color, # color + width, # line width + index, # mutable color index + vispfx) # prefix code, but only if visible +global clist # list of classification records +global ctable # table keyed by two-char prefix + + + +procedure main(args) + local e, xywh, lon1, lat1, lon2, lat2, hilightOnly + + Window("size=870,870", "bg=pale moderate brown", args) + + &error := 1 + WAttrib("resize=on") + &error := 0 + + Font(("Helvetica" | "Univers" | "LucidaSans") || ",bold,12") # may fail + WAttrib("pointer=cross" | "pointer=crosshair") # may fail + msgwin := Clone(&window) # save shaded window for notices + setclasses() + + if *args > 0 then + setfiles(args) | exit() + else + setfiles() | exit() + + setwindow() + setcenter() + setzoom() + drawmap() + + repeat case e := Event() of { + + !"01": { + setregion(lonmin, lonmax, latmin, latmax) + drawmap() + } + + !"23456789": { setzoom(e); drawmap() } + !"+=": { setzoom(2.0 * curzoom); drawmap() } + "-": { setzoom(0.5 * curzoom); drawmap() } + + !"Oo": { + if setfiles() then { + setwindow() + setcenter() + setzoom() + drawmap() + } + } + + !"Ll": setlayers() + !"Rr": drawmap() + + !"Mm": { + tmpwin := WOpen("canvas=hidden", + "width=" || WAttrib("width"), "height=" || WAttrib("height")) + if /tmpwin then { + Notice("can't open temporary canvas", "for PPM snapshot") + break + } + CopyArea(&window, tmpwin) + writefile(writeppm, "Write PPM file:", "Writing PPM file...") + WClose(tmpwin) + tmpwin := &null + } + + !"Pp": + writefile(writeps, "Write PostScript file:", "Writing PostScript...") + + !"Ss": + writefile(writelch, "Save displayed portion as:", "Saving...") + + !"Ff": { + if /litName then { + hilightOnly := 1 + litName := "" + } + else { + hilightOnly := &null + } + if TextDialog("Find features named:", , litName) == "Okay" then { + litName := map(dialog_value[1]) + if litName == "" then litName := &null + drawmap(hilightOnly) + } + } + + QuitEvents(): break + + Key_Left | Key_KP_Left: shift(e, +SHIFTBY, 0) + Key_Right | Key_KP_Right: shift(e, -SHIFTBY, 0) + Key_Up | Key_KP_Up: shift(e, 0, +SHIFTBY) + Key_Down | Key_KP_Down: shift(e, 0, -SHIFTBY) + + &lpress: { + xywh := Sweep() + if xywh[3|4] < 10 then + next + lon1 := ctrlon + (get(xywh) - 0.5) / xscale + lat1 := ctrlat + (get(xywh) - 0.5) / yscale + lon2 := lon1 + (get(xywh) + 0.5) / xscale + lat2 := lat1 + (get(xywh) + 0.5) / yscale + setregion(lon1, lon2, lat1, lat2) + drawmap() + } + + &mrelease: { + setlayers() + } + + &rrelease: { + identify(&x, &y) + } + + &resize: { + resize() + } + } +end + + +procedure writefile(proc, caption, message) + local oname, ofile + + repeat case OpenDialog(msgwin, caption) of { + "Okay": { + if *dialog_value = 0 then + next + if close(open(oname := dialog_value)) then + case TextDialog(msgwin, "Overwrite existing file?", , , , + ["Yes", "No", "Cancel"]) of { + "Yes": &null + "No": next + "Cancel": fail + } + if ofile := open(oname, "w") then + break + case TextDialog(msgwin, "Cannot open " || oname) of { + "Okay": next + "Cancel": fail + } + } + "Cancel": + fail + } + + Popup(msgwin, , , 32 + TextWidth(msgwin, message), 32, + popmsg, message, proc, ofile) + close(ofile) + return +end + +procedure popmsg(message, proc, ofile) + CenterString(WAttrib("clipw") / 2, WAttrib("cliph") / 2, message) + return proc(ofile) +end + + +procedure setfiles(L) + local f, fname + + /L := list() + fnameList := list() + every close(!(\ifileList)) + ifileList := list() + prescan() # reset lonmin,lonmax,latmin,latmax + until *fnameList > 0 do { + until *L > 0 do { + case OpenDialog(msgwin, "Input file(s):") of { + "Okay": put(L, words(dialog_value)) + "Cancel": fail + } + } + while fname := get(L) do { + if not (f := open(fname)) then { + Notice(msgwin, "Cannot open " || fname) + next + } + if not (prescan(f)) then { + Notice(msgwin, "Invalid format: " || fname) + close(f) + next + } + put(fnameList, fname) + put(ifileList, f) + } + } + return +end + + + +# prescan(f) -- verify that f is a valid file, setting globals if so + +procedure prescan(f) + local line, alon, alat, blon, blat + if /f then { + lonmin := latmin := 9999999 + lonmax := latmax := 0 + return + } + line := read(f) | fail + line ? { + =" " | fail + alon := move(7) | fail + alat := move(7) | fail + } + line := read(f) | fail + line ? { + =" " | fail + blon := move(7) | fail + blat := move(7) | fail + } + if alon > blon then { + alon :=: blon + alat :=: blat + } + lonmin >:= alon + latmin >:= alat + lonmax <:= blon + latmax <:= blat + return +end + + + +procedure setwindow() + local ww, wh, xstr, ystr, latsin, raspr, waspr + + ww := WAttrib("width") + wh := WAttrib("height") + dx := ww / 2 + dy := wh / 2 + + xstr := "dx=" || (dx := WAttrib("width") / 2) + ystr := "dy=" || (dy := WAttrib("height") / 2) + every WAttrib(&window | !wintbl, xstr, ystr) + + # calculate aspect ratio of file region + latsin := sin(((latmax + latmin) / 2.0) * (&pi / 9999999)) + raspr := real(lonmax - lonmin) / real(latmax - latmin) * latsin * (360 / 180) + + # calculate aspect ratio of window + waspr := real(ww - 2 * MARGIN) / real(wh - 2 * MARGIN) + + # calculate scaling for zoom factor of 1.0 + if waspr > raspr then { + # window is too wide + fully := real(wh - 2 * MARGIN) / (latmax - latmin) + fullx := fully * latsin * (360 / 180) + } + else { + # window is too tall + fullx := real(ww - 2 * MARGIN) / (lonmax - lonmin) + fully := fullx / latsin / (360 / 180) + } + return +end + + + +procedure setcenter(lon, lat) + ctrlon := round(\lon | (lonmin + lonmax) / 2.0) + ctrlat := round(\lat | (latmin + latmax) / 2.0) + return +end + + + +procedure setzoom(n) + local x1, y1, x2, y2 + + curzoom := \n | 1.0 + xscale := curzoom * fullx + yscale := curzoom * fully + lonrange := integer(dx / xscale + 0.5) + latrange := integer(dy / yscale + 0.5) + + # clip out-of-bounds data because it's probably incomplete + x1 := integer((lonmin - ctrlon) * xscale - 0.5) - CLIP + x2 := integer((lonmax - ctrlon) * xscale + 0.5) + CLIP + y1 := integer((latmin - ctrlat) * yscale - 0.5) - CLIP + y2 := integer((latmax - ctrlat) * yscale + 0.5) + CLIP + + # limit clipping bounds to sensible values, else X gets confused + x1 <:= -dx + x2 >:= dx + y1 <:= -dy + y2 >:= dy + + # clip only drawing windows; NOT &window, used for copying and erasing! + every Clip(!wintbl, x1, y1, x2 - x1, y2 - y1) + return +end + + + +procedure resize() + local dxold, dyold, xshift, yshift + + dxold := dx # save old translation values + dyold := dy + + setwindow() # set window parameters for new size + + xshift := dx - dxold + yshift := dy - dyold + + # move to realign existing map with new window center + CopyArea(-dx - xshift, -dy - yshift, 2 * dx, 2 * dy, -dx, -dy) + if xshift > 0 then EraseArea(dx - xshift, -dy) + if yshift > 0 then EraseArea(-dx, dy - yshift) + + # restore scaling and clipping + setzoom(xscale / fullx) # don't change zoom, but reset other globals + + return +end + + + +procedure shift(e, nx, ny) + + while Pending()[1] === e do + Event() # consume duplicate shift events + + setcenter(ctrlon - nx / xscale, ctrlat - ny / yscale) + CopyArea(-dx, -dy, 2 * dx, 2 * dy, -dx + nx, -dy + ny) + if (nx > 0) then EraseArea(-dx, -dy, nx, 2 * dy) + if (ny > 0) then EraseArea(-dx, -dy, 2 * dx, ny) + if (nx < 0) then EraseArea(dx + nx, -dy) + if (ny < 0) then EraseArea(-dx, dy + ny) + settitle() # reset center coords in title + setzoom(curzoom) # reset clipping + + drawmap() + + return +end + + + +procedure drawmap(hilightOnly) + local line, w, worig, lon, lat, dlon, dlat, a, bdy, dim, class, fename, f + local drawProc, litFeature + + WAttrib("pointer=wait" | "pointer=watch") + + if /hilightOnly then { + EraseArea() + settitle() + } + litFeature := list() + + every f := !ifileList do { + seek(f, 1) + read(f) # skip minima line + read(f) # skip maxima line + + while line := read(f) do line ? { + + if *Pending() > 0 then { + WAttrib("pointer=cross" | "pointer=crosshair") + return + } + + w := \wintbl[class := move(2)] | next + move(1) + bdy := move(1) + if ="|" then { + fename := tab(upto('|')) + move(1) + } + else { + fename := &null + } + dim := integer(move(4)) + lon := move(7) - ctrlon + lat := move(7) - ctrlat + +# quick clip + if dim < 9999 & + (lon - dim > lonrange | lon + dim < -lonrange | + lat - dim > latrange | lat + dim < -latrange) then + next + + a := [xscale * lon, yscale * lat] + while (dlon := move(4) - 5000) & (dlat := move(4) - 5000) do + put(a, xscale * (lon +:= dlon), yscale * (lat +:= dlat)) + +# if beyond valid X range (with dx/dy margin), use library clipper + if (!a > 32000) | (!a < -32000) then + drawProc := DrawClipped + else + drawProc := DrawLine + + push(a, w) # add graphics context + + if find(\litName, map(\fename)) then { + put(litFeature, drawProc, a) + } + + if /hilightOnly then { + if any('57', bdy) & (a[1] := \wintbl["Y" || bdy]) then { + drawProc ! a # draw boundary indicator + if any('F', class) then + next # chain is ONLY a boundary + a[1] := w + } + drawProc ! a # draw line itself + } + } + } + if w := \wintbl["LL"] then { + repeat { + drawProc := get(litFeature) | break + a := get(litFeature) | break + a[1] := w # replace graphics context + drawProc ! a + } + } + + WAttrib("pointer=cross" | "pointer=crosshair") + return +end + + + +procedure identify(x, y) + local line, lon, lat, dlon, dlat, dim, s, f + local fename, cfcc, bndry, x0, y0, w, h + local features + + WAttrib("pointer=wait" | "pointer=watch") + + # calculate region of interest in lat/lon coordinates + x := (x - EPSILON) / xscale + y := (y - EPSILON) / yscale + w := (1 + 2 * EPSILON) / xscale + h := (1 + 2 * EPSILON) / yscale + + features := set() + every f := !ifileList do { + seek(f, 1) + read(f) # skip minima line + read(f) # skip maxima line + + while line := read(f) do line ? { + + if *Pending() > 0 then { + WAttrib("pointer=cross" | "pointer=crosshair") + return + } + + cfcc := move(3) + bndry := move(1) + if ="|" then { # get feature name + fename := tab(upto('|')) + move(1) + } + else { + fename := "" + } + dim := integer(move(4)) + lon := move(7) - ctrlon + lat := move(7) - ctrlat + if dim < 9999 & + (lon - dim > lonrange | lon + dim < -lonrange | + lat - dim > latrange | lat + dim < -latrange) then + next + + x0 := lon + y0 := lat + while (dlon := move(4) - 5000) & (dlat := move(4) - 5000) do { + lon +:= dlon + lat +:= dlat + if ClipLine([x0, y0, lon, lat], x, y, w, h) then { + s := case bndry of { + "9":" (national boundary) " + "8":" (state boundary) " + "7":" (county boundary) " + "5":" (city limit) " + "0":" " + } + insert(features, cfcc || s || fename) + } + x0 := lon + y0 := lat + } + } + } + WAttrib("pointer=cross" | "pointer=crosshair") + Popup(, , , WAttrib("leading") * (0 ~= *features), popList, sort(features)) + return +end + + + +procedure popList(l) + WAttrib("row=1", "col=1") + every WWrite(!l) + until Active() +end + + + +procedure settitle() + local lon, lat + + lon := ctrlon * (360.0 / 9999999) + if lon > 180.0 then + lon -:= 360.0 + lat := 90.0 - ctrlat * (180.0 / 9999999) + title := fnameList[1] + if *fnameList > 1 then + title ||:= "..." + title ||:= ": " || dms(lon, "W", "E") || " " || dms(lat, "S", "N") + WAttrib("label=" || title) + return +end + + + +procedure dms(n, s1, s2) + local deg, min, sec + + if n < 0 then + n := -n + else + s1 := s2 + + deg := integer(n) + n := (n - deg) * 60 + min := integer(n) + n := (n - min) * 60 + sec := integer(n + 0.5) + + return deg || "\260" || right(min, 2, "0") || "'" || + right(sec, 2, "0") || "\"" || s1 +end + + + +procedure setregion(lomin, lomax, ltmin, ltmax) + local xzoom, yzoom + + setcenter((lomin + lomax + 1) / 2, (ltmin + ltmax + 1) / 2) + xzoom := ((dx - MARGIN) * 2 / fullx) / (lomax - lomin) + yzoom := ((dy - MARGIN) * 2 / fully) / (ltmax - ltmin) + if xzoom < yzoom then + setzoom(xzoom) + else + setzoom(yzoom) + return +end + + + +# setclasses() -- initialize table of classifications +# +# The order used here is reflected in the Layers dialog box. + +procedure setclasses() + local c, w, mcolors, m + + clist := [ # classification list + # prefix, psgray&w, label, color, width + class("A1", .0, 4, "roads", "black", 3), # freeway/tollway + class("A2", .0, 2, "roads", "black", 2), # primary road + class("A3", .0, 1, "roads", "black"), # secondary road + class("A4", .0, 0, "roads", "white"), # local road + class("A", .0, 0, "roads", "white"), # other road + class("B1", .4, 2, "railroads", "deep green", 2), # railroad line + class("B", .4, 1, "railroads", "deep green"), # r.r. spur, yard, etc. + class("H", .7, 1, "water", "dark cyanish blue"), # water + class("Y7", .9, 5, "major boundaries", "orange", 3), # county + class("Y5", .9, 3, "major boundaries", "orange", 2), # city + class("E", .9, 1, "minor boundaries", "light orange"), # visible + class("F", .9, 1, "minor boundaries", "light orange"), # invisible + class("D", .0, 1, "landmarks", "dark red"), # landmark + class("C", .5, 1, "piplines & power", "purple"), # pipe, power + class("LL", .2, 2, "highlighted feature", "yellow", 10), # hilit feature + class("T0", .8, 3, "GPS track", "dark greenish cyan", 2), # Track data + class("X", .8, 1, "unclassified", "purple")] # unclassified + + every c := !clist do + c.vispfx := c.prefix # initially, all layers visible + + ctable := table() + every c := !clist do + if *c.prefix = 1 then + every /ctable[c.prefix || !"0123456789"] := c + else + ctable[c.prefix] := c + + wintbl := table() # global window table + mcolors := table() # local table of mutable colors + + every c := !clist do { + + w := Clone() | stop("can't clone window for ", c.label) + /mcolors[c.color] := NewColor(w, c.color) # may fail + c.index := mcolors[c.color] + Fg(w, \c.index | c.color) | stop("can't set color for ", c.label) + + WAttrib(w, "linewidth=" || \c.width) + wintbl[c.prefix] := w + if *c.prefix = 1 then + every /wintbl[c.prefix || (0 to 9)] := w + } + return +end + + + +# setlayers() -- bring up layers dialog + +procedure setlayers() + local c, i, defaults, buttons, choice, lset + static labels, values + + initial { + lset := set() + labels := list() + values := list() + every c := !clist do + if \c.index & not member(lset, c.label) then { + insert(lset, c.label) + put(labels, c.label) + put(values, 1) + } + } + + if *labels = 0 then { + Notice("No layer control available") + fail + } + + while choice ~=== "Okay" do { # loop when "Apply" selected + + defaults := values + buttons := ["Okay", "Apply", "Cancel"] + choice := ToggleDialog(msgwin, "Layers:", labels, defaults, buttons) + if choice == "Cancel" then + fail + values := dialog_value + + # change mutable color for every item that changed in the dialog + every i := 1 to *values do + if values[i] ~=== defaults[i] then + every c := !clist do + if c.label == labels[i] then { + if \values[i] then { + Color(\c.index, c.color) + c.vispfx := c.prefix + } + else { + Color(\c.index, Bg()) + c.vispfx := &null + } + } + } + return +end + + + +procedure writelch(ofile) + local line, dim, lon, lat, f, a, b, x, y, dlon, dlat, nlon, nlat, w, head + local startlon, startlat, minlon, minlat, maxlon, maxlat, deltas, class + + write(ofile, " ", + right(ctrlon - lonrange, 7), right(ctrlat - latrange, 7)) + write(ofile, " ", + right(ctrlon + lonrange, 7), right(ctrlat + latrange, 7)) + + every f := !ifileList do { + seek(f, 1) + read(f) # skip minima line + read(f) # skip maxima line + + while line := read(f) do line ? { + w := \wintbl[class := move(2)] | next + head := class || move(2) + if ="|" then { + head ||:= "|" || tab(upto('|') + 1) + } + dim := integer(move(4)) + lon := move(7) - ctrlon + lat := move(7) - ctrlat +# quick clip + if dim < 9999 & + (lon - dim > lonrange | lon + dim < -lonrange | + lat - dim > latrange | lat + dim < -latrange) then + next + + a := [xscale * lon, yscale * lat] + while (dlon := move(4) - 5000) & (dlat := move(4) - 5000) do + put(a, xscale * (lon +:= dlon), yscale * (lat +:= dlat)) + a := Coalesce(ClipLine(w, a)) | next + every b := !a do { + deltas := "" + startlon := minlon := maxlon := lon := + round(get(b) / xscale) + ctrlon + startlat := minlat := maxlat := lat := + round(get(b) / yscale) + ctrlat + while nlon := round(get(b) / xscale) + ctrlon do { + nlat := round(get(b) / yscale) + ctrlat + deltas ||:= right(nlon - lon + 5000, 4, "0") + deltas ||:= right(nlat - lat + 5000, 4, "0") + lon := nlon + lat := nlat + maxlon <:= lon + minlon >:= lon + maxlat <:= lat + minlat >:= lat + } + dim := startlon - minlon + dim <:= maxlon - startlon + dim <:= startlat - minlat + dim <:= maxlat - startlat + dim >:= 9999 + + write(ofile, head, right(dim, 4), right(startlon, 7, "0"), + right(startlat, 7, "0"), deltas) + } + } + } + return +end + +# writeppm(ofile) -- write PPM image to ofile +# +# comments note latitude and longitude bounds in arc-seconds + +procedure writeppm(ofile) + local w, h, rw, rh, s, lon, lat, dlon, dlat + + w := WAttrib("width") + h := WAttrib("height") + rw := real(w) + rh := real(h) + + lon := ctrlon * (360.0 / 9999999) + if lon > 180.0 then + lon -:= 360.0 + lat := 90.0 - ctrlat * (180.0 / 9999999) + + dlon := lonrange * (360.0 / 9999999) + dlat := latrange * (180.0 / 9999999) + + write(ofile, "P6") + write(ofile, "#RTIN") + write(ofile, "#lon,lat:", + arcs(lon - dlon), arcs(lat - dlat), arcs(lon - dlon), arcs(lat + dlat), + arcs(lon + dlon), arcs(lat + dlat), arcs(lon + dlon), arcs(lat - dlat)) + write(ofile, "#x,y: 0.0 0.0 0.0 ", rh, " ", rw, " ", rh, " ", rw, " 0.0") + write(ofile, w, " ", h) + write(ofile, 255) + + every writes(ofile, rgb24(Pixel(tmpwin))) + + return +end + + + +# arcs(n) -- format latitude or longitude in arc-seconds with leading space + +procedure arcs(n) + return " " || (n * 3600.0) +end + + + +# rgb24(k) -- return 24-bit (3-byte) r-g-b value for k + +procedure rgb24(k) + local s, r, g, b + static t + initial t := table() + + if s := \t[k] then + return s + + (ColorValue(k | Color(k)) | fail) ? { + s := char(tab(upto(',')) / 256) + move(1) + s ||:= char(tab(upto(',')) / 256) + move(1) + s ||:= char(tab(0) / 256) + } + t[k] := s + return s +end + + + +# writeps(ofile) -- write Encapsulated PostScript to ofile + +procedure writeps(ofile) + local x1, x2, y1, y2, line, prevcode, code, dim, lon, lat, a, n, c, f + + x1 := integer((lonmin - ctrlon) * xscale - 0.5) - CLIP + y1 := integer((latmin - ctrlat) * yscale - 0.5) - CLIP + x2 := integer((lonmax - ctrlon) * xscale + 0.5) + CLIP + y2 := integer((latmax - ctrlat) * yscale + 0.5) + CLIP + x1 <:= -dx + y1 <:= -dy + x2 >:= dx + y2 >:= dy + epsheader(ofile, (dx + x1) * PSSCALE, (dy - y2) * PSSCALE, + (x2 - x1) * PSSCALE, (y2 - y1) * PSSCALE, "r") + + every write(ofile, ![ + "/m { moveto } bind def", + "/r { rlineto } bind def", + "/s { stroke } bind def", + "/w { .00666667 mul inch setlinewidth setgray stroke } bind def"]) + + every c := !clist do + write(ofile, "/", left(\c.vispfx, 2), + " { ", c.psgray, " ", c.pswidth, " w } bind def") + + every f := !ifileList do { + seek(f, 1) + read(f) # skip minima line + read(f) # skip maxima line + + while line := read(f) do line ? { + code := \ctable[move(2)].vispfx | next + move(2) +# skip feature name + if ="|" then + tab(upto('|') + 1) + dim := integer(move(4)) + lon := xscale * (move(7) - ctrlon) + lat := yscale * (move(7) - ctrlat) + if dim < 9999 & + (lon - dim > lonrange | lon + dim < -lonrange | + lat - dim > latrange | lat + dim < -latrange) then + next + else { + writes(ofile, integer(PSSCALE * (dx + lon)), " ", + integer(PSSCALE * (dy - lat)), " m") + while lon := move(4) - 5000 & lat := move(4) - 5000 do + writes(ofile, "\n", integer(PSSCALE * xscale * lon), " ", + integer(-PSSCALE * yscale * lat), " r") + write(ofile, " ", (prevcode ~===:= code) | "s") + } + } + } + write(ofile, "showpage") + return +end diff --git a/ipl/gpacks/tiger/tgrmerge.icn b/ipl/gpacks/tiger/tgrmerge.icn new file mode 100644 index 0000000..78942c6 --- /dev/null +++ b/ipl/gpacks/tiger/tgrmerge.icn @@ -0,0 +1,59 @@ +############################################################################ +# +# File: tgrmerge.icn +# +# Subject: Program to merge line chain files +# +# Authors: Gregg M. Townsend and William S. Evans +# +# Date: June 9, 2000 +# +############################################################################ +# +# usage: tgrmerge file.lch ... +# +# Tgrmerge merges multiple line chain files to produce a single +# output file. +# +############################################################################ + +procedure main(args) + local f, fname, line, lat, lon + local minlat, maxlat, minlon, maxlon + + if *args = 0 then + stop("usage: ", &progname, " file.lch ...") + minlat := minlon := 9999999 + maxlat := maxlon := 0 + + every fname := !args do { + f := open(fname) | stop("can't open ", fname) + line := read(f) | stop("empty file: ", fname) + line ? { + move(8) + lon := move(7) + lat := move(7) + minlon >:= lon + minlat >:= lat + } + line := read(f) | stop("truncated file: ", fname) + line ? { + move(8) + lon := move(7) + lat := move(7) + maxlon <:= lon + maxlat <:= lat + } + close(f) + } + + write(" ", right(minlon, 7), right(minlat, 7)) + write(" ", right(maxlon, 7), right(maxlat, 7)) + every fname := !args do { + f := open(fname) | stop("can't open ", fname) + read(f) + read(f) + while write(read(f)) + close(f) + } +end diff --git a/ipl/gpacks/tiger/tgrprep.icn b/ipl/gpacks/tiger/tgrprep.icn new file mode 100644 index 0000000..c510b20 --- /dev/null +++ b/ipl/gpacks/tiger/tgrprep.icn @@ -0,0 +1,273 @@ +############################################################################ +# +# File: tgrprep.icn +# +# Subject: Program to prepare TIGER line chains +# +# Authors: Gregg M. Townsend and William S. Evans +# +# Date: June 9, 2000 +# +############################################################################ +# +# Tgrprep writes files of "line chain" data extracted from Census Bureau +# TIGER/Line data files. The main purpose of this is to prepare +# input for the "tgrmap" program. +# +# Usage: tgrprep rec1file rec2file +# +# rec1file: tgr*.rt1 file containing Type 1 (chain) data +# rec2file: tgr*.rt2 file containing Type 2 (shape point) data +# +############################################################################ +# +# Output consists of: +# +# Line 1: the smallest longitude and latitude found in the Type 1 file +# Line 2: the largest longitude and latitude found in the Type 1 file +# Line 3-n: chain specifications, one per line, in the following format +# +# (3 chars) census feature class code (CFCC) +# (1 char) boundary code (see below) +# (varies) optional feature name, delimted by '|' (see below) +# (4 chars) max dimension (latitude or longitude units), max 9999 +# (7 chars) starting longitude, fraction E of Greenwich meridian +# (7 chars) starting latitude, fraction S of North Pole +# (4 chars) delta longitude to first point, same units, plus 5000 +# (4 chars) delta latitude to first point, same units, plus 5000 +# followed by any number (zero or more) of additional delta pairs. +# Output lines may be arbitrarily long. +# +# Boundary codes are: +# 9 national boundary (not used) +# 8 state boundary (not used) +# 7 county boundary +# 5 city limits +# 0 other, unknown, not a boundary +# +# Feature name is the concatenation of the following TIGER fields +# "Feature Direction, Prefix" +# "Feature Name" +# "Feature Type" +# "Feature Direction, Suffix" +# The concatenation is surrounded by vertical bars "|" unless it is empty +# (all spaces). Any "|" within a TIGER field is replaced by "!". +# +# For input formats and the definition of CFCC codes, see +# TIGER/Line Files, 1998 Technical Documentation +# Bureau of the Census, Washington, DC, 1998. +# http://www.census.gov/geo/www/tiger/tiger98.pdf +############################################################################ + + +global minlon, maxlon # min/max longitude seen (in input terms) +global minlat, maxlat # min/max latitude seen (in input terms) + +global curlon, curlat # current longitude/latitude for output +global deltas # string of deltas for output + + +procedure main(args) + local details, file1, file2, n + + *args = 2 | stop("usage: ", &progname, " rec1file rec2file") + file1 := open(args[1]) | stop("can't open ", args[1]) + file2 := open(args[2]) | stop("can't open ", args[2]) + + write(&errout, "prescanning ", args[1]) + n := llrange(file1) + write(&errout, right(n, 10), " chain records") + write(" ", rz(cvlon(minlon)), rz(cvlat(maxlat))) + write(" ", rz(cvlon(maxlon)), rz(cvlat(minlat))) + + write(&errout, "prescanning ", args[2]) + details := dtindex(file2) + write(&errout, right(*details, 10), " supplemental sets") + + write(&errout, "scanning ", args[1]) + n := scan(file1, file2, details) + write(&errout, right(n, 10), " supplements used") + write(&errout, "done") +end + + +# scan(file1, file2, details) -- scan records and write output. +# +# returns the number of supplements referenced. + +procedure scan(file1, file2, details) + local line, tlid, cfcc, lon, lat, n, l, r + local startlon, startlat, endlon, endlat, dim, bound, fename + + n := 0 + seek(file1, 1) + while line := read(file1) do line ? { + ="1" | next + tab(6) + tlid := move(10) + tab(18) + + fename := "" + fename ||:= " " || ("" ~== trim(move(2) \ 1)) # direction prefix + fename ||:= " " || ("" ~== trim(move(30) \ 1)) # name + fename ||:= " " || ("" ~== trim(move(4) \ 1)) # type + fename ||:= " " || ("" ~== trim(move(2) \ 1)) # direction prefix + if fename ~== "" then + fename := "|" || map(fename[2:0], "|", "!") || "|" + + tab(56) + cfcc := move(3) + bound := "0" + + tab(135) + l := move(3) #left county code + r := move(3) #right county code + if l ~== r then #different --> county boundary + bound := "7" + else { + tab(161) + l := move(5) #left city code + r := move(5) #right city code + if l ~== r then #different --> city boundary + bound := "5" + } + + tab(191) + startlon := curlon := minlon := maxlon := cvlon(move(10)) + startlat := curlat := minlat := maxlat := cvlat(move(9)) + endlon := cvlon(move(10)) + endlat := cvlat(move(9)) + + deltas := "" + if seek(file2, \details[tlid]) then { + n +:= 1 + while line := read(file2) do line ? { + tab(6) + =tlid | break + tab(19) + every 1 to 10 do + drawto(cvlon(0 ~= move(10)), cvlat(0 ~= move(9))) + } + } + drawto(endlon, endlat) + + dim := startlon - minlon + dim <:= maxlon - startlon + dim <:= startlat - minlat + dim <:= maxlat - startlat + dim >:= 9999 + + write(cfcc, bound, fename, + right(dim, 4), rz(startlon), rz(startlat), deltas) + } + return n +end + + +# drawto(lon, lat) -- append deltas, updating curlon/curlat + +procedure drawto(lon, lat) + local dlon, dlat + + dlon := lon - curlon + dlat := lat - curlat + + if abs(dlon | dlat) >= 5000 then { + drawto(curlon + dlon / 2, curlat + dlat / 2) + drawto(lon, lat) + } + else { + deltas ||:= rz(dlon + 5000, 4) + deltas ||:= rz(dlat + 5000, 4) + curlon := lon + curlat := lat + minlon >:= lon + maxlon <:= lon + minlat >:= lat + maxlat <:= lat + } + return +end + + + +# rz(v, n) -- right-justify value in n digits with zero fill + +procedure rz(v, n) + /n := 7 + return right(v, n, "0") +end + + + +# cvlon(n) -- convert longitude to output form +# +# (Fraction of circle east of Greenwich, as 0000000 to 9999999). + +procedure cvlon(n) + static m + initial m := 9999999 / 360.0 / 1000000 + + n := integer(n) + if n < 0 then + n +:= 360000000 + return integer(m * n) +end + + +# cvlat(n) -- convert latitude to output form +# +# (Fraction of semicircle south of North Pole, as 0000000 to 9999999). + +procedure cvlat(n) + static m + initial m := 9999999 / 180.0 / 1000000 + return integer(m * (90000000 - n)) +end + + + +# dtindex(f) -- return table of record indices by TLID from file f + +procedure dtindex(f) + local details, line, w + + details := table() + seek(f, 1) + while (w := where(f)) & (line := read(f)) do line ? { + ="2" | next + tab(6) + /details[move(10)] := w + } + return details +end + + + +# llrange(f) -- scan f to set min/max lon/lat, returning record count + +procedure llrange(f) + local line, n, lon, lat + + minlon := +180000000 + maxlon := -180000000 + minlat := +90000000 + maxlat := -90000000 + n := 0 + + seek(f, 1) + while line := read(f) do line ? { + ="1" | next + n +:= 1 + tab(191) + every 1 | 2 do { + lon := integer(move(10)) + lat := integer(move(9)) + minlon >:= lon + maxlon <:= lon + minlat >:= lat + maxlat <:= lat + } + } + return n +end diff --git a/ipl/gpacks/tiger/tgrquant.icn b/ipl/gpacks/tiger/tgrquant.icn new file mode 100644 index 0000000..de1f6a7 --- /dev/null +++ b/ipl/gpacks/tiger/tgrquant.icn @@ -0,0 +1,58 @@ +############################################################################ +# +# File: tgrquant.icn +# +# Subject: Program to quantize a line chain file +# +# Authors: Gregg M. Townsend and William S. Evans +# +# Date: December 18, 1999 +# +############################################################################ +# +# usage: tgrquant [n] [file.tgr] +# +# Tgrquant copies a chain file, deliberately losing precision by +# rounding down each coordinate value to a multiple of n (default 10). +# +############################################################################ + +procedure main(args) + local n, fname, ifile, line + local prefix, fename, dim, lon, lat, rndlon, rndlat, newrlon, newrlat + + if n := integer(args[1]) then + get(args) + else + n := 10 + + if fname := get(args) then + ifile := open(fname) | stop("can't open ", fname) + else + ifile := &input + + if *args > 0 then + stop("usage: ", &progname, " [n] [file.lch]") + + while line := read(ifile) do line ? { + prefix := move(4) + if ="|" then + fename := "|" || tab(upto('|')) || move(1) + else + fename := "" + dim := move(4) + lon := move(7) + lat := move(7) + rndlon := lon - lon % n + rndlat := lat - lat % n + writes(prefix, fename, dim, right(rndlon, 7), right(rndlat, 7)) + while (lon +:= move(4) - 5000) & (lat +:= move(4) - 5000) do { + newrlon := lon - lon % n + newrlat := lat - lat % n + writes(right(newrlon-rndlon+5000, 4), right(newrlat-rndlat+5000, 4)) + rndlon := newrlon + rndlat := newrlat + } + write() + } +end diff --git a/ipl/gpacks/tiger/tgrsort b/ipl/gpacks/tiger/tgrsort new file mode 100755 index 0000000..825f5bd --- /dev/null +++ b/ipl/gpacks/tiger/tgrsort @@ -0,0 +1,31 @@ +#!/bin/sh +# +# tgrsort [file] -- sort TIGER line chains +# +# Sort keys are: +# +# 1. CFCC feature class, in this order: +# boundary +# water +# other topographic feature (rare) +# road +# railroad +# pipeline, power line, etc. +# landmark +# unclassified +# +# 2. Major category, largest (least significant) first +# +# The feature class and category sorting is chosen so that more important +# chains are drawn later, obscuring lesser chains, instead of the reverse. +# +# Note that this sorting can reverse the positions of the first two lines +# of the file (the min/max lines), but tgrmap.icn can handle that. + +TR1=FHEABCDX +TR2=JKLMNPQR + +cat $1 | +tr $TR1 $TR2 | +sort -t: -k 1.1,1.1 -k 1.2,1.3r -k 1.4 | +tr $TR2 $TR1 diff --git a/ipl/gpacks/tiger/tgrstats b/ipl/gpacks/tiger/tgrstats new file mode 100755 index 0000000..36cdd09 --- /dev/null +++ b/ipl/gpacks/tiger/tgrstats @@ -0,0 +1,5 @@ +#!/bin/sh +# +# tgrstats [file...] -- report counts by CFCC code from .lch files + +cut -c1-3 $* | sort | uniq -c diff --git a/ipl/gpacks/tiger/tgrstrip b/ipl/gpacks/tiger/tgrstrip new file mode 100755 index 0000000..46338e0 --- /dev/null +++ b/ipl/gpacks/tiger/tgrstrip @@ -0,0 +1,13 @@ +#!/bin/sh +# +# tgrstrip [file] -- remove details from line chain file +# +# Filters a line chain file to remove hydrology (water), pipelines, +# powerlines, and minor roads, except when any of these coincides +# with a major boundary line. The effect of this is to produce a +# much smaller file with less detail. + +sed ' + /^[CEFH]..0/d + /^A[4-9].0/d +' $* diff --git a/ipl/gpacks/tiger/tgrtrack.icn b/ipl/gpacks/tiger/tgrtrack.icn new file mode 100644 index 0000000..07a25f2 --- /dev/null +++ b/ipl/gpacks/tiger/tgrtrack.icn @@ -0,0 +1,168 @@ +############################################################################ +# +# File: tgrtrack.icn +# +# Subject: Program to translate "track log" files into TIGER chains +# +# Author: William S. Evans and Gregg M. Townsend +# +# Date: June 9, 2000 +# +############################################################################ +# +# tgrtrack reads a fixed field length file containing track data from +# a GPS receiver and outputs a "line chain" (.lch) format file (see +# tgrprep) that can then be viewed using tgrmap. +# +# Usage: tgrtrack file +# +# Input is a text file of coordinates such as those from a GPS +# receiver. Lines ending with two decimal values are interpreted +# as specifying latitude and longitude in that order. +# Lines without data indicate breaks between paths. +# +# Output is a line chain file +# +############################################################################ +# +# Links: numbers, strings +# +############################################################################ + +link numbers +link strings + +global deltas +global curlon, curlat +global maxlon, minlon, maxlat, minlat + +procedure main(args) + local n, trackfile + + *args = 1 | stop("usage: ", &progname, " GPStrackfile") + trackfile := open(args[1]) | stop("can't open ", args[1]) + n := llrange(trackfile) + write(" ", rz(convertLon(minlon)), rz(convertLat(maxlat))) + write(" ", rz(convertLon(maxlon)), rz(convertLat(minlat))) + writeLCH(trackfile) + return +end + +procedure convertLat(n) +# convert latitude from decimal degrees to fraction of semicircle +# south of North Pole, as 0000000 to 9999999. + static m + initial m := 9999999 / 180.0 + return round(m * (90.0 - n)) +end + +procedure convertLon(n) +# convert longitude to fraction of circle east of Greenwich, +# as 0000000 to 9999999. + static m + initial m := 9999999 / 360.0 + + n := real(n) + if n < 0 then + n +:= 360.0 + return round(m * n) +end + + +procedure writeLCH(trackfile) + local x, y, line, n, trackPts, dim, startlon, startlat, lon, lat, w + + n := 1 + trackPts := 0 + deltas := "" + + seek(trackfile, 1) | fail + repeat { + line := read(trackfile) | "stop" + every put(w := [], words(line)) + if (lat := real(w[-2])) & (lon := real(w[-1])) & + (-90. <= lat <= 90.) & (-180. <= lon <= 180.) then { + y := convertLat(lat) + x := convertLon(lon) + if (trackPts = 0) then { # starting a new track + deltas := "" + startlon := minlon := maxlon := curlon := x + startlat := minlat := maxlat := curlat := y + } + else { + drawto(x, y) + } + trackPts +:= 1 + } + else { + if trackPts >= 2 then { + dim := startlon - minlon + dim <:= maxlon - startlon + dim <:= startlat - minlat + dim <:= maxlat - startlat + dim >:= 9999 + write("T000|GPS Track ", n, "|", right(dim, 4), + rz(startlon), rz(startlat), deltas) + n +:= 1 + } + trackPts := 0 + } + if w[1] == "stop" then break + } + return +end + +procedure drawto(lon, lat) + local dlon, dlat + + dlon := lon - curlon + dlat := lat - curlat + + if abs(dlon | dlat) >= 5000 then { + drawto(curlon + dlon / 2, curlat + dlat / 2) + drawto(lon, lat) + } + else { + deltas ||:= rz(dlon + 5000, 4) + deltas ||:= rz(dlat + 5000, 4) + curlon := lon + curlat := lat + minlon >:= lon + maxlon <:= lon + minlat >:= lat + maxlat <:= lat + } + return +end + + +procedure rz(v, n) +# right-justify value in n digits with zero fill + /n := 7 + return right(v, n, "0") +end + + +procedure llrange(f) +# scan f to set min/max lon/lat, returning record count + local line, n, lon, lat, w + + minlon := +180.0 + maxlon := -180.0 + minlat := +90.0 + maxlat := -90.0 + n := 0 + + seek(f, 1) + while line := read(f) do line ? { + every put(w := [], words(line)) + if (lat := real(w[-2])) & (lon := real(w[-1])) & + (-90. <= lat <= 90.) & (-180. <= lon <= 180.) then { + minlon >:= lon + maxlon <:= lon + minlat >:= lat + maxlat <:= lat + } + } + return n +end diff --git a/ipl/gpacks/vib/Makefile b/ipl/gpacks/vib/Makefile new file mode 100644 index 0000000..69283df --- /dev/null +++ b/ipl/gpacks/vib/Makefile @@ -0,0 +1,35 @@ +# Makefile for vib, the Visual Interface Builder + +ICONT = icont +IFLAGS = -us +ITRAN = $(ICONT) $(IFLAGS) + +OBJ = vib.u2 vibbttn.u2 vibedit.u2 vibfile.u2 vibglbl.u2 \ + viblabel.u2 vibline.u2 viblist.u2 vibmenu.u2 vibradio.u2 \ + vibrect.u2 vibsizer.u2 vibslidr.u2 vibtalk.u2 vibtext.u2 + +.SUFFIXES: .icn .u2 .gif .ps + +.icn.u2: ; $(ITRAN) -c $< +.icn: ; $(ITRAN) $< + +.gif.ps: + giftoppm $< | ppmtopgm | pnmtops -scale .75 >$@ + +vib: $(OBJ) + $(ITRAN) -o vib $(OBJ) + +$(OBJ): vibdefn.icn + + +ipd doc: ipd265.ps + +ipd265.ps: ipd265.bibl fig1.ps fig2.ps + bib -t stdn -p /r/che/usr/ralph/docs/reg.index <ipd265.bibl | \ + psfig | psroff -t >ipd265.ps + +Iexe: vib + cp vib ../../iexe/ + +clean Clean: + rm -f vib *.ps *.u[12] app vibpro* core busy dlog diff --git a/ipl/gpacks/vib/busy.icn b/ipl/gpacks/vib/busy.icn new file mode 100644 index 0000000..da3095f --- /dev/null +++ b/ipl/gpacks/vib/busy.icn @@ -0,0 +1,144 @@ +# busy.icn -- vib application demo and tester +# +# A complex user interface that does nothing useful +# (except to assist in testing VIB) + +link vsetup + +global vidgets + + +# main procedure + +procedure main(args) + + vidgets := ui(args, cbk) # set up vidgets + + VSetItems(vidgets["list1"], + ["Select", " your", "custom", "pizza", "below"]) + VSetItems(vidgets["list2"], + ["individual", "small", "medium", "large", "family"]) + VSetItems(vidgets["list3"], + ["anchovies", "bacon", "black olive", "bell pepper", "broccoli", + "capicolla", "garlic", "green olive", "linguisa", "mushroom", "onion", + "pepperoni", "pineapple", "sausage", "spinach", "tomato", "extra cheese"]) + + GetEvents(vidgets["root"], quitcheck) # enter event loop +end + + +# quitcheck() -- handle events that fall outside the vidgets + +procedure quitcheck(e) + if e === QuitEvents() then + exit() + else + write("unhandled event: ", image(e)) +end + + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=490,401", "bg=pale gray", "label=An Icon Busy-Box"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,490,401:An Icon Busy-Box",], + ["DUMP:Button:regular::11,31,73,20:DUMP",dump], + ["QUIT:Button:regular::11,56,73,20:QUIT",quit], + ["Toggles:Label:::25,159,49,13:Toggles",], + ["b1:Button:regular::129,189,28,27:1",], + ["b2:Button:regular::129,216,28,27:2",], + ["b3:Button:regular::129,243,28,27:3",], + ["b4:Button:regular::129,270,28,27:4",], + ["b5:Button:regular::129,297,28,27:5",], + ["check1:Button:xbox:1:21,282,37,37:",], + ["checko:Button:check:1:123,108,69,20:checko",], + ["circlo:Button:circle:1:123,83,69,20:circlo",], + ["line1:Line:::128,154,186,171:",], + ["line2:Line:::131,147,189,164:",], + ["line3:Line:::12,24,150,24:",], + ["list1:List:r::350,10,120,115:",], + ["list2:List:w::350,141,120,115:",], + ["list3:List:a::350,274,120,115:",], + ["menu1:Menu:pull::12,110,71,21:Food Menu",foodhandler, + ["American", + ["Burgers","Barbecue","Tex-Mex","Creole","New England"], + "Chinese", + ["Cantonese","Mandarin","Szechuan"], + "Greek","Italian", + ["Pasta","Pizza","Sandwiches", + ["Grinder","Hoagie","Poor Boy","Submarine"]], + "Mexican", + ["Sonoran","Chihuahuan","Angelino","Taco Bell"], + "Japanese","Korean","French","German","English", + "Scottish","Irish"]], + ["sbar1:Scrollbar:v:1:316,10,18,379:77,22,66",], + ["sbar2:Scrollbar:h::20,345,280,18:999,1,777",], + ["slider1:Slider:h::20,369,280,18:0,1000,200",], + ["slider2:Slider:v:1:290,10,18,312:33,67,44",], + ["stations:Choice::5:204,83,57,105:",, + ["KUAT","KUAZ","KXCI","KJZZ","WOI"]], + ["tcheck:Button:checkno:1:23,235,62,20:check",], + ["tcircle:Button:circleno:1:22,256,69,20:circle",], + ["text:Text::12:122,54,157,19:password:\\=swordfish",], + ["title1:Label:::11,10,126,13:Some VIB Experimen",], + ["title2:Label:::137,10,14,13:ts",], + ["tline:Line:::26,181,92,181:",], + ["tregular:Button:regular:1:23,189,56,20:regular",], + ["tsimple:Button:regularno:1:24,213,77,20:no-outline",], + ["xgrooved:Button:xboxno:1:64,284,33,33:",], + ["rectx:Rect:grooved::62,282,37,37:",], + ["rect1:Rect:grooved::188,202,30,50:",], + ["rect2:Rect:sunken::229,201,30,50:",], + ["rect3:Rect:raised::188,263,30,50:",], + ["rect4:Rect:invisible::230,263,30,50:",], + ["trect:Rect:grooved::12,151,98,176:",], + ) +end +#===<<vib:end>>=== end of section maintained by vib + + +procedure cbk(v, x) + writes("CALLBACK: ") + VEcho(v, x) + return +end + +procedure foodhandler(v, x) + writes("FOOD: ") + every writes(" ", !x) + write() + return +end + +procedure dump(v, x) + local l, id + + write() + write("key v.id VGetState(v) image(v)") + write("--------- --------- ------------ -----------------------------") + l := sort(vidgets, 3) + while id := get(l) do { + v := get(l) + write(left(\id | "**NULL**", 12), left(\v.id | "**NULL**", 12), + left(vimage(VGetState(v)) | "---", 15), image(v)) + } + write() + return +end + +procedure vimage(a) + local s + + if (type(a) ~== "list") then + return image(a) + s := "[" + every s ||:= image(!a) || "," + return s[1:-1] || "]" +end + +procedure quit(v, x) + exit() +end diff --git a/ipl/gpacks/vib/dlog.icn b/ipl/gpacks/vib/dlog.icn new file mode 100644 index 0000000..13dc394 --- /dev/null +++ b/ipl/gpacks/vib/dlog.icn @@ -0,0 +1,40 @@ +# dlog.icn -- VIB dialog box demo and test program + +procedure main(args) + Window("font=sans,bold,24", args) + WAttrib("fillstyle=textured", "pattern=grains") + FillRectangle() + WAttrib("fillstyle=solid") + CenterString(247, 102, "Dialog Box Test") + Fg("white") + CenterString(250, 100, "Dialog Box Test") + while dl() ~== "quit" +end + +link dsetup + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure dl(win, deftbl) +static dstate +initial dstate := dsetup(win, + [":Sizer::1:0,0,270,300:",], + ["checkbox:Button:check:1:29,52,83,20:checkbox",], + ["line:Line:::15,233,255,233:",], + ["ne:Button:regular:1:235,0,35,20:ne",], + ["nw:Button:regular:1:0,0,35,20:nw",], + ["quit:Button:regular::137,257,49,20:quit",], + ["radio:Choice::4:180,49,57,84:",, + ["KUAT","KUAZ","KMCI","KJZZ"]], + ["repeat:Button:regular:-1:70,256,49,20:repeat",], + ["scroller:Scrollbar:h:1:35,183,200,18:0.0,1.0,0.5",], + ["se:Button:regular:1:235,280,35,20:se",], + ["slider:Slider:h:1:35,154,200,18:0.0,1.0,0.5",], + ["sw:Button:regular:1:0,280,35,20:sw",], + ["text:Text::11:34,112,122,19:Text:\\=",], + ["title:Label:::73,17,105,13:Dialog Box Test",], + ["xbox:Button:xbox:1:30,80,25,25:",], + ["xlabel:Label:::65,85,28,13:xbox",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/vib.icn b/ipl/gpacks/vib/vib.icn new file mode 100644 index 0000000..1423036 --- /dev/null +++ b/ipl/gpacks/vib/vib.icn @@ -0,0 +1,318 @@ +############################################################################ +# +# File: vib.icn +# +# Subject: Program to build Icon interfaces +# +# Authors: Mary Cameron and Gregg M. Townsend +# +# Date: May 25, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# For documentation, see IPD284: +# http://www.cs.arizona.edu/icon/docs/ipd284.htm +# +############################################################################ + +# Version 1 (XIB): Original version +# Version 2 (VIB): Compact specifications in same file as source +# Version 3 (VIB, Dec 94): 3-D appearance, uses VIB for own dialogs +# Oct 96: add list vidget + +$include "keysyms.icn" +$include "vdefns.icn" +$include "vibdefn.icn" + +link drag +link dsetup +link graphics +link vsetup +link interact + +link vibbttn +link vibedit +link vibfile +link vibglbl +link viblabel +link vibline +link viblist +link vibmenu +link vibradio +link vibrect +link vibsizer +link vibslidr +link vibtalk +link vibtext + +global CHOSEN # object picked from Select menu + +############################################################################ +# main() opens a window, creates the palette and menus, initializes +# global variables, and starts up the WIT event loop. +############################################################################ +procedure main(args) + local edit_menu, file_menu, x, y + + Window("size=640,480", "label= ", args) + + &error := 1 + WAttrib("resize=on") + &error := 0 + + VSetFont() + APPWIN := Clone() | stop("can't clone window") + XORWIN := Clone("drawop=reverse") | stop("can't clone window") + + SESSION := def_extn("" ~== args[1]) | newname() + label_session() + + PAD := WAttrib("fheight") + 6 + LBMASK := &ascii[32+:95] -- '\"\\' + IDMASK := &ascii[32+:95] -- '\"\\:' + CBMASK := &letters ++ &digits ++ '_' + + O_LIST := [] + P_LIST := [] + SIZER := create_sizer() + + ROOT := Vroot_frame(&window) + edit_menu := Vsub_menu(&window, + "copy @C", menu_cb, + "delete @X", menu_cb, + "undelete @U", menu_cb, + "align vert @V", menu_cb, + "align horz @H", menu_cb) + file_menu := Vsub_menu(&window, + "new @N", menu_cb, + "open @O", menu_cb, + "save @S", menu_cb, + "save as ", menu_cb, + "refresh @R", menu_cb, + "prototype @P", menu_cb, + "quit @Q", menu_cb) + MENUBAR := Vmenu_bar(&window, "File ", file_menu, "Edit ", edit_menu) + VInsert(ROOT, MENUBAR, 0, 0) + SELECT := Vpane(&window, select_cb, , , TextWidth("Select") + 8, MENUBAR.ah) + VInsert(ROOT, SELECT, MENUBAR.aw, 0) + + dialogue() + + VResize(ROOT) + CANVASY := MENUBAR.ah + 3 + PAL_H + 4 + Clip(APPWIN, 0, CANVASY, 9999, 9999) + + DRAGWIN := Clone(APPWIN, "bg=blackish gray") | stop("can't clone APPWIN") + + create_palette() + + if not (args[1] & load_session(SESSION)) then { + draw_header() + draw_canvas() + } + + GetEvents(ROOT, vib_event_loop) +end + +############################################################################ +# menu_cb() is the callback routine for the file and edit menus. +############################################################################ +procedure menu_cb(wit, value) + local cmd + + cmd := trim(value[1] ? tab(upto('@') | 0)) + case cmd of { + + # file menu + "n" | "new" : new_session() + "o" | "open" : if flush_session() then open_session() + "s" | "save" : save_session(SESSION) + "save as" : vib_save_as("file to save: ", "") + "r" | "refresh" : redraw_screen() + "p" | "prototype" : prototype() + "q" | "quit" : if flush_session() then exit() + + # edit menu + "c" | "d" | "copy" : copy_focus() + "x" | "\d" | "delete" : delete_focus() + "u" | "undelete" : undelete() + "v" | "align vert" : if \FOCUS then set_align("alignv") + "h" | "align horz" : if \FOCUS then set_align("alignh") + } +end + +############################################################################ +# select_cb() is the callback routine for the Select pseudo-menu. +############################################################################ +procedure select_cb(wit, ev) + local i, idlist, mlist, smenu, obj + + if not (ev === (&lpress | &ldrag | &mpress | &mdrag | &rpress | &rdrag)) then + return + + idlist := set() + every insert(idlist, (!O_LIST).id) + idlist := sort(idlist) + + mlist := [&window] + every put(mlist, !idlist, choice_cb) + smenu := Vmenu_bar_item(&window, "Select", , , , , Vsub_menu ! mlist) + VInsert(ROOT, smenu, wit.ax, wit.ay) + VResize(smenu) + + CHOSEN := &null + VEvent(smenu, &lpress) + VRemove(ROOT, smenu, 1) + + if \CHOSEN then + every obj := !O_LIST do + if obj.id == CHOSEN then { + focus_object(obj) + break + } + return +end + +############################################################################ +# choice_cb() is the callback routine for a chosen Select entry. +############################################################################ +procedure choice_cb(wit, value) + CHOSEN := value[1] +end + +############################################################################ +# vib_event_loop() is called by the WIT library whenever an event +# occurs that does not correspond to WIT objects. +############################################################################ +procedure vib_event_loop(e, x, y) + local f, obj, flag, diffx, diffy + + case e of { + &meta & "I": snapshot() + &meta & !"nosrpqcdxuvh": menu_cb(, e) + "\d": menu_cb(, e) + Key_Left | Key_KP_Left: shift_focus(-1, 0) + Key_Right | Key_KP_Right: shift_focus(+1, 0) + Key_Up | Key_KP_Up: shift_focus(0, -1) + Key_Down | Key_KP_Down: shift_focus(0, +1) + &resize: { + if SIZER.x+10 > &x then + SIZER.x := &x - 11 + if SIZER.y+10 > &y then + SIZER.y := maximum(&y - 11, CANVASY) + redraw_screen() + DIRTY := 1 + } + &mpress: { + obj := object_of_event(x, y) + if type(obj) == "menu_obj" then { + focus_object(obj) + simulate_menu(obj) + } + } + &rpress: { + if on_target(SIZER, x, y) then + display_sizer_atts(SIZER) + else { + obj := object_of_event(x, y) + focus_object(\obj) + display_talk(\FOCUS) + } + } + &lpress: { + if \ALIGN then { + obj := object_of_event(x, y) + if \obj & \FOCUS then { + unfocus_object(f := FOCUS) + if ALIGN == "alignv" then + move_object(obj, obj.x, f.y) + else + move_object(obj, f.x, obj.y) + focus_object(f) + } + else + unset_align() + } + else { # not in ALIGN mode + if \(obj := palette_object_of_event(x, y)) then { + obj := create_object_instance(obj) + focus_object(obj) + &y := CANVASY + 4 + drag_obj(APPWIN, obj) + } + else if on_target(SIZER, x, y) then + drag_sizer() + else if flag := on_focus(\FOCUS, x, y) then + resize_drag(FOCUS, flag) + else if \(obj := object_of_event(x, y)) then + drag_obj(DRAGWIN, obj) + else + unfocus_object(\FOCUS) + } + } + } +end + +############################################################################ +# drag_obj() moves an object to follow the mouse pointer. +############################################################################ +procedure drag_obj(win, obj) + unfocus_object(\FOCUS) + case type(obj) of { + "rect_obj": { + # use APPWIN, not DRAGWIN, to get XOR color correct + DragOutline(APPWIN, obj.x, obj.y, obj.w, obj.h) + } + "line_obj": + drag_line(obj) + default: { + EraseArea(APPWIN, obj.x, obj.y, obj.w, obj.h) + draw_object(obj) + Drag(win, obj.x, obj.y, obj.w, obj.h) + } + } + + if obj.x ~= &x | obj.y ~= &y then + move_object(obj, &x, &y) + focus_object(obj) +end + +############################################################################ +# resize_drag() resizes an object using the mouse pointer. +############################################################################ +procedure resize_drag(obj, flag) + local e, orig, winw, winh + + orig := copy(obj) + unfocus_object(obj) + draw_outline(obj) + winw := WAttrib("width") + winh := WAttrib("height") + repeat { + e := Event() + &x <:= 0 + &x >:= winw - 1 + &y <:= CANVASY + &y >:= winh - 1 + case e of { + &ldrag: { + resize_object(obj, &x, &y, flag) + DIRTY := 1 + } + &lrelease: { + draw_outline(obj) + erase_object(orig) + draw_overlap(orig) + if type(obj) ~== "line_obj" then + VResize(obj.v, obj.x, obj.y, obj.w, obj.h) + draw_object(obj) + focus_object(obj) + return + } + } + } +end diff --git a/ipl/gpacks/vib/vibbttn.icn b/ipl/gpacks/vib/vibbttn.icn new file mode 100644 index 0000000..362b807 --- /dev/null +++ b/ipl/gpacks/vib/vibbttn.icn @@ -0,0 +1,220 @@ +############################################################################ +# +# vibbttn.icn -- procedures for defining a button object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" + +########################################################################## +# button_obj: +# v : vidget used for drawing text input object +# proc : name of user callback procedure +# id : unique means of identifying instance +# x,y,w,h : bounding box +# label : button label +# style : button style +# toggle : is this a toggle button? +# dflt : is this button the default in a dialog box? +# focus : should focus lines be drawn around this object? +########################################################################## +record button_obj(v, proc, id, x, y, w, h, + label, style, toggle, dflt, focus) + + +########################################################################## +# create_button() creates a button instance and draws the button if +# it is a first class object. +########################################################################## +procedure create_button(x, y, w, h, label, style, toggle, dflt) + local r, id + + id := next_id("button") + /style := DEFAULT_BUTTON_STYLE + r := button_obj(, "button_cb" || id, "button" || id, + x, y, w, h, label, style, toggle, dflt, 0) + r.v := Vbutton(ROOT, x, y, APPWIN, label, , id, style, w, h) + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# draw_button() draws the given button in that button's style. +########################################################################## +procedure draw_button(r) + VResize(r.v, r.x, r.y, r.w, r.h) + VDraw(r.v) + if \r.dflt then + BevelRectangle(APPWIN, r.x - 4, r.y - 4, r.w + 8, r.h + 8, -2) + return r +end + +########################################################################## +# update_button_bb() updates various attributes of the button that +# change when the button is resized, etc. +########################################################################## +procedure update_button_bb(r) + local tempy, temph, vpad, hpad, sp, sz + + vpad := 4 # vertical padding + hpad := 7 # horizontal padding + sp := 11 # space between circle/box and text + r.w <:= MIN_W + r.h <:= MIN_H + case r.style of { + "check" | "circle" | "checkno" | "circleno": { + sz := integer(WAttrib(APPWIN, "fheight") * 0.75) + r.w <:= sz + sp + TextWidth(APPWIN, r.label) + hpad + r.h <:= WAttrib(APPWIN, "fheight") + vpad + } + "regular" | "regularno": { + r.w <:= TextWidth(APPWIN, r.label) + hpad + r.h <:= WAttrib(APPWIN, "fheight") + vpad + } + "xbox" | "xboxno": { + r.w <:= r.h + r.h <:= r.w + r.label := &null + } + } +end + +########################################################################## +# load_button() restores a button object from session code. +########################################################################## +procedure load_button(r, o) + r.label := o.lbl + r.style := o.sty + case o.num of { + "1": r.toggle := 1 + "-1": r.dflt := 1 + } + r.v := Vbutton(ROOT, r.x, r.y, APPWIN, r.label, , r.id, r.style, r.w, r.h) + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# load_xbox() makes an xbox button object from an old checkbox entry. +########################################################################## +procedure load_xbox(r, o) + r.label := "" + r.style := "xbox" + r.toggle := 1 +end + +########################################################################## +# save_button() augments the record for saving a button object. +########################################################################## +procedure save_button(r, o) + r.typ := "Button" + r.lbl := o.label + r.sty := o.style + if \o.dflt then + r.num := -1 + else + r.num := o.toggle + return +end + +########################################################################## +# display_button_atts() displays the attribute sheet with the current +# attributes for the given button instance. +########################################################################## +procedure display_button_atts(object) + local s, o, t, d + + d := object.dflt + + s := object.style + o := 1 + if s[-2:0] == "no" then { + s := s[1:-2] + o := &null + } + + t := table() + t["_style"] := s + t["_outline"] := o + t["_toggle"] := object.toggle + t["_dflt"] := object.dflt + t["a_label"] := object.label + t["b_id"] := object.id + t["c_callback"] := object.proc + t["d_x"] := object.x + t["e_y"] := object.y - CANVASY + t["f_width"] := object.w + t["g_height"] := object.h + + repeat { + if button_dialog(t) == "Cancel" then + fail + + if illegal(t["a_label"], "Label", "l") | + illegal(t["b_id"], "ID", "s") | + illegal(t["c_callback"], "Callback", "p") | + illegal(t["d_x"], "X", "i") | + illegal(t["e_y"], "Y", "i") | + illegal(t["f_width"], "Width", MIN_W) | + illegal(t["g_height"], "Height", MIN_H) + then + next + + if t["_style"] ? ="xbox" & *t["a_label"] > 0 then { + Notice("No text is allowed with xbox style") + next + } + if \t["_toggle"] & \t["_dflt"] then { + Notice("A toggle button cannot be a dialog default") + next + } + + object.style := t["_style"] + if /t["_outline"] then + object.style ||:= "no" + + object.dflt := t["_dflt"] + object.toggle := t["_toggle"] + object.label := t["a_label"] + object.id := t["b_id"] + object.proc := t["c_callback"] + + object.v.style := object.style + object.v.s := object.label + + unfocus_object(object) + if /object.dflt & \d then # remove default frame + EraseArea(object.x - 4, object.y - 4, object.w + 8, object.h + 8) + move_object(object, + t["d_x"], t["e_y"] + CANVASY, t["f_width"], t["g_height"]) + focus_object(object) + break + } +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure button_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["button_dialog:Sizer::1:0,0,392,240:",], + ["_cancel:Button:regular::211,189,50,30:Cancel",], + ["_dflt:Button:check:1:245,148,125,20:dialog default",], + ["_okay:Button:regular:-1:141,189,50,30:Okay",], + ["_outline:Button:check:1:245,85,76,20:outline",], + ["_style:Choice::4:142,85,78,84:",, + ["regular","check","circle","xbox"]], + ["_toggle:Button:check:1:245,116,76,20:toggle",], + ["a_label:Text::40:13,14,360,19:label: \\=",], + ["b_id:Text::40:13,35,360,19:ID: \\=",], + ["c_callback:Text::40:13,56,360,19:callback: \\=",], + ["d_x:Text::3:13,85,101,19: x: \\=",], + ["e_y:Text::3:13,106,101,19: y: \\=",], + ["f_width:Text::3:13,131,101,19: width: \\=",], + ["g_height:Text::3:13,152,101,19: height: \\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/vibdefn.icn b/ipl/gpacks/vib/vibdefn.icn new file mode 100644 index 0000000..02d8a04 --- /dev/null +++ b/ipl/gpacks/vib/vibdefn.icn @@ -0,0 +1,75 @@ +############################################################################ +# +# vibdefn.icn -- manifest constants +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$define PAL_H 36 # height of palette entry +$define PAL_W 48 # width of palette entry + +$define SZDIM 9 # sizer dimensions + +$define DEFAULT_BUTTON_STYLE "regular" # default button style +$define MIN_W 10 # minimum object width +$define MIN_H 10 # minimum object height + +$define TEXTCHARS 40 # size of hand-built text field +$define TEXTWIDTH (20 + 7 * TEXTCHARS) # space used for same +$define LONGTEXT 50 # size of long text fields + + +# alternate keypad symbols not always set + +$ifndef Key_KP_Left + $define Key_KP_Left Key_Left +$endif +$ifndef Key_KP_Right + $define Key_KP_Right Key_Right +$endif +$ifndef Key_KP_Up + $define Key_KP_Up Key_Up +$endif +$ifndef Key_KP_Down + $define Key_KP_Down Key_Down +$endif + + +# file names and commands for prototyping + +$ifdef _UNIX + $define EXECPROTO ("./" || PROTOEXE || " && rm -f " || PROTOEXE || " &") +$endif + +$ifdef _CYGWIN + $define EXECPROTO ("./" || PROTOEXE || " && rm -f " || PROTOEXE || " &") +$endif + +$ifdef _MS_WINDOWS + $define PROTOEXE "vibproto.exe" +$endif + +# defaults used if not set above + +$ifndef PROTOFILE # prototype file name + $define PROTOFILE "vibproto.icn" +$endif + +$ifndef PROTOEXE # executable file name + $define PROTOEXE "vibproto" +$endif + +$ifndef BUILDPROTO # build command + $ifdef _JAVA + $define BUILDPROTO ("jcont -s -o" || PROTOEXE || " " || PROTOFILE) + $else # _JAVA + $define BUILDPROTO ("icont -s -o" || PROTOEXE || " " || PROTOFILE) + $endif # _JAVA +$endif + +$ifndef EXECPROTO # execute command + $define EXECPROTO PROTOEXE +$endif diff --git a/ipl/gpacks/vib/vibedit.icn b/ipl/gpacks/vib/vibedit.icn new file mode 100644 index 0000000..b8f07e1 --- /dev/null +++ b/ipl/gpacks/vib/vibedit.icn @@ -0,0 +1,922 @@ +############################################################################ +# +# vibedit.icn -- shared graphical editing routines +# +## ######################################################################### +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" +$include "vdefns.icn" + +record palette_obj(name, x, y, bwimage, colrimage) + +############################################################################ +# next_id() generates an ID number for a new object +############################################################################ +procedure next_id(s) + local obj, n + + n := 0 + every obj := !O_LIST do + obj.id ? + if =s then + n <:= integer(tab(0)) # find highest used so far + return n + 1 +end + +############################################################################ +# strip() deletes trailing blanks from the incoming string. +############################################################################ +procedure strip(s) + local index + + index := 0 + every index := *s to 1 by -1 do + if s[index] ~== " " then break + return s[1:index+1] +end + +############################################################################ +# set_align() sets the align flag and changes the cursor to indicate that +# the system is in align mode. +############################################################################ +procedure set_align(kind) + ALIGN := kind + if kind == "alignv" then + WAttrib("pointer=" || ("top side" | "sb v double arrow" | "crosshair")) + else + WAttrib("pointer=" || ("left side" | "sb h double arrow" | "crosshair")) +end + +############################################################################ +# unset_align() unsets the align flag and restores the cursor to its +# original state. +############################################################################ +procedure unset_align() + ALIGN := &null + WAttrib("pointer=" || ("left ptr" | "arrow")) +end + +############################################################################ +# minimum() returns the smaller of two numeric values. +############################################################################ +procedure minimum(x, y) + return x > y | x +end + +############################################################################ +# maximum() returns the larger of two numeric values. +############################################################################ +procedure maximum(x, y) + return x < y | x +end + +############################################################################ +# draw_outline() draws an outline for the given object. Used for resizing. +############################################################################ +procedure draw_outline(object) + case type(object) of { + "line_obj" : outline_line(object) + default : DrawRectangle(XORWIN, + object.x-1, object.y-1, object.w+1, object.h+1) + } +end + +############################################################################ +# update_bb() calls update routines for the various object types so +# that attributes correctly get updated when an object is +# resized or a label changes, etc. +############################################################################ +procedure update_bb(object) + case type(object) of { + "button_obj" : update_button_bb(object) + "radio_button_obj": update_radio_bb(object) + "line_obj" : update_line_bb(object) + "slider_obj" : update_slider_bb(object) + "text_input_obj" : update_text_input_bb(object) + "label_obj" : update_label_bb(object) + "menu_obj" : update_menu_bb(object) + "list_obj" : update_list_bb(object) + # nothing to do for rectangles + } +end + +############################################################################ +# move_object() is called to reposition, resize, and redraw an object. +############################################################################ +procedure move_object(object, x, y, w, h) + + erase_object(object) + draw_overlap(object) + + if type(object) == "line_obj" then { + object.x2 := object.x2 - object.x + x + object.y2 := object.y2 - object.y + y + object.x1 := object.x1 - object.x + x + object.y1 := object.y1 - object.y + y + update_bb(object) + } + else { + x <:= 0 + y <:= CANVASY # ensure object does not overlap palette + object.x := x + object.y := y + object.w := \w + object.h := \h + update_bb(object) + VResize(object.v, object.x, object.y, object.w, object.h) + } + + draw_object(object) + DIRTY := 1 +end + +############################################################################ +# resize_object() is called to resize the outline of an object. First, +# draw_outline() is called to erase the outline, then the +# attributes are updated, then draw_outline is called to +# draw the new outline. +############################################################################ +procedure resize_object(object, x, y, direction) + local neww, newh, newy, xcorner, ycorner + + # move particular enpoint of line and adjust bounding box of line + if type(object) == "line_obj" then { + draw_outline(object) + if direction == "lpt" then { + object.x1 := x + object.y1 := maximum(CANVASY, y) + } + else if direction == "rpt" then { + object.x2 := x + object.y2 := maximum(CANVASY, y) + } + update_bb(object) + draw_outline(object) + return + } + + # all other objects can be resized freely, + # subject to minimum width/height imposed in update_bb() + + draw_outline(object) + y <:= CANVASY + ycorner := direction[1] # "u" or "l" + xcorner := direction[2] # "l" or "r" + + if xcorner == "r" then { + neww := x - object.x + neww <:= MIN_W + } + else { + neww := object.w + object.x - x + neww <:= MIN_W + object.x +:= object.w - neww + } + + if ycorner == "l" then { + newh := y - object.y + newh <:= MIN_H + } + else { + newh := object.h + object.y - y + newh <:= MIN_H + object.y +:= object.h - newh + } + + object.h := newh + object.w := neww + update_bb(object) + if object.w ~= neww & xcorner == "l" then + object.x +:= neww - object.w + if object.h ~= newh & ycorner == "u" then + object.y +:= newh - object.h + + VResize(object.v, object.x, object.y, object.w, object.h) + draw_outline(object) +end + +############################################################################ +# display_talk() is called to display the attribute sheets of the various +# object types. +############################################################################ +procedure display_talk(object) + case type(object) of { + "button_obj" : display_button_atts(object) + "slider_obj" : display_slider_atts(object) + "text_input_obj" : display_text_input_atts(object) + "rect_obj" : display_rect_atts(object) + "menu_obj" : display_menu_atts(object) + "line_obj" : display_line_atts(object) + "label_obj" : display_label_atts(object) + "radio_button_obj": display_radio_button_atts(object) + "list_obj" : display_list_atts(object) + } +end + +############################################################################ +# draw_object() is called to draw the various object types. +############################################################################ +procedure draw_object(object) + update_bb(object) + case type(object) of { + "sizer_obj" : draw_sizer(object) + "button_obj" : draw_button(object) + "text_input_obj" : draw_text_input(object) + "radio_button_obj" : draw_radio_button(object) + "rect_obj" : draw_rect(object) + "slider_obj" : draw_slider(object) + "line_obj" : draw_line(object) + "label_obj" : draw_label(object) + "menu_obj" : draw_menu(object) + "list_obj" : draw_list(object) + } +end + +############################################################################ +# erase_object() removes an object from the screen. +############################################################################ +procedure erase_object(object) + if type(object) == "line_obj" then + DrawGroove(APPWIN, object.x1, object.y1, object.x2, object.y2, 0) + else if type(object) == "button_obj" & \object.dflt then + EraseArea(APPWIN, object.x - 4, object.y - 4, object.w + 8, object.h + 8) + else + EraseArea(APPWIN, object.x, object.y, object.w, object.h) +end + +############################################################################ +# draw_focus() is called to draw focus lines around an object. +############################################################################ +procedure draw_focus(o) + if type(o) == "line_obj" then { + FillRectangle(XORWIN, o.x1 - 3, o.y1 - 3, 6, 6) + FillRectangle(XORWIN, o.x2 - 3, o.y2 - 3, 6, 6) + } else { + DrawLine(XORWIN, o.x-2, o.y+2, o.x-2, o.y-2, o.x+2, o.y-2) + DrawLine(XORWIN, o.x-2, o.y+o.h-3, o.x-2, o.y+o.h+1, o.x+2, o.y+o.h+1) + DrawLine(XORWIN, o.x+o.w-3, o.y-2, o.x+o.w+1, o.y-2, o.x+o.w+1, o.y+2) + DrawLine(XORWIN, + o.x+o.w-3, o.y+o.h+1, o.x+o.w+1, o.y+o.h+1, o.x+o.w+1, o.y+o.h-3) + } +end + +############################################################################ +# focus_object() sets the given object to be the object with the focus. +# Focus lines are drawn around the object and the FOCUS +# global is set to be the object. +############################################################################ +procedure focus_object(object) + unfocus_object(\FOCUS) + draw_focus(object) + object.focus := 1 + FOCUS := object + return object +end + +############################################################################ +# unfocus_object() unsets the focus. The focus lines are erased about +# the object and the FOCUS global is set to null. +############################################################################ +procedure unfocus_object(object) + draw_focus(object) + object.focus := 0 + FOCUS := &null + return object +end + +############################################################################ +# on_focus() returns either +# "lpt" : if object is a line and the mouse is on the left endpoint +# "rpt" : if object is a line and the mouse is on the right endpoint +# "ur" : if mouse is on upper-right focus point of object +# "ul" : if mouse is on upper-left focus point of object +# "lr" : if mouse is on lower-right focus point of object +# "ll" : if mouse is on lower-left focus point of object +# otherwise it fails +############################################################################ +procedure on_focus(object, x, y) + local range + + range := 5 + if type(object) == "line_obj" then { + if (object.x1 - range < x < object.x1 + range) & + (object.y1 - range < y < object.y1 + range) then + return "lpt" + else if (object.x2 - range < x < object.x2 + range) & + (object.y2 - range < y < object.y2 + range) then + return "rpt" + else fail + } + if (object.x+object.w-range) < x < (object.x+object.w+range) & + (object.y - range) < y < (object.y + range) then + return "ur" + if (object.x - range) < x < (object.x + range) & + (object.y - range) < y < (object.y + range) then + return "ul" + if (object.x - range) < x < (object.x + range) & + (object.y+object.h-range) < y < (object.y+object.h+range) then + return "ll" + if (object.x+object.w-range) < x < (object.x+object.w+range) & + (object.y+object.h-range) < y < (object.y+object.h+range) then + return "lr" + fail +end + +############################################################################ +# on_target() returns the object if the mouse is over the object. +# Else fails. +############################################################################ +procedure on_target(o, x, y) + local m, a, b, c, d + + if y < CANVASY then fail + if not ((o.x <= x <= o.x + o.w) & + (o.y <= y <= o.y + o.h)) then + fail + if type(o) == "line_obj" & o.w > 6 & o.h > 6 then { # if skewed line + # make sure (x,y) is reasonably close to the line + m := (o.y2 - o.y1) / real(o.x2 - o.x1) # slope + a := o.y1 - m * o.x1 # y-intercept + b := o.x1 - o.y1 / m # x-intercept + c := -a * o.x1 - b * o.y1 # ax + by + c = 0 + d := (a * x + b * y + c) / sqrt(a ^ 2 + b ^ 2) # distance + if abs(d) > 5 then + fail + } + return o +end + +############################################################################ +# object_of_event() checks the canvas object list against the mouse event +# coordinates to determine if the event correlates to +# a canvas object. If multiple objects match, the +# smallest is returned. (The area of a "line" is fudged.) +# Null is returned if the event does not correlate. +############################################################################ +procedure object_of_event(x, y) + local o, a, obj, area + + every o := !O_LIST do + if on_target(o, x, y) then { + if type(o) == "line_obj" then + a := 5 * maximum(o.w, o.h) + else + a := o.w * o.h + if /obj | a < area then { + obj := o + area := a + } + } + return obj +end + +############################################################################ +# clear_screen() empties the entire screen, redrawing just the palette +# and sizer object. The canvas list is emptied. +############################################################################ +procedure clear_screen() + O_LIST := list() + FOCUS := &null + DIRTY := &null + redraw_screen() +end + +############################################################################ +# redraw_screen() clears the screen and redraws both the palette and canvas. +############################################################################ +procedure redraw_screen() + EraseArea() + draw_header() + draw_canvas() +end + +############################################################################ +# shift_focus() moves the object with the FOCUS by in the amount given. +############################################################################ +procedure shift_focus(dx, dy) + local object + + if object := \FOCUS then { + unfocus_object(object) + move_object(object, object.x + dx, object.y + dy) + focus_object(object) + } +end + +############################################################################ +# copy_focus() makes a copy of the object with the focus. +############################################################################ +procedure copy_focus() + local r, drawin, temp, obj + + if obj := \FOCUS then { + unfocus_object(obj) + case type(obj) of { + "rect_obj": { + r := create_rect(obj.x + 10, obj.y + 10, obj.w, obj.h, obj.style) + } + "menu_obj": { + temp := copy(obj) + r := create_menu(obj.x + 10, obj.y + 10, obj.label, obj.style) + copy_menu(r, temp) + } + "button_obj": { + r := create_button(obj.x + 10, obj.y + 10, obj.w, obj.h, + obj.label, obj.style, obj.toggle) + } + "text_input_obj": { + r := create_text_input(obj.x + 10, obj.y + 10, + obj.label, obj.value, obj.length) + } + "label_obj": { + r := create_label(obj.x + 10, obj.y + 10, obj.label) + } + "radio_button_obj": { + r := create_radio_button(obj.x + 10, obj.y + 10, copy(obj.alts)) + } + "slider_obj": { + r := create_slider(obj.x + 10, obj.y + 10, obj.w, obj.h, + obj.typ, obj.min, obj.max, obj.value, obj.filter) + } + "line_obj": { + r := create_line(obj.x1 + 10, obj.y1 + 10, obj.x2 + 10, obj.y2 + 10) + } + "list_obj": { + r := create_list(obj.x + 10, obj.y + 10, obj.w, obj.h, + obj.style, obj.scroll) + } + default: return + } + push(O_LIST, r) + draw_object(r) + focus_object(r) + DIRTY := 1 + } +end + +############################################################################ +# delete_focus() removes the object with the FOCUS from the canvas list. +############################################################################ +procedure delete_focus() + local i + + if \FOCUS then { + draw_focus(FOCUS) + erase_object(FOCUS) + DELETED := FOCUS + every i := 1 to *O_LIST do + if (O_LIST[i] === FOCUS) then + O_LIST := O_LIST[1:i] ||| O_LIST[i+1:*O_LIST+1] + FOCUS := &null + DELETED.focus := 0 + DIRTY := 1 + draw_overlap(DELETED) + } +end + +############################################################################ +# undelete() restores the most recently deleted object. +############################################################################ +procedure undelete() + if \DELETED then { + unfocus_object(\FOCUS) + push(O_LIST, DELETED) + draw_object(DELETED) + focus_object(DELETED) + DELETED := &null + DIRTY := 1 + } +end + +############################################################################ +# add_palette_entry() adds one entry to the palette +############################################################################ +procedure add_palette_entry(name, bwimage, colrimage) + static x + initial x := 0 + + push(P_LIST, palette_obj(name, x, MENUBAR.ah + 3, bwimage, colrimage)) + x +:= PAL_W +end + +############################################################################ +# draw_decor() redraws the decorative lines that extend across the window. +############################################################################ +procedure draw_decor() + DrawLine(0, MENUBAR.ah, 2000, MENUBAR.ah) + DrawLine(0, CANVASY-1, 2000, CANVASY-1) +end + +############################################################################ +# draw_header() redraws the window header. +############################################################################ +procedure draw_header() + local e, xpad, ypad, w, d, h, im + + MENUBAR.V.draw(MENUBAR) + DrawString(SELECT.ax + 4, SELECT.ay + 15, "Select") + BevelRectangle(SELECT.ax, SELECT.ay, SELECT.aw, SELECT.ah) + draw_decor() + every e := !P_LIST do { + if WAttrib("depth") > 1 then (im := e.colrimage) ? { + w := tab(upto(',')) # width of image + move(1) + tab(upto(',') + 1) # skip over palette spec + h := *tab(0) / w # height of image + } + else (im := e.bwimage) ? { + w := tab(upto(',')) # width of image + d := ((w + 3) / 4) # digits per row + move(2) + h := *tab(0) / d # height of image + } + xpad := (PAL_W - w) / 2 + ypad := (PAL_H - h) / 2 + DrawImage(e.x + xpad, e.y + ypad, im) + } +end + +############################################################################ +# draw_canvas() draws all the objects that exist within the canvas. +############################################################################ +procedure draw_canvas() + every draw_object(O_LIST[*O_LIST to 1 by -1]) + draw_sizer(SIZER) + draw_focus(\FOCUS) +end + +############################################################################ +# draw_overlap() draws any objects that overlap the argument object. +############################################################################ +procedure draw_overlap(object) + local f, o, d + + if type(object) == "button_obj" & \object.dflt then + d := 8 # fudge factor for default box on both objects + else + d := 4 # only the other object can have default box + + unfocus_object(f := \FOCUS) + every o := O_LIST[*O_LIST to 1 by -1] do { + if o.x >= object.x + object.w + d then next + if object.x >= o.x + o.w + d then next + if o.y >= object.y + object.h + d then next + if object.y >= o.y + o.h + d then next + if o === object then next + draw_object(o) + } + if object.x + object.w + d >= SIZER.x | + object.y + object.h + d >= SIZER.y then + draw_sizer(SIZER) + focus_object(\f) +end + +############################################################################ +# palette_object_of_event() cycles through the list of palette objects +# to determine if any of them were the target +# of a mouse event. +############################################################################ +procedure palette_object_of_event(x, y) + local o + + every o := !P_LIST do + if o.x <= x <= o.x + PAL_W & o.y <= y <= o.y + PAL_H then + return o + return &null +end + +############################################################################ +# create_object_instance() creates an instance of the given object. +############################################################################ +procedure create_object_instance(obj) + local r, temp, x, y, w, h + + x := &x + y := CANVASY + w := 32 + h := 20 + case obj.name of { + "line": + r := create_line(x, y + 3, x + PAL_W, y + 3) + "rect": + r := create_rect(x, y, w, h, "grooved") + "menu": { + r := create_menu(x, y, "Menu", "pull") + add_item(r, "three", 0) + add_item(r, "two", 0) + add_item(r, "one", 0) + } + "button": + r := create_button(x, y, w, h, "push") + "radio_button": + r := create_radio_button(x, y, ["one","two","three"]) + "text": + r := create_text_input(x, y, "Text:", "", 3) + "label": + r := create_label(x, y, "Label") + "slider": + r := create_slider(x, y, VSlider_DefWidth, VSlider_DefLength, + "Slider", 0.0, 1.0, 0.5, 1) + "scroll": + r := create_slider(x, y, VSlider_DefWidth, VSlider_DefLength, + "Scrollbar", 0.0, 1.0, 0.5, 1) + "list": + r := create_list(x, y) + default: return &null + } + push(O_LIST, r) + DIRTY := 1 + return r +end + +############################################################################ +# create_palette() creates the palette objects. +############################################################################ +procedure create_palette() + + add_palette_entry("button", + "25,#1ffffff10000011000001115555110aaaa11155551100000110000011ffffff", + "25,c1,_ + 6666666666666666666666666_ + 6~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~222222222222222~~~~1_ + 6~~~~222222222222222~~~~1_ + 6~~~~222222222222222~~~~1_ + 6~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~~~~~~1_ + 6111111111111111111111111_ + ") + add_palette_entry("radio_button", + "32,#FFFFFFFF8000000180000021800000518555508982AAA1058555508980000051_ + 80000021800000018000000180000021800000518555508982AAA10585555089_ + 800000518000002180000001800000018000002180000071855550F982AAA1FD_ + 855550F9800000718000002180000001FFFFFFFF", + "33,c1,_ + 666666666666666666666666666666661_ + 6~~~~~6~~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~666~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~66~66~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~66~~~66~~~222222222222222~~~~1_ + 6~66~~~~~66~~222222222222222~~~~1_ + 6~~11~~~11~~~222222222222222~~~~1_ + 6~~~11~11~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~111~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~~1~~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~~6~~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~666~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~66~66~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~66~~~66~~~222222222222222~~~~1_ + 6~66~~~~~66~~222222222222222~~~~1_ + 6~~11~~~11~~~222222222222222~~~~1_ + 6~~~11~11~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~111~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~~1~~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~~6~~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~666~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~66066~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~6600066~~~222222222222222~~~~1_ + 6~660000066~~222222222222222~~~~1_ + 6~~1100011~~~222222222222222~~~~1_ + 6~~~11011~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~111~~~~~~~~~~~~~~~~~~~~~~~~1_ + 6~~~~~1~~~~~~~~~~~~~~~~~~~~~~~~~1_ + 611111111111111111111111111111111_ + ") + add_palette_entry("menu", + "20,#1ffff1ffff1d5571eaaf1d5571fffffffff800018000180001955518aaa98000_ + 18000180001955518aaa9800018000180001955518aaa9800018000180001955_ + 518aaa98000180001fffff", + "20,c1,_ + 1111111111111116~~~~_ + 1000000000000006~~~~_ + 1005555555550006~~~~_ + 1005555555550006~~~~_ + 1000000000000006~~~~_ + 1000000000000006~~~~_ + 66666666666666666666_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~22222222222222~~1_ + 6~~22222222222222~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~22222222222222~~1_ + 6~~22222222222222~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~22222222222222~~1_ + 6~~22222222222222~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~22222222222222~~1_ + 6~~22222222222222~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 6~~~~~~~~~~~~~~~~~~1_ + 61111111111111111111_ + ") + add_palette_entry("list", + "32,#FFFFFFFF92000001AA000001AA555551C62AAAA9FE0000018200000182555551_ + FE2AAAA9C6000001C7FFFFFFC7AAAAAFC7D55557C7FFFFFFC6000001C6555551_ + C62AAAA9FE0000018200000182555551822AAAA9820000018200000182555551_ + 822AAAA982000001FE000001C6555551AA2AAAA9AA00000192000001FFFFFFFF", + "32,c1,_ + 111111111111111111111111~1111111_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~~6~~6_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~6~1~6_ + 1~~222222222222222222~~6~1~6~1~6_ + 1~~222222222222222222~~6~16~~~16_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1611116_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~~~~~6_ + 1~~222222222222222222~~6~1666666_ + 1~~222222222222222222~~6~16~~~16_ + 1~~~~~~~~~~~~~~~~~~~~~~6~16~~~16_ + 100000000000000000000006~16~~~16_ + 100222222222222222222006~16~~~16_ + 100222222222222222222006~16~~~16_ + 100000000000000000000006~16~~~16_ + 1~~~~~~~~~~~~~~~~~~~~~~6~16~~~16_ + 1~~222222222222222222~~6~16~~~16_ + 1~~222222222222222222~~6~1611116_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~~~~~6_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~~~~~6_ + 1~~222222222222222222~~6~1~~~~~6_ + 1~~222222222222222222~~6~1~~~~~6_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~~~~~6_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~~~~~6_ + 1~~222222222222222222~~6~1~~~~~6_ + 1~~222222222222222222~~6~1~~~~~6_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1666666_ + 1~~~~~~~~~~~~~~~~~~~~~~6~16~~~16_ + 1~~222222222222222222~~6~16~~~16_ + 1~~222222222222222222~~6~1~6~1~6_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~6~1~6_ + 1~~~~~~~~~~~~~~~~~~~~~~6~1~~6~~6_ + 16666666666666666666666641666666_ + ") + add_palette_entry("text", + "32,#ffffc00080004000800040008000400080004555800042aa9ffe455580004000_ + 80004000ffffc000", + "32,c1,_ + ~~~~~~~~~~~~~~111111111111111111_ + ~~~~~~~~~~~~~~1~~~~~~~~~~~~~~~~6_ + ~~~~~~~~~~~~~~1~~~~~~~~~~~~~~~~6_ + ~~~~~~~~~~~~~~1~~~~~~~~~~~~~~~~6_ + 22222222222~~~1~~~~~~~~~~~~~~~~6_ + 22222222222~~~1~~~~~~~~~~~~~~~~6_ + 22222222222~~~1~~~~~~~~~~~~~~~~6_ + ~~~~~~~~~~~~~~1~~~~~~~~~~~~~~~~6_ + ~~~~~~~~~~~~~~1~~~~~~~~~~~~~~~~6_ + ~~~~~~~~~~~~~~166666666666666666_ + ") + add_palette_entry("slider", + "9,#1FF1011011011011011011011011011011FF1831831831831831FF_ + 1831831831831831FF1011011011011011011011FF", + "9,c1,_ + 111111111_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 166666666_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 161111116_ + 166666616_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 161111116_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 166666666_ + ") + add_palette_entry("scroll", + "9,#1FF1111291291451451FF1011011011011FF1831831831831831FF_ + 1011011011011011011011FF1451451291291111FF", + "9,c1,_ + 111111111_ + 1~~~6~~~6_ + 1~~6~1~~6_ + 1~~6~1~~6_ + 1~6~~~1~6_ + 1~6~~~1~6_ + 16~~~~~16_ + 161111116_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 166666666_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 16~~~~~16_ + 161111116_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 1~~~~~~~6_ + 166666666_ + 16~~~~~16_ + 1~6~~~1~6_ + 1~6~~~1~6_ + 1~~6~1~~6_ + 1~~6~1~~6_ + 1~~~6~~~6_ + 166666666_ + ") + add_palette_entry("rect", + "32,#ffffffff80000001800000018000000180000001800000018000000180000001_ + 8000000180000001800000018000000180000001800000018000000180000001_ + 800000018000000180000001ffffffff", + "32,c1,_ + 33333333333333333333333333333333_ + 36666666666666666666666666666666_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36~~~~~~~~~~~~~~~~~~~~~~~~~~~~36_ + 36333333333333333333333333333336_ + 36666666666666666666666666666666_ + ") + add_palette_entry("label", + "13,#0040004000e000e000e001b00190019003180308030807fc060406040c061e0f", + "13,c1,_ + ~~~~~~0~~~~~~_ + ~~~~~~0~~~~~~_ + ~~~~~000~~~~~_ + ~~~~~000~~~~~_ + ~~~~~000~~~~~_ + ~~~~00~00~~~~_ + ~~~~0~~00~~~~_ + ~~~~0~~00~~~~_ + ~~~00~~~00~~~_ + ~~~0~~~~00~~~_ + ~~~0~~~~~0~~~_ + ~~000000000~~_ + ~~0~~~~~~00~~_ + ~~0~~~~~~00~~_ + ~00~~~~~~~00~_ + 0000~~~~~0000_ + ") + add_palette_entry("line", + "32,#0000000f0000000f0000001f0000006f00000180000006000000180000006000_ + 0001800000060000001800000060000001800000f6000000f8000000f0000000f0000000", + "30,c1,_ + ~~~~~~~~~~~~~~~~~~~~~~~~~~0000_ + ~~~~~~~~~~~~~~~~~~~~~~~~~~3300_ + ~~~~~~~~~~~~~~~~~~~~~~~~336600_ + ~~~~~~~~~~~~~~~~~~~~~~33660000_ + ~~~~~~~~~~~~~~~~~~~~3366~~~~~~_ + ~~~~~~~~~~~~~~~~~~3366~~~~~~~~_ + ~~~~~~~~~~~~~~~~3366~~~~~~~~~~_ + ~~~~~~~~~~~~~~3366~~~~~~~~~~~~_ + ~~~~~~~~~~~~3366~~~~~~~~~~~~~~_ + ~~~~~~~~~~3366~~~~~~~~~~~~~~~~_ + ~~~~~~~~3366~~~~~~~~~~~~~~~~~~_ + ~~~~~~3366~~~~~~~~~~~~~~~~~~~~_ + 00003366~~~~~~~~~~~~~~~~~~~~~~_ + 003366~~~~~~~~~~~~~~~~~~~~~~~~_ + 0066~~~~~~~~~~~~~~~~~~~~~~~~~~_ + 0000~~~~~~~~~~~~~~~~~~~~~~~~~~_ + ") +end diff --git a/ipl/gpacks/vib/vibfile.icn b/ipl/gpacks/vib/vibfile.icn new file mode 100644 index 0000000..da1dd43 --- /dev/null +++ b/ipl/gpacks/vib/vibfile.icn @@ -0,0 +1,603 @@ +############################################################################ +# +# vibfile.icn -- procedures for reading and writing specs to files +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" +$include "vdefns.icn" + +############################################################################ +# constants and globals that are used only in this file: +############################################################################ +$define PTITLE "#===<<vib prototype file>>===" +$define HEADER "#===<<vib:begin>>===\tmodify using vib; do not remove this marker line" +$define TRAILER "#===<<vib:end>>===\tend of section maintained by vib" +$define XHEADER "#===<<xie:begin>>===" # for detecting old files +$define XTRAILER "#===<<xie:end>>===" +$define HMATCH 20 # number of chars that must match in header +$define TMATCH 18 # number of chars that must match in trailer +global USER_PREFIX, # user code preceding spec + USER_SUFFIX # user code following spec + +############################################################################ +# new_session() creates a new, empty VIB session +############################################################################ +procedure new_session() + local fname + + if not flush_session() then fail + SIZER := create_sizer() + clear_screen() + SESSION := newname() + label_session() + USER_PREFIX := USER_SUFFIX := &null + return +end + +############################################################################ +# load_session() reads in a saved VIB session file so that it can be +# re-edited. +############################################################################ +procedure load_session(s) + local line, ifile, l, o + + ifile := open(s, "r") | fail + clear_screen() + + USER_PREFIX := USER_SUFFIX := "" + while line := read(ifile) do { + if line ? match((HEADER | XHEADER)[1 +: HMATCH]) then + break + if line ? match("# Session Code:") then { + Notice("Old file format; use uix to convert") + USER_PREFIX := USER_SUFFIX := &null + fail + } + USER_PREFIX ||:= line + USER_PREFIX ||:= "\n" + line := &null + } + + DIRTY := &null + if not (\line ? match((HEADER | XHEADER)[1 +: HMATCH])) then { + Notice("No interface section found; creating one") + USER_PREFIX ||:= "\n\n\n" + DIRTY := 1 + } + + while o := load_object(ifile) do case o.typ of { + "Button" : init_object(load_button, button_obj(), o) + "Text" : init_object(load_text_input, text_input_obj(), o) + "Scrollbar" : init_object(load_slider, slider_obj(), o) + "Slider" : init_object(load_slider, slider_obj(), o) + "Line" : init_object(load_line, line_obj(), o) + "Rect" : init_object(load_rect, rect_obj(), o) + "Label" : init_object(load_label, label_obj(), o) + "Message" : init_object(load_label, label_obj(), o) + "Choice" : init_object(load_radio_button, radio_button_obj(), o) + "Menu" : init_object(load_menu, menu_obj(), o) + "Sizer" : init_object(load_sizer, sizer_obj(), o) + "Check" : init_object(load_xbox, button_obj(), o) + "List" : init_object(load_list, list_obj(), o) + } + + while USER_SUFFIX ||:= read(ifile) do + USER_SUFFIX ||:= "\n" + close(ifile) + return +end + +############################################################################# +# init_object() initializes an object record and calls a proc to register it. +############################################################################# +procedure init_object(proc, r, o) + r.id := o.id + r.proc := o.proc + r.x := integer(o.x) + r.y := o.y + CANVASY + r.w := integer(o.w) + r.h := integer(o.h) + r.focus := 0 + push(O_LIST, r) # must precede proc call + proc(r, o) # call object-specific procedure + update_bb(r) + draw_object(r) +end + +############################################################################ +# load_object() reads the next object from a saved session file. +############################################################################ +procedure load_object(f) + local c, s, l, r + + # find a line where the first nonblank character is a "[" + repeat { + while (c := reads(f, 1)) & upto(' \t\f', c) + if \c == "[" then + break + s := (c || read(f)) | fail + if s ? match((TRAILER | XTRAILER)[1 +: TMATCH]) then + fail + } + + # load the list of values + l := load_strings(f) | fail + + # break them down into an ext_rec record + r := ext_rec() + s := get(l) | fail + s ? { + r.id := tab(upto(':')) | fail; move(1) + r.typ := tab(upto(':')) | fail; move(1) + r.sty := tab(upto(':')) | fail; move(1) + r.num := tab(upto(':')) | fail; move(1) + r.x := tab(upto(',')) | fail; move(1) + r.y := tab(upto(',')) | fail; move(1) + r.w := tab(upto(',')) | fail; move(1) + r.h := tab(upto(':')) | fail; move(1) + r.lbl := tab(0) + } + r.proc := get(l) | "" + r.etc := get(l) | [] + return r +end + +############################################################################ +# load_strings() reads a list of strings after "[" has already been consumed. +############################################################################ +procedure load_strings(f) + local l, c, s, n + + l := [] + n := 0 + while c := reads(f, 1) do case c of { + + "]": return l # end of list + ",": (n <:= *l) | put(l, &null) + " ": next # whitespace: do nothing + "\t": next + "\r": next + "\n": next + "[": put(l, load_strings(f)) # nested list + + "\"": { # string constant + s := "" + while (c := reads(f, 1)) & not upto('"\n"', c) do + if s == "\\" then + s ||:= reads(f, 1) + else + s ||:= c + put(l, s) + } + + default: { # anything else: consume to separator + s := c + while (c := reads(f, 1)) & not upto(',] \t\r\n', c) do + s ||:= c + put(l, s) + if c == "]" then + return l + } + } + + fail # EOF hit +end + +############################################################################ +# save_session() saves the current session to a file. If "pflag" is set, +# the standard prefix is used (for prototype mode). +############################################################################ +procedure save_session(s, pflag) + local ofile + + sanity_check() | fail + ofile := open(s, "w") + if /ofile then { + Notice("Could not open " || s, "(FILE WAS NOT SAVED)") + fail + } + if /SIZER.dlog then + save_app(ofile, pflag, s) + else + save_dlog(ofile, pflag, s) + close(ofile) + if /pflag then + DIRTY := &null + return +end + +############################################################################ +# sanity_check() issues warnings if certain things don't look right. +############################################################################ +procedure sanity_check() + local messages, npush, ndflt, nrect, nlist, o + + messages := [] + npush := ndflt := nrect := nlist := 0 + every o := !O_LIST do { + case type(o) of { + "button_obj": { + if /o.toggle then npush +:= 1 + if \o.dflt then ndflt +:= 1 + } + "rect_obj": { + nrect +:= 1 + } + "list_obj": { + nlist +:= 1 + } + } + } + + if \SIZER.dlog then { + if ndflt > 1 then + put(messages, "", + "More than one button is marked as the default.", + "Only one will be used.") + if npush = 0 then + put(messages, "", + "There is no non-toggle button, so it will not", + "be possible to dismiss the dialog box.") + if nrect > 0 | nlist > 0 then + put(messages, "", + "There are one or more regions or text lists,", + "but these do not function in dialog boxes.") + } + else { + if ndflt > 0 then + put(messages, "", + "A button is marked as a dialog default,", + "but this is not a dialog specification.") + } + + if *messages = 0 then + return + + push(messages, "Warning:") + case TextDialog(messages, , , , ["Continue", "Cancel"], 2) of { + "Continue": return + "Cancel": fail + } +end + +############################################################################ +# save_app() saves the session as an application. If "pflag" is set, +# the standard prefix is used (for prototype mode). +############################################################################ +procedure save_app(ofile, pflag, filename) + local id + + id := ("" ~== \SIZER.id) | "ui" + + if \pflag then + write(ofile, PTITLE, "\n\n") + if \pflag | /USER_PREFIX then { + if /pflag then + ipl_header(ofile, filename, "Program to", "vsetup") + app_prologue(ofile, id, pflag) + if /pflag then + save_procs(ofile) + } + else + writes(ofile, USER_PREFIX) + + write(ofile, HEADER) + write(ofile, "procedure ", id, "_atts()") + writes(ofile, " return [\"size=", SIZER.x + SIZER.w, ",", + SIZER.y - CANVASY + SIZER.h, "\", \"bg=", VBackground, "\"") + writes(ofile, ", \"label=", "" ~== SIZER.label, "\"") + write(ofile, "]") + write(ofile,"end") + write(ofile) + write(ofile, "procedure ", id, "(win, cbk)") + write(ofile, "return vsetup(win, cbk,") + output_spec(ofile, SIZER) + output_all(ofile, O_LIST) + write(ofile, " )") + write(ofile, "end") + write(ofile, TRAILER) + + if /pflag & \USER_SUFFIX then + writes(ofile, USER_SUFFIX) + return +end + +############################################################################ +# save_procs() generates empty callback procedures in lexical order. +############################################################################ +procedure save_procs(ofile) + local o, t, l + + t := table() + every o := !O_LIST do + t["" ~== \o.proc] := o + l := sort(t, 3) + while get(l) do { + o := get(l) + writes(ofile, "procedure ", o.proc, "(vidget, ") + if type(o) == "rect_obj" then + write(ofile, "e, x, y)") + else + write(ofile, "value)") + write(ofile, " return") + write(ofile, "end") + write(ofile) + } + return +end + +############################################################################ +# save_dlog() saves the session as a dialog. If "pflag" is set, +# the standard prefix is used (for prototype mode). +############################################################################ +procedure save_dlog(ofile, pflag, filename) + local id + + id := ("" ~== \SIZER.id) | "dl" + + if \pflag then + dlog_prototype(ofile, id) + else if /USER_PREFIX then { + ipl_header(ofile, filename, "Procedure to", "dsetup") + dlog_prologue(ofile) + } + else + writes(ofile, USER_PREFIX) + + write(ofile, HEADER) + write(ofile, "procedure ", id, "(win, deftbl)") + write(ofile, "static dstate") + write(ofile, "initial dstate := dsetup(win,") + output_spec(ofile, SIZER) + output_all(ofile, O_LIST) + write(ofile, " )") + write(ofile, "return dpopup(win, deftbl, dstate)") + write(ofile, "end") + write(ofile, TRAILER) + + if /pflag & \USER_SUFFIX then + writes(ofile, USER_SUFFIX) + return +end + +############################################################################ +# output_all() outputs the members of an object list, sorted by ID, +# but with rectangles last so that they can enclose other objects. +############################################################################ +record output_rec(obj, key) + +procedure output_all(f, l) + local t, e, k + + t := [] + every e := !l do { + if type(e) == "rect_obj" then + k := "~" || right(e.w * e.h, 20) || e.id # rects last, by area + else + k := e.id + put(t, output_rec(e, k)) + } + t := sortf(t, 2) + every e := !t do + output_spec(f, e.obj) + return +end + +############################################################################ +# output_spec() outputs the spec for an object. +############################################################################ +procedure output_spec(f, o) + local r + + # set standard fields + r := ext_rec(o) + r.id := o.id + r.proc := o.proc + r.x := o.x + r.y := o.y - CANVASY + r.w := o.w + r.h := o.h + # set type-dependent fields + case type(o) of { + "sizer_obj" : save_sizer(r, o) + "button_obj" : save_button(r, o) + "text_input_obj" : save_text_input(r, o) + "line_obj" : save_line(r, o) + "rect_obj" : save_rect(r, o) + "slider_obj" : save_slider(r, o) + "radio_button_obj" : save_radio_button(r, o) + "label_obj" : save_label(r, o) + "menu_obj" : save_menu(r, o) + "list_obj" : save_list_obj(r, o) + } + writes(f, " [\"") + writes(f, r.id, ":", r.typ, ":", r.sty, ":", r.num, ":") + writes(f, r.x, ",", r.y, ",", r.w, ",", r.h, ":") + writes(f, r.lbl, "\",") + if /SIZER.dlog then + writes(f, r.proc) + if \r.etc then + output_list(f, r.etc) + write(f, "],") + return +end + +############################################################################ +# output_list() outputs a list in Icon form preceded by ",\n". +############################################################################ +procedure output_list(f, a) + local prefix, elem, n + static indent + initial indent := " " + + n := 0 + indent ||:= " " + writes(f, ",\n", indent, "[") + prefix := "" + while elem := get(a) do + if type(elem) == "list" then { + output_list(f, elem) + prefix := ",\n" || indent + n := 0 + } + else { + writes(f, prefix, image(elem)) + if (n +:= 1) % 5 = 0 then + prefix := ",\n" || indent + else + prefix := "," + } + writes(f, "]") + indent := indent[1:-3] +end + +############################################################################ +# prototype() saves, compiles, and executes the current session. +############################################################################ +procedure prototype() + local f, line + + if f := open(PROTOFILE) then { + line := read(f) + close(f) + if \line & not (line ? =PTITLE) then { + Notice("Cannot create prototype file " || PROTOFILE || ":", + "it already contains something that is not a VIB prototype") + fail + } + } + + # write source file + if save_session(PROTOFILE, 1) then { + # translate and execute + WAttrib("pointer=" || ("wait" | "watch")) + system(BUILDPROTO) + remove(PROTOFILE) + WAttrib("pointer=" || ("left ptr" | "arrow")) + system(EXECPROTO) + } +end + +############################################################################ +# newname() invents a name when creating a new file. +############################################################################ +procedure newname() + local s, i, f + + every i := seq() do { + s := "app" || i || ".icn" # invent "app<n>.icn" file name + if f := open(s) then + close(f) # can't use this name; already exists + else + return s # found a safe new name + } +end + +############################################################################ +# ipl_header() writes a standard IPL application header. +############################################################################ +procedure ipl_header(ofile, filename, subject, links) + local hline, date + + hline := repl("#", 76) + &dateline ? { + tab(upto(',') + 2) + date := tab(upto(',') + 6) + } + + write(ofile, hline) + write(ofile, "#\n#\tFile: ", filename) + write(ofile, "#\n#\tSubject: ", subject, " ...") + write(ofile, "#\n#\tAuthor: ") + write(ofile, "#\n#\tDate: ", date) + write(ofile, "#\n", hline) + write(ofile, "#\n#\n#\n", hline) + write(ofile, "#\n# Requires:\n#\n", hline) + write(ofile, "#\n# Links: ", links) + write(ofile, "#\n", hline) + write(ofile) + return +end + +############################################################################ +# app_prologue() writes a main program and other code for a new application. +############################################################################ +procedure app_prologue(f, id, pflag) + local vecho, e + + if \pflag then + vecho := ", VEcho" + else + vecho := "" + + every write(f, ![ + "# This vib interface specification is a working program that responds", + "# to vidget events by printing messages. Use a text editor to replace", + "# this skeletal program with your own code. Retain the vib section at", + "# the end and use vib to make any changes to the interface.", + "", + "link vsetup", + "", + "procedure main(args)", + " local vidgets, root, paused", + "", + " (WOpen ! " || id || "_atts()) | stop(\"can't open window\")", + " vidgets := " || id || "(" || vecho || ")\t\t\t\t# set up vidgets", + " root := vidgets[\"root\"]" + ]) + + # generate a sample VSetItems call for every list object (prototyping only) + if \pflag then + every e := !O_LIST do + if type(e) == "list_obj" then + write(f, " VSetItems(vidgets[\"", e.id, + "\"], [\"a\", \"b\", \"c\", \"d\"])"); + + every write(f, ![ + "", + " paused := 1\t\t\t\t\t# flag no work to do", + " repeat {", + " # handle any events that are available, or", + " # wait for events if there is no other work to do", + " while (*Pending() > 0) | \\paused do {", + " ProcessEvent(root, QuitCheck)", + " }", + " # if <paused> is set null, code can be added here", + " # to perform useful work between checks for input", + " }", + "end", + ""]) +end + +############################################################################ +# dlog_prologue() writes a header for a dialog file. +############################################################################ +procedure dlog_prologue(f) +every write(f, ![ + "# Link this dialog specification with the rest of your program code.", + "# Use vib to make any changes.", + "", + "link dsetup", + ""]) +end + +############################################################################ +# dlog_prototype() writes a header for a dialog prototyping run. +############################################################################ +procedure dlog_prototype(f, id) + write(f, PTITLE) + write(f) + write(f, "link dsetup, graphics") + write(f) + write(f, "procedure main(args)") + write(f, " remove(", image(PROTOEXE), ")") + write(f, " dproto(", id, ", , ", + SIZER.x + SIZER.w, ", ", SIZER.y - CANVASY + SIZER.h, ", args)") + write(f, "end") + write(f) +end diff --git a/ipl/gpacks/vib/vibglbl.icn b/ipl/gpacks/vib/vibglbl.icn new file mode 100644 index 0000000..e226fe8 --- /dev/null +++ b/ipl/gpacks/vib/vibglbl.icn @@ -0,0 +1,38 @@ +############################################################################ +# +# vibglbl.icn -- global variables +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +global SESSION # name of current editing session (file name) +global DIRTY # dirty bit to inform user of unsaved changes +global ALIGN # flag indicating current state of align mode + +global XORWIN # &window clone clone with "drawop=reverse" +global APPWIN # &window clipped to application area +global DRAGWIN # clone with dark background, for dragging + +global CANVASY # offset to app coordinate system (below menu bar) +global PAD # vertical spacing in dialog boxes + +global ROOT # root frame for vidgets +global MENUBAR # vidget for VIB's menu bar +global SELECT # vidget for "Select" pseudo-menu button + +global P_LIST # list of palette objects +global O_LIST # list of graphical object instances +global SIZER # sizer object that gets dragged around the canvas + +global FOCUS # current object of focus (if any) +global DELETED # last object deleted (if any) + +global LBMASK # cset of chars allowed in object label +global IDMASK # cset of chars allowed in object index (table key) +global CBMASK # cset of chars allowed in callback or other Icon ID + +# external representation record +record ext_rec(id, typ, sty, num, x, y, w, h, lbl, proc, etc) diff --git a/ipl/gpacks/vib/viblabel.icn b/ipl/gpacks/vib/viblabel.icn new file mode 100644 index 0000000..54e71dd --- /dev/null +++ b/ipl/gpacks/vib/viblabel.icn @@ -0,0 +1,125 @@ +############################################################################ +# +# viblabel.icn -- procedures for defining a label object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" + +########################################################################## +# label_obj: +# v : vidget used for drawing label +# proc : name of user callback procedure (unused for a label) +# id : unique means of identifying instance +# x,y,w,h : bounding box +# label : label itself +# focus : should focus lines be drawn around this object? +########################################################################## +record label_obj(v, proc, id, x, y, w, h, label, focus) + +########################################################################## +# create_label() creates a label instance and draws the label if +# it is a first class object. +########################################################################## +procedure create_label(x, y, label) + local r, id + + id := next_id("label") + r := label_obj(, "", "label" || id, x, y, 0, 0, label, 0) + r.v := Vmessage(ROOT, x, y, APPWIN, label) + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# draw_label() draws the given label instance. +########################################################################## +procedure draw_label(r) + r.v.s := r.label + VDraw(r.v) +end + +########################################################################## +# update_label_bb() disallows resizing of a label. +########################################################################## +procedure update_label_bb(object) + object.w := TextWidth(APPWIN, object.label) + object.h := WAttrib(APPWIN, "fheight") +end + +########################################################################## +# load_label() restores a label object from session code. +########################################################################## +procedure load_label(r, o) + r.label := o.lbl + r.v := Vmessage(ROOT, r.x, r.y, APPWIN, r.label) + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# save_label() augments the record for saving a label object. +########################################################################## +procedure save_label(r, o) + r.typ := "Label" + r.lbl := image(o.label)[2:-1] + return +end + +########################################################################## +# display_label_atts() displays the attribute sheet with the current +# attributes for the given label instance. +########################################################################## +procedure display_label_atts(object) + local t + + t := table() + t["a_label"] := object.label + t["b_id"] := object.id + t["c_x"] := object.x + t["d_y"] := object.y - CANVASY + + repeat { + if label_dialog(t) == "Cancel" then + fail + + if illegal(t["a_label"], "Label", "l") | + illegal(t["b_id"], "ID", "s") | + illegal(t["c_x"], "X", "i") | + illegal(t["d_y"], "Y", "i") + then + next + + if *t["a_label"] = 0 then { + Notice("Label value must be specified") + next + } + + object.label := t["a_label"] + object.id := t["b_id"] + + unfocus_object(object) + move_object(object, t["c_x"], t["d_y"] + CANVASY) + focus_object(object) + break + } +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure label_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["label_dialog:Sizer::1:0,0,460,180:",], + ["_cancel:Button:regular::250,120,50,30:Cancel",], + ["_okay:Button:regular:-1:180,120,50,30:Okay",], + ["a_label:Text::50:13,14,430,19:label: \\=",], + ["b_id:Text::40:13,35,360,19:ID: \\=",], + ["c_x:Text::3:13,62,101,19: x: \\=",], + ["d_y:Text::3:13,83,101,19: y: \\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/vibline.icn b/ipl/gpacks/vib/vibline.icn new file mode 100644 index 0000000..16f3d89 --- /dev/null +++ b/ipl/gpacks/vib/vibline.icn @@ -0,0 +1,197 @@ +############################################################################ +# +# vibline.icn -- procedures for defining a line object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" + +########################################################################## +# line_obj: +# proc : name of user callback procedure +# v : vidget used for drawing line +# id : unique means of identifying instance +# x,y,w,h : bounding box +# x1,y1 : one endpoint +# y1,y2 : other endpoint +# focus : should focus lines be drawn around this object? +########################################################################## +record line_obj(v, proc, id, x, y, w, h, x1, y1, x2, y2, focus) + +########################################################################## +# create_line() creates a line instance and draws the line if +# it is a first class object. +########################################################################## +procedure create_line(x1, y1, x2, y2) + local r, id + + id := next_id("line") + r := line_obj(, "", "line" || id, , , , , x1, y1, x2, y2, 0) + r.v := Vline(APPWIN, x1, y1, x2, y2) + VInsert(ROOT, r.v, x1, y1) + VRemove(ROOT, r.v, 1) + update_line_bb(r) + return r +end + +########################################################################## +# update_line_bb() updates various attributes of the line that +# change when the button is resized, etc. +########################################################################## +procedure update_line_bb(object) + if object.x1 < 0 then { + object.x2 -:= object.x1 + object.x1 := 0 + } + if object.x2 < 0 then { + object.x1 -:= object.x2 + object.x2 := 0 + } + if object.y1 < CANVASY then { + object.y2 -:= (object.y1 - CANVASY) + object.y1 := CANVASY + } + if object.y2 < CANVASY then { + object.y1 -:= (object.y2 - CANVASY) + object.y2 := CANVASY + } + object.x := minimum(object.x1, object.x2) - 2 + object.y := minimum(object.y1, object.y2) - 2 + object.w := abs(object.x1 - object.x2) + 4 + object.h := abs(object.y1 - object.y2) + 4 +end + +########################################################################## +# draw_line() draws the given line object. +########################################################################## +procedure draw_line(r) + r.v.ax1 := r.x1 + r.v.ay1 := r.y1 + r.v.ax2 := r.x2 + r.v.ay2 := r.y2 + VDraw(r.v) + return r +end + +########################################################################## +# outline_line() draws an outline for the given line. Outlines are +# used when the object is moved or resized. +########################################################################## +procedure outline_line(r) + DrawLine(XORWIN, r.x1, r.y1, r.x2, r.y2) +end + +########################################################################## +# drag_line() is a special procedure for dragging line objects. +########################################################################## +procedure drag_line(r) + local xoff, yoff, x1, y1, dx, dy + + x1 := r.x1 + y1 := r.y1 + dx := r.x2 - x1 + dy := r.y2 - y1 + xoff := x1 - &x + yoff := y1 - &y + DrawLine(XORWIN, x1, y1, x1 + dx, y1 + dy) + until Event(XORWIN) === (&lrelease | &mrelease | &rrelease) do { + DrawLine(XORWIN, x1, y1, x1 + dx, y1 + dy) + x1 := &x + xoff + y1 := &y + yoff + DrawLine(XORWIN, x1, y1, x1 + dx, y1 + dy) + } + DrawLine(XORWIN, x1, y1, x1 + dx, y1 + dy) + &x := r.x + x1 - r.x1 + &y := r.y + y1 - r.y1 +end + +########################################################################## +# load_line() restores a line object from session code. +########################################################################## +procedure load_line(r, o) + r.x1 := o.x + r.y1 := o.y + CANVASY + r.x2 := o.w + r.y2 := o.h + CANVASY + r.v := Vline(APPWIN, r.x1, r.y1, r.x2, r.y2) + VInsert(ROOT, r.v, r.x1, r.y1) + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# save_line() augments the record for saving a line object. +########################################################################## +procedure save_line(r, o) + r.typ := "Line" + r.x := o.x1 + r.y := o.y1 - CANVASY + r.w := o.x2 + r.h := o.y2 - CANVASY + r.proc := &null + return +end + +########################################################################## +# display_line_atts() displays the attribute sheet with the current +# attributes for the given line instance. +########################################################################## +procedure display_line_atts(object) + local t, dx, dy + + t := table() + t["a_id"] := object.id + t["c_x1"] := object.x1 + t["d_y1"] := object.y1 - CANVASY + t["e_x2"] := object.x2 + t["f_y2"] := object.y2 - CANVASY + + repeat { + if line_dialog(t) == "Cancel" then + fail + + if illegal(t["a_id"], "ID", "s") | + illegal(t["c_x1"], "X1", "i") | + illegal(t["d_y1"], "Y1", "i") | + illegal(t["e_x2"], "X2", "i") | + illegal(t["f_y2"], "Y2", "i") + then + next + + unfocus_object(object) + erase_object(object) + + object.id := t["a_id"] + object.x1 := t["c_x1"] + object.y1 := t["d_y1"] + CANVASY + object.x2 := t["e_x2"] + object.y2 := t["f_y2"] + CANVASY + + # can't just do a move_object() here: doesn't work for line changes + update_line_bb(object) + draw_canvas() + focus_object(object) + DIRTY := 1 + break + } +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure line_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["line_dialog:Sizer::1:0,0,350,138:",], + ["_cancel:Button:regular::192,87,50,30:Cancel",], + ["_okay:Button:regular:-1:127,86,50,30:Okay",], + ["a_id:Text::40:13,14,318,19:ID: \\=",], + ["c_x1:Text::3:13,42,59,19:x1: \\=",], + ["d_y1:Text::3:81,42,59,19:y1: \\=",], + ["e_x2:Text::3:204,42,59,19:x2: \\=",], + ["f_y2:Text::3:272,42,59,19:y2: \\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/viblist.icn b/ipl/gpacks/vib/viblist.icn new file mode 100644 index 0000000..66fc813 --- /dev/null +++ b/ipl/gpacks/vib/viblist.icn @@ -0,0 +1,168 @@ +############################################################################ +# +# viblist.icn -- procedures for defining a list object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vdefns.icn" +$include "vibdefn.icn" + +$define MINIMUM_HEIGHT (VSlider_DefWidth * VSlider_MinAspect) +$define MINIMUM_WIDTH (VFWidth + VSlider_DefWidth + 10) +$define DEFAULT_HEIGHT 100 +$define DEFAULT_WIDTH 100 +$define DEFAULT_STYLE "w" +$define DEFAULT_SCROLL 0 + +########################################################################## +# list_obj: +# v : vidget used for drawing list object +# proc : name of user callback procedure +# id : unique means of identifying instance +# x,y,w,h : bounding box +# style : "r", "w", or "a" indicating list editing mode +# scroll : 1 for passive scrolling that waits for mouse release +########################################################################## +record list_obj(v, proc, id, x, y, w, h, style, scroll, focus) + +########################################################################## +# create_list() creates a list instance and draws it. +########################################################################## +procedure create_list(x, y, w, h, style, scroll) + local r, id + + /w := DEFAULT_WIDTH + /h := DEFAULT_HEIGHT + /style := DEFAULT_STYLE + /scroll := DEFAULT_SCROLL + id := next_id("list") + r := list_obj(, "list_cb" || id, "list" || id, x, y, w, h, style, scroll) + r.v := Vlist(ROOT, x, y, APPWIN, , id, [], scroll, w, h, style) + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# draw_list() draws the given list object. +########################################################################## +procedure draw_list(r) + VResize(r.v) + VDraw(r.v) + return r +end + +########################################################################## +# update_list_bb() enforces a minimum size when resizing. +########################################################################## +procedure update_list_bb(object) + object.w <:= MINIMUM_WIDTH + object.h <:= MINIMUM_HEIGHT +end + +########################################################################## +# load_list() restores a list object from session code. +########################################################################## +procedure load_list(r, o) + r.style := o.sty + if integer(o.num) > 0 then + r.scroll := 1 + else + r.scroll := &null + r.v := Vlist(ROOT, r.x, r.y, + APPWIN, , r.id, [], r.scroll, r.w, r.h, r.style) + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# save_list_obj() augments the record for saving a list object. +# (_obj is in the name due to a name conflict with a library procedure.) +########################################################################## +procedure save_list_obj(r, o) + r.typ := "List" + r.sty := o.style + r.num := o.scroll + return +end + +########################################################################## +# display_list_atts() displays the attribute sheet with the current +# attributes for the given list instance. +########################################################################## +procedure display_list_atts(object) + local t + + t := table() + t["a_id"] := object.id + t["b_callback"] := object.proc + t["c_x"] := object.x + t["d_y"] := object.y - CANVASY + t["e_width"] := object.w + t["f_height"] := object.h + + t["g_style"] := case object.style of { + "r" : "read only" + "w" : "select one" + "a" : "select many" + } + + repeat { + if list_dialog(t) == "Cancel" then + fail + + if illegal(t["a_id"], "ID", "s") | + illegal(t["b_callback"], "Callback", "p") | + illegal(t["c_x"], "X", "i") | + illegal(t["d_y"], "Y", "i") | + illegal(t["e_width"], "Width", MINIMUM_WIDTH) | + illegal(t["f_height"], "Height", MINIMUM_HEIGHT) + then + next + + object.id := t["a_id"] + object.proc := t["b_callback"] + + object.style := case t["g_style"] of { + "read only" : "r" + "select one" : "w" + "select many" : "a" + } + + unfocus_object(object) + move_object(object, + t["c_x"], t["d_y"] + CANVASY, t["e_width"], t["f_height"]) + + # delete and recreate the vidget in case the style changed + erase_object(object) + object.v := Vlist(ROOT, object.x, object.y, APPWIN, , object.id, + [], object.scroll, object.w, object.h, object.style) + VRemove(ROOT, object.v) + + draw_object(object) + focus_object(object) + break + } +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure list_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["list_dialog:Sizer::1:0,0,383,198:",], + ["_cancel:Button:regular::197,148,50,30:Cancel",], + ["_okay:Button:regular:-1:130,148,50,30:Okay",], + ["a_id:Text::40:13,14,360,19:ID: \\=",], + ["b_callback:Text::40:13,35,360,19:callback: \\=",], + ["c_x:Text::3:13,62,101,19: x: \\=",], + ["d_y:Text::3:13,83,101,19: y: \\=",], + ["e_width:Text::3:129,63,101,19: width: \\=",], + ["f_height:Text::3:129,84,101,19: height: \\=",], + ["g_style:Choice::3:266,59,106,63:",, + ["read only","select one","select many"]], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/vibmenu.icn b/ipl/gpacks/vib/vibmenu.icn new file mode 100644 index 0000000..d9d4c1e --- /dev/null +++ b/ipl/gpacks/vib/vibmenu.icn @@ -0,0 +1,468 @@ +############################################################################ +# +# vibmenu.icn -- procedures for defining a menu object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vdefns.icn" +$include "vibdefn.icn" + +global startyMENU, MENU_TALK +global MENU_VIDGET +global reg_list, ins_list +global SIM_TAB + +########################################################################## +# menu_obj: +# v : vidget used for drawing menu +# proc : name of user callback procedure +# id : unique means of identifying instance +# x,y,w,h : bounding box +# label : menu button label +# lx,ly : label coordinates +# style : style of menu ... currently only pull down is supported +# focus : should focus lines be drawn around this object? +# items : a list of menu items that make up the menu +# +# menu_item: +# label : menu choice name +# items : a list of menu_items for a submenu, or an empty list +# +# menu_id: +# v : text vidget for label field +# item : corresponding menu_item record +########################################################################## + +record menu_obj(v, proc, id, x, y, w, h, label, lx, ly, style, focus, items) +record menu_item(label, items) +record menu_id(tv, item) + +########################################################################## +# create_menu() creates a menu instance and draws the menu button. +########################################################################## +procedure create_menu(x, y, label, style) + local r, id + + id := next_id("menu") + /style := "pull" + r := menu_obj(, "menu_cb" || id, "menu" || id, + x, y, 0, 0, label, 0, 0, style, 0, []) + r.v := Vbutton(ROOT, x, y, APPWIN, label, , id, V_RECT) + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# copy_submenu() recursively copies a cascading menu. +########################################################################## +procedure copy_submenu(old, temp) + local i + + /temp := copy(old) + if *old.items > 0 then { + temp.items := [] + every put(temp.items, copy_submenu(!old.items)) + } + return temp +end + +########################################################################## +# copy_menu() makes a copy of a menu old and returns it in new. +########################################################################## +procedure copy_menu(new, old) + every put(new.items, copy_submenu(!old.items)) +end + +########################################################################## +# add_item() adds a menu choice with name "label" to the menu at the +# location indicated by "after". +########################################################################## +procedure add_item(menu, label, after) + local choice + + after >:= *menu.items + choice := menu_item(label, []) + menu.items := menu.items[1:after+1] ||| [choice] ||| menu.items[after+1:0] +end + +########################################################################## +# update_menu_bb() updates various attributes of the menu that +# change when the menu button label is altered. +########################################################################## +procedure update_menu_bb(object) + object.w := object.v.aw # disallow changes + object.h := object.v.ah + # .lx/.ly values must agree with locations drawn by menu vidgets + # else the simulation of a menu leaves the label in the wrong place + # and moving the menu then leaves debris behind on the screen + object.lx := object.x + 4 + object.ly := object.y + WAttrib(APPWIN, "ascent") + 4 +end + +########################################################################## +# draw_menu() draws the given menu button object. +########################################################################## +procedure draw_menu(r) + VResize(r.v, r.x, r.y, r.w, r.h) + VDraw(r.v) + return r +end + +########################################################################## +# load_menu() restores a menu object from session code. +########################################################################## +procedure load_menu(r, o) + r.style := o.sty + r.label := o.lbl + r.items := load_submenu(o.etc) + r.v := Vbutton(ROOT, r.x, r.y, APPWIN, r.label, , r.id, V_RECT) + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# load_submenu() restores a menu or submenu list. +########################################################################## +procedure load_submenu(spec) + local i, r, lst + + lst := [] + while i := get(spec) do { + r := menu_item() + r.label := i + if type(spec[1]) == "list" then { + r.items := load_submenu(get(spec)) + } + else + r.items := [] + put(lst, r) + } + return lst +end + +########################################################################## +# save_menu() augments the record for saving a menu object. +########################################################################## +procedure save_menu(r, o) + r.typ := "Menu" + r.lbl := o.label + r.sty := o.style + r.etc := save_submenu(o.items) + return +end + +########################################################################## +# save_submenu() builds a list representing a submenu. +########################################################################## +procedure save_submenu(items) + local l, i + l := [] + every i := !items do { + put(l, i.label) + if *i.items > 0 then + put(l, save_submenu(i.items)) + } + return l +end + +########################################################################## +# simulate_sub_menu() is called by simulate_menu to recursively construct +# WIT submenus and place them in a table for reference +# by simulate_menu(). +########################################################################## +procedure simulate_sub_menu(obj, label) + local i, temp_list + + every i := 1 to *obj.items do { + if *obj.items[i].items > 0 then + simulate_sub_menu(obj.items[i], label || "_" || obj.items[i].label) + } + temp_list := [&window] + every i := 1 to *obj.items do { + put(temp_list, obj.items[i].label) + if *obj.items[i].items > 0 then + put(temp_list, SIM_TAB["id_" || label || "_" || obj.items[i].label]) + else + put(temp_list, &null) # null callback + } + SIM_TAB["id_" || label] := Vsub_menu ! temp_list +end + +########################################################################## +# simulate_menu() creates a complete WIT menu object so that the +# VIB user can see what the menu looks like without +# prototyping. +########################################################################## +procedure simulate_menu(obj) + local i, temp_list, sim_menu, tmp + + SIM_TAB := table() + every i := 1 to *obj.items do { + if *obj.items[i].items > 0 then + simulate_sub_menu(obj.items[i], obj.items[i].label) + } + temp_list := [&window] + every i := 1 to *obj.items do { + put(temp_list, obj.items[i].label) + if *obj.items[i].items > 0 then + put(temp_list, SIM_TAB["id_" || obj.items[i].label]) + else + put(temp_list, &null) # null callback + } + sim_menu := Vmenu_bar_item(&window, obj.label, , , , , Vsub_menu ! temp_list) + tmp := ScratchCanvas(ROOT.win, obj.w, obj.h) + CopyArea(ROOT.win, tmp, obj.x, obj.y, obj.w, obj.h) + VInsert(ROOT, sim_menu, obj.x, obj.y) + VResize(sim_menu) + VEvent(sim_menu, &mpress) + VRemove(ROOT, sim_menu, 1) + CopyArea(tmp, ROOT.win, 0, 0, obj.w, obj.h, obj.x, obj.y) + EraseArea(tmp) +end + +########################################################################## +# menu_atts() defines the attribute sheet template for a menu object. +########################################################################## +procedure menu_atts() + local tempy + + MENU_TALK := Vdialog(&window, PAD, PAD) + tempy := 0 + VRegister(MENU_TALK, + Vtext(&window, "menu label: ", , 1, TEXTCHARS, LBMASK), 0, tempy) + tempy +:= PAD + VRegister(MENU_TALK, + Vtext(&window, "ID: ", , 2, TEXTCHARS, IDMASK), 0, tempy) + tempy +:= PAD + VRegister(MENU_TALK, + Vtext(&window, "callback: ", , 3, TEXTCHARS, CBMASK), 0, tempy) + + VRegister(MENU_TALK, + Vtext(&window, "x: ", , 4, 3, &digits), 80 + TEXTWIDTH + 10, 0) + VRegister(MENU_TALK, + Vtext(&window, "y: ", , 5, 3, &digits), 80 + TEXTWIDTH + 10, PAD) + VFormat(MENU_TALK) + startyMENU := tempy +end + +########################################################################## +# display_menu_atts() displays the attribute sheet with the current +# attributes for the given menu instance. +########################################################################## +procedure display_menu_atts(object) + local i, data, send_data, new, v, dw, l + initial menu_atts() + + new := copy(object) + new.y -:= CANVASY + new.items := [] + copy_menu(new, object) + + repeat { + + menu_list_atts(MENU_TALK, startyMENU, new.items) + VFormat(MENU_TALK) + + MENU_VIDGET := &null + send_data := [new.label, new.id, new.proc, new.x, new.y] + every put(send_data, (!new.items).label) + data := VOpenDialog(MENU_TALK, , "menu_dialog", send_data, "Okay") + every VUnregister(MENU_TALK, !reg_list) + every VRemove(MENU_TALK, !ins_list, 1) + + if data === send_data then + fail # cancelled + + new.label := strip(get(data)) + new.id := strip(get(data)) + new.proc := strip(get(data)) + new.x := get(data) + new.y := get(data) + every (!new.items).label := get(data) + + # if "add" or "del" was pressed, process it and loop to re-post dialog + if \MENU_VIDGET then { + l := [] + every i := 1 to *new.items do { + v := reg_list[i] + if v.ay - PAD < MENU_VIDGET.ay-1 < v.ay then + put(l, menu_item("", [])) + if v.ay ~= MENU_VIDGET.ay-1 then + put(l, new.items[i]) + } + if MENU_VIDGET.ay-1 > reg_list[*new.items].ay | *l = 0 then + put(l, menu_item("", [])) + new.items := l + next + } + + # check for legal field values + + if illegal(new.id, "ID", "s") | + illegal(new.label, "Label", "l") | + illegal(new.proc, "Callback", "p") | + illegal(new.x, "X", "i") | + illegal(new.y, "Y", "i") + then + fail + + # everything is valid + + dw := VFWidth * (*new.label - *object.label) + + object.label := new.label + object.id := new.id + object.proc := new.proc + object.items := new.items + + object.v.s := object.label + object.v.aw := object.w + dw + + unfocus_object(object) + move_object(object, new.x, new.y + CANVASY, object.w, object.h) + focus_object(object) + break + } +end + +########################################################################## +# display_submenu_atts() displays the attribute sheet with the current +# attributes for the given submenu instance. +########################################################################## +procedure display_submenu_atts(button, val) + local submenu_talk, send_data, data, old_reg, old_ins + local entry, items, s, i, v + + old_reg := reg_list + old_ins := ins_list + entry := button.id.item + items := copy(entry.items) + if *items = 0 then + every 1 to 3 do + put(items, menu_item("", [])) + + repeat { + + submenu_talk := Vdialog(&window, PAD, PAD) + v := Vmessage(&window, "\"" || button.id.tv.data || \"\" submenu entries") + VInsert(submenu_talk, v, 0, 0) + menu_list_atts(submenu_talk, 0, items) + VFormat(submenu_talk) + + MENU_VIDGET := &null + send_data := [] + every put(send_data, (!items).label) + data := VOpenDialog(submenu_talk, , "submenu_dialog", send_data, "Okay") + every VUnregister(MENU_TALK, !reg_list) + every VRemove(MENU_TALK, !ins_list, 1) + + if data === send_data then { + reg_list := old_reg + ins_list := old_ins + fail # cancelled + } + + every (!items).label := get(data) # update new labels + + if *(items := update_menu_list(items)) > 0 then + next # loop to re-post dialog + + # the revised list has been accepted + + entry.items := items + VErase(button) + if *items = 0 then + s := "create submenu" + else + s := "edit submenu (" || *items || ")" + button.aw +:= VFWidth * (*s - *button.s) + button.s := s + VResize(button) + VDraw(button) + break + } + reg_list := old_reg + ins_list := old_ins +end + +########################################################################## +# menu_list_atts() adds the menu items (with add/del/submenu buttons) +# and okay/cancel buttons to a dialog box. +# ins_list and reg_list are set. +########################################################################## +procedure menu_list_atts(menu, y, itemlist) + local i, s, v, id + + # construct text fields with "add", "del", and "submenu" buttons + + reg_list := [] + ins_list := [] + every i := 0 to *itemlist do { + y +:= PAD + + v := Vbutton(&window, "add", menu_mod_cb, V_OK, , 28, 17) + VInsert(menu, v, 0, y + PAD / 2) + put(ins_list, v) + + if i = 0 then + next + + v := Vbutton(&window, "del", menu_mod_cb, V_OK, , 28, 17) + VInsert(menu, v, 35 + TEXTWIDTH, y + 1) + put(ins_list, v) + + v := Vtext(&window, "", , 100 + i, TEXTCHARS, LBMASK) + VRegister(menu, v, 35, y) + put(reg_list, v) + id := menu_id(v, itemlist[i]) + + if *itemlist[i].items = 0 then + s := "create submenu" + else + s := "edit submenu (" || *itemlist[i].items || ")" + v := Vbutton(&window, s, display_submenu_atts, id, , , 17) + VInsert(menu, v, 35 + TEXTWIDTH + 40, y + 1) + put(ins_list, v) + } + + # add "Okay" and "Cancel" + y +:= 2 * PAD + v := Vbutton(&window, "Okay", , V_OK, , 50, 30) + VInsert(menu, v, TEXTWIDTH / 2 + 30, y) + put(ins_list, v) + v := Vbutton(&window, "Cancel", , V_CANCEL, , 50, 30) + VInsert(menu, v, TEXTWIDTH / 2 + 100, y) + put(ins_list, v) +end + +########################################################################## +# update_menu_list() creates a new item list reflecting adds and deletes. +########################################################################## +procedure update_menu_list(oldlist) + local newlist, v, i + + if /MENU_VIDGET then + fail + newlist := [] + every i := 1 to *oldlist do { + v := reg_list[i] + if v.ay - PAD < MENU_VIDGET.ay-1 < v.ay then + put(newlist, menu_item("", [])) + if v.ay ~= MENU_VIDGET.ay-1 then + put(newlist, oldlist[i]) + } + if MENU_VIDGET.ay-1 > reg_list[*oldlist].ay then + put(newlist, menu_item("", [])) + MENU_VIDGET := &null + return newlist +end + +########################################################################## +# menu_mod_cb is called when an "add" or "del" button is pressed. +########################################################################## +procedure menu_mod_cb(v) + MENU_VIDGET := v +end diff --git a/ipl/gpacks/vib/vibradio.icn b/ipl/gpacks/vib/vibradio.icn new file mode 100644 index 0000000..b164594 --- /dev/null +++ b/ipl/gpacks/vib/vibradio.icn @@ -0,0 +1,209 @@ +############################################################################ +# +# vibradio.icn -- procedures for defining a radio button object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" + +global RB_starty, RADIO_TALK, RADIO_VIDGET + +########################################################################## +# radio_button_obj: +# v : vidget used for drawing radio button +# proc : name of user callback procedure +# id : unique means of identifying instance +# x,y,w,h : bounding box +# focus : should focus lines be drawn around this object? +# alts : a list of button labels making up the radio button object +########################################################################## +record radio_button_obj(v, proc, id, x, y, w, h, focus, alts) + +########################################################################## +# create_radio_button() creates a radio button instance and draws the +# button if it is a first class object. +########################################################################## +procedure create_radio_button(x, y, alts) + local r, id + + id := next_id("radio_button") + r := radio_button_obj(, "radio_button_cb" || id, "radio_button" || id, + x, y, 0, 0, 0, alts) + r.v := Vradio_buttons(ROOT, x, y, APPWIN, alts, , id, V_DIAMOND_NO) + r.w := r.v.aw + r.h := r.v.ah + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# update_radio_bb() disallows resizing of a radio button object. +########################################################################## +procedure update_radio_bb(object) + object.w := object.v.aw + object.h := object.v.ah +end + +########################################################################## +# draw_radio_button() draws the given radio button object. +########################################################################## +procedure draw_radio_button(r) + VDraw(r.v) + return r +end + +########################################################################## +# load_radio_button() restores a radio button object from session code. +########################################################################## +procedure load_radio_button(r, o) + r.alts := o.etc + r.v := Vradio_buttons(ROOT, r.x, r.y, APPWIN, r.alts, , r.id, V_DIAMOND_NO) + r.w := r.v.aw + r.h := r.v.ah + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# save_radio_button() augments the record for saving a radio_button object. +########################################################################## +procedure save_radio_button(r, o) + r.typ := "Choice" + r.num := *o.alts + r.etc := copy(o.alts) + return +end + +########################################################################## +# radio_button_atts() defines the attribute sheet template for a radio +# button object. +########################################################################## +procedure radio_button_atts() + local tempy + + RADIO_TALK := Vdialog(&window, PAD, PAD) + tempy := 0 + VRegister(RADIO_TALK, + Vtext(&window, "ID: ",, 1, TEXTCHARS, IDMASK), 0, tempy) + tempy +:= PAD + VRegister(RADIO_TALK, + Vtext(&window, "callback: ",, 3, TEXTCHARS, CBMASK), 0, tempy) + tempy +:= (3 * PAD)/2 + VRegister(RADIO_TALK, Vtext(&window, " x: ",, 4, 3, &digits), 0, tempy) + tempy +:= PAD + VRegister(RADIO_TALK, Vtext(&window, " y: ",, 5, 3, &digits), 0, tempy) + VFormat(RADIO_TALK) + RB_starty := tempy +end + +########################################################################## +# display_radio_button_atts() displays the attribute sheet with the current +# attributes for the given radio button instance. +########################################################################## +procedure display_radio_button_atts(object) + local tempy, i, send_data, data, new, v, ok, nok, reg_list, ins_list, l + initial radio_button_atts() + + new := copy(object) + new.y -:= CANVASY + new.alts := copy(object.alts) + + repeat { + reg_list := [] + ins_list := [] + tempy := RB_starty + + # construct text fields and "add" and "del" buttons + every i := 0 to *new.alts do { + tempy +:= PAD + v := Vbutton(&window, "add", radio_cb, V_OK, , 28, 17) + VInsert(RADIO_TALK, v, 0, tempy + PAD / 2) + put(ins_list, v) + if i = 0 then + next + v := Vbutton(&window, "del", radio_cb, V_OK, , 28, 17) + VInsert(RADIO_TALK, v, 35 + TEXTWIDTH, tempy + 1) + put(ins_list, v) + v := Vtext(&window, "", , 5 + i, TEXTCHARS, LBMASK) + VRegister(RADIO_TALK, v, 35, tempy) + put(reg_list, v) + } + + # add "Okay" and "Cancel" + tempy +:= 2 * PAD + ok := Vbutton(&window, "Okay", , V_OK, , 50, 30) + nok := Vbutton(&window, "Cancel", , V_CANCEL, , 50, 30) + VInsert(RADIO_TALK, ok, TEXTWIDTH / 2 - 30, tempy) + VInsert(RADIO_TALK, nok, TEXTWIDTH / 2 + 40, tempy) + put(ins_list, ok, nok) + + # post the dialog + RADIO_VIDGET := &null + VFormat(RADIO_TALK) + send_data := [new.id, new.proc, new.x, new.y] ||| new.alts + data := VOpenDialog(RADIO_TALK, , "radio_dialog", send_data, "Okay") + every VUnregister(RADIO_TALK, !reg_list) + every VRemove(RADIO_TALK, !ins_list, 1) + + if data === send_data then + fail # cancelled + + # save new values + new.id := strip(get(data)) + new.proc := strip(get(data)) + new.x := get(data) + new.y := get(data) + every !new.alts := get(data) + + # if "add" or "del" was pressed, process it and loop to re-post dialog + if \RADIO_VIDGET then { + l := [] + every v := reg_list[1 to *new.alts] do { + if v.ay - PAD < RADIO_VIDGET.ay-1 < v.ay then + put(l, "") + if v.ay ~= RADIO_VIDGET.ay-1 then + put(l, v.data) + } + if RADIO_VIDGET.ay-1 > reg_list[*new.alts].ay | *l = 0 then + put(l, "") + new.alts := l + next + } + + # check for legal field values + if illegal(new.id, "ID", "s") | + illegal(new.proc, "Callback", "p") | + illegal(new.x, "X", "i") | + illegal(new.y, "Y", "i") + then + next + + # everything is valid + object.proc := new.proc + object.id := new.id + object.alts := new.alts + + unfocus_object(object) + EraseArea(object.x, object.y, object.w, object.h) + + object.v := Vradio_buttons(ROOT, + object.x, object.y, APPWIN, new.alts, , object.v.id, V_DIAMOND_NO) + object.w := object.v.aw + object.h := object.v.ah + VRemove(ROOT, object.v, 1) + + move_object(object, new.x, new.y + CANVASY, object.w, object.h) + focus_object(object) + break + } +end + +########################################################################## +# radio_cb is called when an "add" or "del" button is pressed. +########################################################################## +procedure radio_cb(v) + RADIO_VIDGET := v +end diff --git a/ipl/gpacks/vib/vibrect.icn b/ipl/gpacks/vib/vibrect.icn new file mode 100644 index 0000000..5d98757 --- /dev/null +++ b/ipl/gpacks/vib/vibrect.icn @@ -0,0 +1,135 @@ +############################################################################ +# +# vibrect.icn -- procedures for defining an area object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" + +########################################################################## +# rect_obj: +# v : vidget used for drawing rectangle +# proc : name of user callback procedure +# id : unique means of identifying a rectangle instance +# x,y,w,h : bounding box +# style : invisible, sunken, grooved, raised +# focus : should focus lines be drawn around this object? +########################################################################## +record rect_obj(v, proc, id, x, y, w, h, style, focus) + +########################################################################## +# create_rect() creates a rect instance and draws the rect if +# it is a first class object. +########################################################################## +procedure create_rect(x, y, w, h, style) + local r, id + + id := next_id("region") + r := rect_obj(, "region_cb" || id, "region" || id, x, y, w, h, style, 0) + r.v := Vpane(ROOT, x, y, APPWIN, , id, style, w, h) + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# draw_rect() draws the given rect instance. +########################################################################## +procedure draw_rect(r) + if r.style == "invisible" then { + WAttrib(APPWIN, "linestyle=dashed") + DrawRectangle(APPWIN, r.x, r.y, r.w - 1, r.h - 1) + WAttrib(APPWIN, "linestyle=solid") + } + else + VDraw(r.v) + return r +end + +########################################################################## +# load_rect() restores a rect object from session code. +########################################################################## +procedure load_rect(r, o) + if o.sty ~== "" then + r.style := o.sty + else if integer(o.num) > 0 then + r.style := "grooved" + else + r.style := "invisible" + r.v := Vpane(ROOT, r.x, r.y, APPWIN, , r.id, r.style, r.w, r.h) + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# save_rect() augments the record for saving a rect object. +########################################################################## +procedure save_rect(r, o) + r.typ := "Rect" + r.sty := o.style + return +end + +########################################################################## +# display_rect_atts() displays the attribute sheet with the current +# attributes for the given rect instance. +########################################################################## +procedure display_rect_atts(object) + local t + + t := table() + t["_style"] := object.style + t["a_id"] := object.id + t["b_callback"] := object.proc + t["c_x"] := object.x + t["d_y"] := object.y - CANVASY + t["e_width"] := object.w + t["f_height"] := object.h + + repeat { + if rect_dialog(t) == "Cancel" then + fail + + if illegal(t["a_id"], "ID", "s") | + illegal(t["b_callback"], "Callback", "p") | + illegal(t["c_x"], "X", "i") | + illegal(t["d_y"], "Y", "i") | + illegal(t["e_width"], "Width", MIN_W) | + illegal(t["f_height"], "Height", MIN_H) + then + next + + object.v.style := object.style := t["_style"] + object.id := t["a_id"] + object.proc := t["b_callback"] + unfocus_object(object) + move_object(object, + t["c_x"], t["d_y"] + CANVASY, t["e_width"], t["f_height"]) + focus_object(object) + break + } +end + + + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure rect_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["rect_dialog:Sizer::1:0,0,388,216:",], + ["_cancel:Button:regular::216,167,50,30:Cancel",], + ["_okay:Button:regular:-1:146,167,50,30:Okay",], + ["_style:Choice::4:281,62,92,84:",, + ["invisible","sunken","grooved","raised"]], + ["a_id:Text::40:13,14,360,19:ID: \\=",], + ["b_callback:Text::40:13,35,360,19:callback: \\=",], + ["c_x:Text::3:13,62,101,19: x: \\=",], + ["d_y:Text::3:13,88,101,19: y: \\=",], + ["e_width:Text::3:132,62,101,19: width: \\=",], + ["f_height:Text::3:132,88,101,19: height: \\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/vibsizer.icn b/ipl/gpacks/vib/vibsizer.icn new file mode 100644 index 0000000..dcee0ac --- /dev/null +++ b/ipl/gpacks/vib/vibsizer.icn @@ -0,0 +1,197 @@ +############################################################################ +# +# vibsizer.icn -- procedures for defining a sizer object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" + +########################################################################## +# sizer_obj: +# x,y,w,h : bounding box +# label : window label +# id : procedure id (only significant when used as dialog) +# dlog : is this a dialog box instead of a main window? +# proc : name of user callback procedure (unused) +# focus : should focus lines be drawn around this object? (not used) +# compose : is the object part of another? (not used) +########################################################################## +record sizer_obj(x, y, w, h, label, id, dlog, proc, focus, compose) + +########################################################################## +# create_sizer() creates a sizer instance. +########################################################################## +procedure create_sizer() + local x, y, r + + x := 600 - SZDIM + y := 400 - SZDIM + 65 + x >:= WAttrib("width") - SZDIM - 10 + y >:= WAttrib("height") - SZDIM - 10 + r := sizer_obj(x, y, SZDIM, SZDIM, "") + return r +end + +########################################################################## +# move_sizer() erases the sizer, updates its location, and redraws. +########################################################################## +procedure move_sizer(r, newx, newy) + erase_sizer(r) + newx <:= 0 + newx >:= WAttrib("width") - 11 + newy <:= CANVASY + newy >:= WAttrib("height") - 11 + r.x := newx + r.y := newy + draw_sizer(r) + DIRTY := 1 +end + +############################################################################ +# drag_sizer() resizes the application window by dragging the sizer. +############################################################################ +procedure drag_sizer() + local x, y + + unfocus_object(\FOCUS) + x := &x + y := &y + DrawRectangle(XORWIN, 0, CANVASY, x, y - CANVASY) + repeat case Event() of { + &ldrag: { + DrawRectangle(XORWIN, 0, CANVASY, x, y - CANVASY) + x := &x + y := &y + x <:= SZDIM + y <:= SZDIM + DrawRectangle(XORWIN, 0, CANVASY, x, y - CANVASY) + } + &lrelease: { + DrawRectangle(XORWIN, 0, CANVASY, x, y - CANVASY) + move_sizer(SIZER, x - SZDIM, y - SZDIM) + draw_canvas() + return + } + } +end + +########################################################################## +# draw_sizer() draws the given sizer object. +########################################################################## +procedure draw_sizer(r) + DrawLine(APPWIN, 0, r.y+SZDIM, r.x+SZDIM, r.y+SZDIM, r.x+SZDIM, CANVASY) + BevelRectangle(APPWIN, r.x, r.y, SZDIM, SZDIM, -2) + return r +end + +########################################################################## +# erase_sizer() erases the given sizer object. +########################################################################## +procedure erase_sizer(r) + EraseArea(APPWIN, r.x, r.y, SZDIM + 1, SZDIM + 1, + 0, r.y + SZDIM, r.x, 1, r.x + SZDIM, CANVASY, 1, r.y) + return r +end + +########################################################################## +# load_sizer() restores the sizer object from session code. +########################################################################## +procedure load_sizer(r, o) + local winw, winh + + winw := WAttrib("width") + winh := WAttrib("height") + pop(O_LIST) # remove sizer from object list + r.label := o.lbl + r.x := r.x + r.w - SZDIM + r.y := r.y + r.h - SZDIM + r.w := r.h := SZDIM + r.dlog := ("" ~== o.num) + erase_sizer(SIZER) + if (r.x + r.w + 11 > winw) | (r.y + r.h + 11 > winh) then { + winw <:= r.x + r.w + 11 + winh <:= r.y + r.h + 11 + WAttrib("width=" || (ROOT.aw := winw), "height=" || (ROOT.ah := winh)) + draw_decor() + } + SIZER := r +end + +########################################################################## +# save_sizer() augments the record for saving the sizer object. +########################################################################## +procedure save_sizer(r, o) + r.typ := "Sizer" + r.lbl := o.label + r.w := r.x + r.w + r.h := r.y + r.h + r.x := r.y := 0 + r.num := o.dlog + return +end + +########################################################################## +# display_sizer_atts() displays the attribute sheet with the current +# attributes for the given sizer instance. +# This amounts to the window dimensions ... +########################################################################## +procedure display_sizer_atts(object) + local t + + t := table() + t["a_name"] := object.id + t["b_label"] := object.label + t["c_width"] := object.x + object.w + t["d_height"] := object.y + object.h - CANVASY + t["_dialog"] := object.dlog + + repeat { + if sizer_dialog(t) == "Cancel" then + fail + + if illegal(t["a_name"], "Procedure name", "p") | + illegal(t["b_label"], "Label", "l") | + illegal(t["c_width"], "Width", SZDIM) | + illegal(t["d_height"], "Height", SZDIM) + then + next + + if t["c_width"] >= WAttrib("width") | + t["d_height"] >= WAttrib("height") then { + Notice("The VIB window is not large enough", + "to model a canvas of that size.") + next + } + + erase_sizer(object) + object.id := t["a_name"] + object.label := t["b_label"] + object.x := t["c_width"] - object.w + object.y := t["d_height"] - object.h + CANVASY + object.dlog := t["_dialog"] + draw_sizer(object) + DIRTY := 1 + break + } +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure sizer_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["sizer_dialog:Sizer::1:0,0,500,180:",], + ["_cancel:Button:regular::265,125,50,30:Cancel",], + ["_dialog:Button:check:1:278,77,118,20:dialog window",], + ["_okay:Button:regular:-1:185,125,50,30:Okay",], + ["a_name:Text::40:13,14,402,19:procedure name: \\=",], + ["b_label:Text::50:13,35,472,19:window label: \\=",], + ["c_width:Text::3:13,60,143,19: width: \\=",], + ["d_height:Text::3:13,81,143,19: height: \\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/vibslidr.icn b/ipl/gpacks/vib/vibslidr.icn new file mode 100644 index 0000000..a7fca9e --- /dev/null +++ b/ipl/gpacks/vib/vibslidr.icn @@ -0,0 +1,207 @@ +############################################################################ +# +# vibslidr.icn -- procedures for defining slider and scrollbar objects +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" +$include "vdefns.icn" + +########################################################################## +# slider_obj: +# v : vidget used for drawing +# proc : name of user callback procedure +# filter : filter out dragging events? +# id : unique identifier +# x,y,w,h : bounding box +# min : min value of range +# max : max value of range +# value : current value within range +# typ : "Slider" or "Scrollbar" +# focus : should focus lines be drawn around this object? +########################################################################## +record slider_obj(v, proc, filter, id, x, y, w, h, min, max, value, typ, focus) + +########################################################################## +# create_slider() creates a slider instance and draws the slider. +########################################################################## +procedure create_slider(x, y, w, h, typ, min, max, value, filter) + local r, id, prefix + + if typ == "Scrollbar" then + prefix := "sbar" + else + prefix := "slider" + id := next_id(prefix) + + r := slider_obj(, prefix || "_cb" || id, filter, prefix || id, + x, y, w, h, min, max, value, typ, 0) + + r.v := slider_vidget(id, typ, x, y, w, h) + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# slider_vidget() creates the appropriate vidget for a slider or scrollbar. +########################################################################## +procedure slider_vidget(id, typ, x, y, w, h) + local dir + + dir := if w > h then "h" else "v" + return case dir || typ of { + "vSlider": Vvert_slider(ROOT, x, y, APPWIN, , id, h, w, 1.0, 0.0) + "hSlider": Vhoriz_slider(ROOT, x, y, APPWIN, , id, w, h) + "vScrollbar": Vvert_scrollbar(ROOT, x, y, APPWIN, , id, h, w, 1.0, 0.0) + "hScrollbar": Vhoriz_scrollbar(ROOT, x, y, APPWIN, , id, w, h) + } +end + +########################################################################## +# update_slider_bb() updates attributes in response to resizing. +########################################################################## +procedure update_slider_bb(object) + if object.w > object.h then { + object.w <:= VSlider_MinAspect * VSlider_MinWidth + object.h >:= object.w / VSlider_MinAspect + } + else { + object.h <:= VSlider_MinAspect * VSlider_MinWidth + object.w >:= object.h / VSlider_MinAspect + } +end + +########################################################################## +# draw_slider() draws the given slider object. +########################################################################## +procedure draw_slider(r) + VSetState(r.v, abs((r.value - r.min) / (real(r.max - r.min)))) + VDraw(r.v) + return r +end + +########################################################################## +# load_slider() restores a slider object from session code. +########################################################################## +procedure load_slider(r, o) + local dir + + r.filter := ("" ~== o.num) + r.typ := o.typ + o.lbl ? { + r.min := tab(upto(",")); move(1) + r.max := tab(upto(",")); move(1) + r.value := tab(0) + } + + r.v := slider_vidget(r.id, r.typ, r.x, r.y, r.w, r.h) + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# save_slider() augments the record for saving a slider object. +########################################################################## +procedure save_slider(r, o) + r.typ := o.typ + r.lbl := o.min || "," || o.max || "," || o.value + r.sty := if r.w > r.h then "h" else "v" + r.num := o.filter + return +end + +########################################################################## +# display_slider_atts() displays the attribute sheet with the current +# attributes for the given slider instance. +########################################################################## +procedure display_slider_atts(object) + local t, s + + t := table() + t["_filter"] := object.filter + t["a_id"] := object.id + t["b_callback"] := object.proc + t["c_x"] := object.x + t["d_y"] := object.y - CANVASY + t["g_lefttop"] := object.min + t["h_initial"] := object.value + t["i_rightbot"] := object.max + + if object.w > object.h then { + t["j_orientation"] := "horizontal" + t["e_length"] := object.w + t["f_width"] := object.h + } + else { + t["j_orientation"] := "vertical" + t["e_length"] := object.h + t["f_width"] := object.w + } + + repeat { + s := slider_dialog(t) + if s == "Cancel" then + fail + + if illegal(t["a_id"], "ID", "s") | + illegal(t["b_callback"], "Callback", "p") | + illegal(t["c_x"], "X", "i") | + illegal(t["d_y"], "Y", "i") | + illegal(t["f_width"], "Width", VSlider_MinWidth) | + illegal(t["e_length"], "Length", t["f_width"] * VSlider_MinAspect) | + illegal(t["g_lefttop"], "Left / Top", "n") | + illegal(t["h_initial"], "Initial", "n") | + illegal(t["i_rightbot"], "Right / Bottom", "n") + then + next + + if not ((t["g_lefttop"] <= t["h_initial"] <= t["i_rightbot"]) | + (t["g_lefttop"] >= t["h_initial"] >= t["i_rightbot"])) then { + Notice("Initial value is not between the two extremes") + next + } + + object.filter := t["_filter"] + object.id := t["a_id"] + object.proc := t["b_callback"] + object.min := t["g_lefttop"] + object.value := t["h_initial"] + object.max := t["i_rightbot"] + unfocus_object(object) + if t["j_orientation"] == "horizontal" then + move_object(object, + t["c_x"], t["d_y"] + CANVASY, t["e_length"], t["f_width"]) + else + move_object(object, + t["c_x"], t["d_y"] + CANVASY, t["f_width"], t["e_length"]) + focus_object(object) + break + } +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure slider_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["slider_dialog:Sizer::1:0,0,389,276:",], + ["_cancel:Button:regular::204,225,50,30:Cancel",], + ["_filter:Button:checkno:1:270,132,69,20:filter",], + ["_okay:Button:regular:-1:139,224,50,30:Okay",], + ["a_id:Text::40:13,14,360,19:ID: \\=",], + ["b_callback:Text::40:13,35,360,19:callback: \\=",], + ["c_x:Text::3:13,62,101,19: x: \\=",], + ["d_y:Text::3:13,83,101,19: y: \\=",], + ["e_length:Text::3:13,109,101,19: length: \\=",], + ["f_width:Text::3:13,130,101,19: width: \\=",], + ["g_lefttop:Text::10:181,62,192,19: top / left: \\=",], + ["h_initial:Text::10:181,83,192,19: initial: \\=",], + ["i_rightbot:Text::10:181,104,192,19:bottom / right: \\=",], + ["j_orientation:Choice::2:15,156,99,42:",, + ["vertical","horizontal"]], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/vib/vibtalk.icn b/ipl/gpacks/vib/vibtalk.icn new file mode 100644 index 0000000..1ffa2d4 --- /dev/null +++ b/ipl/gpacks/vib/vibtalk.icn @@ -0,0 +1,193 @@ +############################################################################ +# +# vibtalk.icn -- procedures involving dialogue windows +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vibdefn.icn" + +global ADD_TALK, DEL_TALK + +########################################################################## +# dialogue() defines pop-up window templates for the various kinds +# of pop-up windows utilized within VIB. +########################################################################## +procedure dialogue() + local tempx, tempy, howmany, where + + ADD_TALK := Vdialog(&window, PAD, PAD) + howmany := Vtext(&window, "Insert ", , 1, 2, &digits) + where := Vtext(&window, "item(s) after item ", , 2, 2, &digits) + tempy := 0 + tempx := 0 + VRegister(ADD_TALK, howmany, tempx, tempy) + tempx +:= howmany.aw + 8 + VRegister(ADD_TALK, where, tempx, tempy) + tempy +:= (3 * PAD)/2 + VInsert(ADD_TALK, Vbutton(&window, "Okay", , V_OK, , 80, 20), 20, tempy) + VInsert(ADD_TALK, Vbutton(&window, "Cancel", , V_CANCEL, , 80, 20),120,tempy) + VFormat(ADD_TALK) + + DEL_TALK := Vdialog(&window, PAD, PAD) + howmany := Vtext(&window, "delete item(s) ", , 1, 2, &digits) + where := Vtext(&window, "thru ", , 2, 2, &digits) + tempy := 0 + tempx := 0 + VRegister(DEL_TALK, howmany, tempx, tempy) + tempx +:= howmany.aw + 8 + VRegister(DEL_TALK, where, tempx, tempy) + tempy +:= (3 * PAD)/2 + VInsert(DEL_TALK, Vbutton(&window, "Okay", , V_OK, , 80, 20), 20, tempy) + VInsert(DEL_TALK, Vbutton(&window, "Cancel", , V_CANCEL, , 80, 20),120,tempy) + VFormat(DEL_TALK) +end + +########################################################################## +# open_session() asks for a file name and opens it as the current session. +########################################################################## +procedure open_session() + local fname + + repeat { + case OpenDialog("file to open: ") of { + "Okay": { + fname := def_extn(dialog_value) + if load_session(fname) then { + SESSION := fname + label_session() + return + } + Notice("Cannot open file " || fname) + } + "Cancel": + fail + } + } + return +end + +########################################################################## +# flush_session() asks whether the current session should be saved first. +# It fails if cancelled. +########################################################################## +procedure flush_session() + + if /DIRTY then + return # nothing needs saving + + return vib_save_as("save session first? ", SESSION) # fails if cancelled +end + +########################################################################## +# vib_save_as() asks for a file name and saves the session. +########################################################################## +procedure vib_save_as(prompt, def) + local fname + + repeat { + case SaveDialog(prompt, def) of { + "Yes": { + fname := def_extn(dialog_value) + if close(open(fname)) & not ok_overwrite(fname) then + next + if save_session(fname) then { + SESSION := fname + label_session() + return + } + } + "No": return + "Cancel": fail + } + } +end + +########################################################################## +# def_extn(fname) adds a ".icn" extension to a file name, if appropriate. +########################################################################## +procedure def_extn(fname) + + if not upto('.', fname) then + fname ||:= ".icn" + return fname +end + +########################################################################## +# ok_overwrite() is called to display a dialogue window for confirming +# the over-writing of a file. It is assumed that it +# is always okay to overwrite the current session. +########################################################################## +procedure ok_overwrite(fname) + if fname == SESSION then + return + + return "Okay" == Dialog( + "File " || fname || " exists. Overwrite?", , , , ["Okay", "Cancel"]) +end + +########################################################################## +# label_session() sets the window and icon labels. +########################################################################## +procedure label_session() + WAttrib("label=" || SESSION, "iconlabel=" || SESSION) +end + +########################################################################## +# illegal() posts a notice and succeeds if a value is illegal. +# +# val is the value to test. +# label is its label. +# how is how to test: +# "p" procedure name, or empty +# "s" general VIB string -- no : \ " +# "l" label string -- can include : +# "n" any numeric value +# "i" any integer value +# <min> any integer of at least <min> +########################################################################## +procedure illegal(val, label, how) + local m, s + + if case how of { + "p": { m := CBMASK; s := "must be a valid identifier" } + "s": { m := IDMASK; s := "cannot contain `\\' or `\"' or `:'" } + "l": { m := LBMASK; s := "cannot contain `\\' or `\"'" } + } + then val ? { + tab(many(m)) + if not pos(0) | (how == "p" & any(&digits, val)) then { + Notice(label || " value " || s) + return + } + else fail + } + + if *val == 0 then { + Notice(label || " value must be specified") + return + } + + if how === "n" then { + if not numeric(val) then { + Notice(label || " value must be numeric") + return + } + else fail + } + + if not integer(val) then { + Notice(label || " value must be an integer") + return + } + + if val < integer(how) then { + Notice(label || " value must not be less than " || how) + return + } + + fail # that is, the value is legal +end diff --git a/ipl/gpacks/vib/vibtext.icn b/ipl/gpacks/vib/vibtext.icn new file mode 100644 index 0000000..bdcfb9b --- /dev/null +++ b/ipl/gpacks/vib/vibtext.icn @@ -0,0 +1,163 @@ +############################################################################ +# +# vibtext.icn -- procedures for defining a text object +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ + +$include "vdefns.icn" +$include "vibdefn.icn" + +########################################################################## +# text_input_obj: +# v : vidget used for drawing text input object +# proc : name of user callback procedure +# id : unique means of identifying instance +# x,y,w,h : bounding box +# label : label of text input object +# value : (editable) value of text input object +# length : max number of chars that value can hold +# focus : should focus lines be drawn around this object? +########################################################################## +record text_input_obj(v, proc, id, x, y, w, h, label, value, length, focus) + +########################################################################## +# create_text_input() creates a text instance and draws the text object if +# it is a first class object. +########################################################################## +procedure create_text_input(x, y, label, value, length) + local r, id + + id := next_id("text_input") + r := text_input_obj(, "text_input_cb" || id, "text_input" || id, + x, y, 0, 0, label, value, length, 0) + r.v := Vtext(ROOT, x, y, APPWIN, label || "\\=" || value, , id, length) + r.w := r.v.aw + r.h := r.v.ah + VRemove(ROOT, r.v, 1) + return r +end + +########################################################################## +# draw_text_input() draws the given text object. +########################################################################## +procedure draw_text_input(r) + r.length := r.v.MaxChars +:= (r.w - r.v.aw) / VFWidth + VResize(r.v) + VDraw(r.v) + return r +end + +########################################################################## +# update_text_input_bb() makes resizing work a character at a time. +########################################################################## +procedure update_text_input_bb(object) + local wxv, n + + wxv := object.v.aw - VFWidth * object.v.MaxChars # width excluding value + n := (object.w - wxv) / VFWidth # num chars for value + n <:= 1 + n <:= *object.value + object.w := wxv + VFWidth * n # force width to char boundary + object.h := object.v.ah # disallow height change +end + +########################################################################## +# load_text_input() restores a text object from session code. +########################################################################## +procedure load_text_input(r, o) + o.lbl ? { + r.label := tab(find("\\\\=")) + move(3) + r.value := tab(0) + } + r.length := o.num + r.v := Vtext(ROOT, r.x,r.y, APPWIN, r.label||"\\="||r.value,, r.id, r.length) + r.w := r.v.aw + r.h := r.v.ah + VRemove(ROOT, r.v, 1) +end + +########################################################################## +# save_text_input() augments the record for saving a text_input object. +########################################################################## +procedure save_text_input(r, o) + r.typ := "Text" + r.lbl := image(o.label)[2:-1] || "\\\\=" || image(o.value)[2:-1] + r.num := o.length + return +end + +########################################################################## +# display_text_input_atts() displays the attribute sheet with the current +# attributes for the given text instance. +########################################################################## +procedure display_text_input_atts(object) + local t + + t := table() + t["a_id"] := object.id + t["b_callback"] := object.proc + t["c_x"] := object.x + t["d_y"] := object.y - CANVASY + t["e_label"] := object.label + t["f_value"] := object.value + t["g_length"] := object.length + + repeat { + if text_dialog(t) == "Cancel" then + fail + + if illegal(t["a_id"], "ID", "s") | + illegal(t["b_callback"], "Callback", "p") | + illegal(t["c_x"], "X", "i") | + illegal(t["d_y"], "Y", "i") | + illegal(t["e_label"], "Label", "l") | + illegal(t["f_value"], "Value", "l") | + illegal(t["g_length"], "Length", 1) | + illegal(t["g_length"], "Length", *t["f_value"]) + then + next + + object.id := t["a_id"] + object.proc := t["b_callback"] + object.label := t["e_label"] + object.value := t["f_value"] + object.length := t["g_length"] + + unfocus_object(object) + EraseArea(object.x, object.y, object.w, object.h) + + object.v.MaxChars := object.length + object.v.s := object.label + VSetState(object.v, object.value) + VResize(object.v) + object.w := object.v.aw + + move_object(object, t["c_x"], t["d_y"] + CANVASY) + focus_object(object) + break + } +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure text_dialog(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["text_dialog:Sizer::1:0,0,460,230:",], + ["_cancel:Button:regular::250,180,50,30:Cancel",], + ["_okay:Button:regular:-1:180,180,50,30:Okay",], + ["a_id:Text::40:13,14,360,19:ID: \\=",], + ["b_callback:Text::40:13,35,360,19:callback: \\=",], + ["c_x:Text::3:13,62,101,19: x: \\=",], + ["d_y:Text::3:13,83,101,19: y: \\=",], + ["e_label:Text::50:13,109,430,19: label: \\=",], + ["f_value:Text::50:13,130,430,19: value: \\=",], + ["g_length:Text::3:258,83,185,19:maximum value length: \\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/Makefile b/ipl/gpacks/weaving/Makefile new file mode 100644 index 0000000..e415e99 --- /dev/null +++ b/ipl/gpacks/weaving/Makefile @@ -0,0 +1,30 @@ +# The programs listed in this Makefile (there are more in the +# directory) are those that are not labeled AD HOC that have +# been verified to build cleanly. + + +PROCS = cells.u2 tdialog.u2 tieutils.u2 tpath.u2 \ + weavegif.u2 weavutil.u2 wifcvt.u2 + +PROGS = comb draw2gmr drawdown drawup gif2geom gif2html heddle lindpath \ + mtrxedit pfd2gif pfd2gmr pfd2ill pfd2wif plexity randweav \ + seqdraft shadow shadpapr showrav tieimage unravel wallpapr weaver wif2pfd + + +IC = icont +IFLAGS = -us + +.SUFFIXES: .icn .u2 +.icn.u2: ; $(IC) $(IFLAGS) -c $< +.icn: ; $(IC) $(IFLAGS) $< + + +all: $(PROGS) + +$(PROGS): $(PROCS) + +Iexe: $(PROGS) + cp $(PROGS) ../../iexe/ + +clean Clean: + rm -f $(PROGS) *.u? diff --git a/ipl/gpacks/weaving/README b/ipl/gpacks/weaving/README new file mode 100644 index 0000000..f5acba7 --- /dev/null +++ b/ipl/gpacks/weaving/README @@ -0,0 +1,4 @@ +This package contains programs related to weaving, and goes +along with the articles in the Icon Analyst on the subject. + +The files here mostly are works in progress. diff --git a/ipl/gpacks/weaving/awl.icn b/ipl/gpacks/weaving/awl.icn new file mode 100644 index 0000000..9244dee --- /dev/null +++ b/ipl/gpacks/weaving/awl.icn @@ -0,0 +1,556 @@ +############################################################################ +# +# File: awl.icn +# +# Subject: Program to create weaving patterns +# +# Author: Ralph E. Griswold +# +# Date: May 4, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC: UNDER DEVELOPEMENT. For now, awl stands for A Weaving Language. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: cells, random, strings, tables, vsetup, weaving, weavrecs, +# xcode +# +############################################################################ + +link cells +link random +link strings +link tables +link vsetup +link weaving +link weavrecs +link xcode + +invocable all + +global symbols +global current_object +global db_file +global object_tbl +global names_list +global null +global objects +global objects_list +global touched +global vidgets + +procedure main() + local root + + vidgets := ui() + + root := vidgets["root"] + + objects := vidgets["obj_list"] + + null := sequence("null", "") + object_tbl := table() + object_tbl["null"] := null + current_object := "null" + + VSetItems(objects, keylist(object_tbl)) + + update() + + symbols := "12345678" + + GetEvents(root, , shortcuts) + +end + +procedure alphabet() + + repeat { + if TextDialog("Alphabet:", , symbols) == "Cancel" then fail + if *cset(dialog_value[1]) ~= *dialog_value[1] then { + Notice("Duplicate symbols not allowd.") + next + } + if *dialog_value = 0 then { + Notice("Empty alphabet not allowed.") + next + } + symbols := dialog_value[1] + return + } + +end + +procedure showcell(cell) + + write(&errout, "n=", cell.n, " m=", cell.m, " color=", cell.color) + + return + +end + +procedure Eval(name) + local i, fnc, args, object + static ftable + + initial { + ftable := table() # mapping from record type to function + ftable["block"] := Block + ftable["concatenation"] := Concatenate + ftable["extension"] := Extend + ftable["interleaving"] := Interleave + ftable["palindroid"] := Palindroid + ftable["palindrome"] := Palindrome + ftable["pbox"] := Pbox + ftable["permutation"] := Permutation + ftable["repetition"] := Repeat + ftable["reversal"] := Reverse + ftable["rotation"] := Rotate + ftable["sequence"] := string + ftable["template"] := Template + } + + if &level > 100 then { + Notice("Recursion limit exceeded.") # ad-hoc escape + fail + } + + object := \object_tbl[name] | return name + + fnc := \ftable[type(object)] | { + Notice("Unsupported type: " || fnc || ".") + fail + } + + args := [] + + every i := 2 to *object do # skip name field + put(args, Eval(object[i])) | { + Notice("Eval() failed for " || type(object) || "[" || i || "].") + fail + } + + return (fnc ! args) + +end + +procedure create_cb(vidget, value) + local args, object + + args := case value of { + "block" : object_pp("Create block:") + "concatenation" : object_pp("Create concatenation:") + "extension" : object_pn("Create extension:") + "interleaving" : object_pp("Create interleaving:") + "palindroid" : object_pp("Create palindroid:") + "pbox" : object_pp("Create pbox:") + "permutation" : object_pp("Create permutation:") + "repetition" : object_pn("Create sequence:") + "reversal" : object_p("Create reversal") + "rotation" : object_pn("Create rotation:") + "sequence" : create_sequence() + "template" : object_pp("Create permutation:") + } | fail + + object := (value ! args) + current_object := object.name + object_tbl[current_object] := object + + VSetItems(objects, keylist(object_tbl)) + + update() + + display_object(current_object) + + return + +end + +procedure object_pp(caption) + local name, object1, object2 + static number + + repeat { + if TextDialog(caption, ["name", "object 1", "object 2"], + [name, object1, object2], [10, 60, 60]) == "Cancel" then fail + name := dialog_value[1] + if *name = 0 then { + Notice("Invalid name.") + next + } + if \object_tbl[dialog_value[2]] then object1 := dialog_value[2] else { + Notice("Invalid object name.") + next + } + if \object_tbl[dialog_value[3]] then object2 := dialog_value[3] else { + Notice("Invalid object name.") + next + } + return dialog_value + } + +end + +procedure object_p(caption) + local name, object + + repeat { + if TextDialog(caption, ["name", "object"], + [name, object], [10, 60, 60]) == "Cancel" then fail + name := dialog_value[1] + if *name = 0 then { + Notice("Invalid name.") + next + } + if \object_tbl[dialog_value[2]] then object := dialog_value[2] else { + Notice("Invalid object name.") + next + } + return dialog_value + } + +end + +procedure object_pn(caption) + local name, object, number + + repeat { + if TextDialog(caption, ["name", "object", "number"], + [name, object, number], [10, 60, 10]) == "Cancel" then fail + name := dialog_value[1] + if *name = 0 then { + Notice("Empty name not allowed.") + next + } + if \object_tbl[dialog_value[2]] then object := dialog_value[2] else { + Notice("Invalid name.") + next + } + number := (0 < integer(dialog_value[3])) | { + Notice("Invalid number.") + next + } + return dialog_value + } + +end + +procedure create_sequence() + local name, value + + repeat { + if TextDialog("Create sequence:", ["name", "value"], [name, value] , [10, 60]) == + "Cancel" then fail + if *dialog_value[1] = 0 then { + Notice("object name cannot be empty.") + next + } + else name := dialog_value[1] + if *(cset(dialog_value[2]) -- symbols) > 0 then { + Notice("Symbol not in alphabet.") + next + } + return dialog_value + } + +end + +procedure file_cb(vidget, value) + + case value[1][1] of { + "save @Q" : save_db() + "open @O" : open_db() + "quit @Q" : exit() + } + + return + +end + +procedure parameters_cb(vidget, value) + + case value[1] of { + "alphabet @A" : alphabet() + } + + return + +end + +# Open database + +procedure open_db() + local input + + repeat{ + if OpenDialog("Open database:", db_file) == "Cancel" then fail + db_file := dialog_value + input := open(db_file) | { + Notice("Cannot open database file.") + next + } + object_tbl := xdecode(input) | { + Notice("Cannot decode database.") + close(input) + next + } + close(input) + object_tbl["null"] := sequence("null", "") + current_object := "null" + VSetItems(objects, keylist(object_tbl)) + return + } + +end + +# Save the current database. + +procedure save_db() + local output + + if /db_file then { + repeat{ + if OpenDialog("Save database:") == "Cancel" then fail + db_file := dialog_value + break + } + } + + output := open(db_file, "w") | { + Notice("Cannot write database file.") + fail + } + + xencode(object_tbl, output) + + close(output) + + touched := &null + + return + +end + +procedure libraries_cb(vidget, value) + + return + +end + +procedure obj_list_cb(vidget, value) + + if /value then return # deselection event + + if \object_tbl[value] then current_object := value else { + Notice("Internal error in object selection.") + fail + } + + update() + + display_object(current_object) + + return + +end + +procedure show_object(name) + local object, attlist + + object := object_tbl[\name] | { + Notice("No current object.") + fail + } + + attlist := [type(object)] + every put(attlist,"", image(!object)) + + Notice ! attlist + + return + +end + +procedure update() + static x, y, w, h + + initial { + x := vidgets["display"].ux + y := vidgets["display"].uy + w := vidgets["display"].uw + h := vidgets["display"].uh + } + + if /current_object then fail + + EraseArea(x, y, w, h) + + DrawString( + x, + y + h - 5, + current_object || ": " || type(object_tbl[current_object]) + ) + + return + +end + +procedure objects_cb(vidgets, value) + + case value[1] of { + "create @C" : create_cb() + "edit @E" : edit_object(current_object) + "information @I" : show_object(current_object) + "display @D" : display_object(current_object) + } + + return + +end + +procedure shortcuts(e) + + if &meta then case map(e) of { + "a" : alphabet() + "c" : create_cb() + "d" : display_object(current_object) + "e" : edit_object(current_object) + "i" : show_object(current_object) + "o" : open_db() + "q" : exit() + "s" : save_db() + } + + return + +end + +procedure edit_object(name) + + return + +end + +procedure display_object(name) + local s, panel, i, place, object + + s := Eval(name) | fail + + panel := makepanel(*s, 8, 6, , , "black") + + WAttrib(panel.window, "canvas=normal", "label=" || name) + + every i := 1 to *s do + colorcell(panel, i, s[i], "black") | { + WClose(panel.window) + Notice("Cannot color grid cell.") + fail + } + + repeat { + case TextDialog(, , , , ["Okay", "Create", "Edit"]) of { + "Okay" : { + WClose(panel.window) + return + } + "Edit" : { + repeat { + case Event(panel.window) of { + "q" : break next + &lpress : { + place := cell(panel, &x, &y) | { + Notice("Cell reporting failure.") + fail + } + # showcell(place) + if place.color == "0,0,0" then + colorcell(panel, place.n, place.m, "white") + else + colorcell(panel, place.n, place.m, "black") + } + } + } + } + "Create" : { + Notice("Creation from grid not yet supported.") + return + } + } + } + +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=600,401", "bg=pale gray"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,600,401:",], + ["create:Choice::13:13,82,120,273:",create_cb, + ["block","concatenation","extension","interleaving","palindroid", + "palindrome","pbox","permutation","repetition","reversal", + "rotation","sequence","template"]], + ["file:Menu:pull::1,0,36,21:File",file_cb, + ["save @S","open @O","quit @Q"]], + ["label1:Label:::28,60,91,13:create object",], + ["label_objects:Label:::406,34,49,13:Objects",], + ["libraries:Menu:pull::169,0,71,21:Libraries",libraries_cb, + ["one","two","three"]], + ["menu_bar:Line:::0,21,600,21:",], + ["obj_list:List:w::367,59,134,313:",obj_list_cb], + ["objects:Menu:pull::37,0,57,21:Objects",objects_cb, + ["create @C","edit @E","information @E","display @D"]], + ["parameters:Menu:pull::92,0,78,21:Parameters",parameters_cb, + ["alphabet @A"]], + ["display:Rect:invisible::15,32,346,16:",], + ) +end +#===<<vib:end>>=== end of section maintained by vib + +procedure test() + local p, s, panel, i, place + + randomize() + + p := palindroid(scramble("12345678")) + + every 1 to 2 do { + p := rotation(palindroid(p)) + } + + s := Eval(p) + + panel := makepanel(*s, 8, 10, , , "black") + + WAttrib(panel.window, "canvas=normal") + + every i := 1 to *s do + colorcell(panel, i, s[i], "black") + + repeat { + case Event(panel.window) of { + "q" : exit() + &lpress : { + place := cell(panel, &x, &y) + if place.color == "0,0,0" then + colorcell(panel, place.n, place.m, "white") + else + colorcell(panel, place.n, place.m, "black") + } + } + } + +end + diff --git a/ipl/gpacks/weaving/bibcvt.icn b/ipl/gpacks/weaving/bibcvt.icn new file mode 100644 index 0000000..621f244 --- /dev/null +++ b/ipl/gpacks/weaving/bibcvt.icn @@ -0,0 +1,46 @@ +############################################################################ +# +# File: bibcvt.icn +# +# Subject: Program to sanitize PageMaker tagged text +# +# Author: Ralph E. Griswold +# +# Date: March 4, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. For weaving bibliography. +# +############################################################################ + +procedure main() + local paragraph, line, tag + + paragraph := "" + + while line := trim(read()) do { + line ? { + ="<" | stop("no tag") + tag := tab(upto('>')) + if tag ~== "Body text" then stop("unknown tag: ", tag) + move(1) + tab(many(' ')) + if pos(0) then { + if *paragraph > 0 then { + write("<Body text>", trim(paragraph)) + paragraph := "" + write("<space>") + } + } + else paragraph ||:= tab(0) || " " + } + } + + if *paragraph > 0 then write("<Body text>", trim(paragraph)) + +end diff --git a/ipl/gpacks/weaving/cells.icn b/ipl/gpacks/weaving/cells.icn new file mode 100644 index 0000000..e546f89 --- /dev/null +++ b/ipl/gpacks/weaving/cells.icn @@ -0,0 +1,192 @@ +############################################################################ +# +# File: cells.icn +# +# Subject: Procedures for creating and coloring panels of cells +# +# Author: Ralph E. Griswold +# +# Date: May 26, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures create an manipulate panels of cells. +# +# makepanel(n, m, size, fg, bg, pg) +# makes a panel in a hidden window with nxm cells of the +# given size, default 10. fg, bg, and pg are the +# colors for the window and panel backgrounds. fg +# and bg default to black and white, respectively. +# If pg is not given a patterned background is used. +# +# matrixpanel(matrix, size, fg, bg, pg) +# same as makepanel(), except matrix determines the +# dimensions. +# +# clearpanel(panel) +# restores the panel to its original state as made +# makepanel. +# +# colorcell(panel, n, m, color) +# colors the cell (n,m) in panel with color. The +# size defaults to 10. +# +# colorcells(panel, tier) +# is like colorcells(), except it operates on a tie-up +# record. +# +# cell(panel, x, y) +# returns Cell() record for the cell in which x,y +# lies. If fails if the point is out of bounds. +# +# tiercells(panel, matrix) +# is like colorcell(), except all cells are colored +# using a matrix of colors. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: wopen +# +############################################################################ + +link wopen + +record Cell(n, m, color) +record Panel(window, n, m, size, fg, bg, pg) + +procedure makepanel(n, m, cellsize, fg, bg, pg) #: make panel of cells + local window, x, y, width, height, panel + + /fg := "black" + /bg := "white" + + /cellsize := 10 + + width := (n * cellsize + 1) + height := (m * cellsize + 1) + + window := WOpen("width=" || width, "height=" || height, + "fg=" || fg, "bg=" || bg, "canvas=hidden") | fail + + panel := Panel(window, n, m, cellsize, fg, bg, pg) + + clearpanel(panel) + + return panel + +end + +procedure clearpanel(panel) + local width, height, x, y + + if \panel.pg then { # default is textured + WAttrib(panel.window, "fillstyle=textured") + Pattern(panel.window, "checkers") + Bg(panel.window, "very dark gray") + } + else Fg(panel.window, panel.fg) + + width := WAttrib(panel.window, "width") + height := WAttrib(panel.window, "height") + + every x := 0 to width by panel.size do + DrawLine(panel.window, x, 0, x, height) + + every y := 0 to height by panel.size do + DrawLine(panel.window, 0, y, width, y) + + WAttrib(panel.window, "fillstyle=solid") + + return panel + +end + +procedure matrixpanel(matrix, cellsize, fg, bg, pg) + + return makepanel(*matrix[1], *matrix, cellsize, fg, bg) + +end + +procedure colorcell(panel, n, m, color) #: color cell in panel + local cellsize + + if not(integer(n) & integer(m)) then + stop("Non-integer value to colorcell(). n=", image(n), " m=", image(m)) + + cellsize := panel.size + + Fg(panel.window, color) + + FillRectangle(panel.window, (n - 1) * cellsize + 1, (m - 1) * cellsize + 1, + cellsize - 1, cellsize - 1) + + return panel + +end + +procedure colorcells(panel, matrix) #: color all cells in panel + local i, j, n, m, cellsize + + cellsize := panel.size + + m := *matrix + n := *matrix[1] + + every i := 1 to m do { + every j := 1 to n do { + # fudge 0/1 matrix + if matrix[i, j] === "1" then matrix[i, j] := "white" + else if matrix[i, j] === "0" then matrix[i, j] := "black" + Fg(panel.window, matrix[i, j]) + stop("Fg() failed in colorcells() with matrix[" || + i || "," || j || "]=" || matrix[i, j] || ".") + FillRectangle(panel.window, (j - 1) * cellsize + 1, (i - 1) * cellsize + 1, + cellsize - 1, cellsize - 1) + } + } + + return panel + +end + +procedure tiercells(panel, tier) #: color all cells in panel + local i, j, n, m, cellsize, matrix + + cellsize := panel.size + + m := tier.shafts + n := tier.treadles + matrix := tier.matrix + + every i := 1 to m do { + every j := 1 to n do { + if matrix[i, j] === "1" then Fg(panel.window, "white") + else Fg(panel.window, "black") + FillRectangle(panel.window, (j - 1) * cellsize + 1, (i - 1) * cellsize + 1, + cellsize - 1, cellsize - 1) + } + } + + return panel + +end + +procedure cell(panel, x, y) + local n, m + + n := x / panel.size + 1 + m := y / panel.size + 1 + + if (n > panel.n) | (m > panel.m) then fail + + return Cell(n, m, Pixel(panel.window, x, y)) + +end diff --git a/ipl/gpacks/weaving/clearpane.icn b/ipl/gpacks/weaving/clearpane.icn new file mode 100644 index 0000000..f53f4e9 --- /dev/null +++ b/ipl/gpacks/weaving/clearpane.icn @@ -0,0 +1,22 @@ + +procedure clear_pane(win, n, m, size) + local x, y, width, height, save_fg + + width := n * size + 1 + height := m * size + 1 + + save_fg := Fg(win) + + Fg(win, "black") + + every x := 0 to width by size do + DrawLine(win, x, 0, x, height) + + every y := 0 to height by size do + DrawLine(win, 0, y, width, y) + + Fg(win, save_fg) + + return + +end diff --git a/ipl/gpacks/weaving/colorup.icn b/ipl/gpacks/weaving/colorup.icn new file mode 100644 index 0000000..995a65c --- /dev/null +++ b/ipl/gpacks/weaving/colorup.icn @@ -0,0 +1,49 @@ +############################################################################ +# +# File: colorup.icn +# +# Subject: Program to produce a weave structure from unravel data +# +# Author: Ralph E. Griswold +# +# Date: May 26, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################# +# +# Input is expected to be the output of unravel -2. +# +############################################################################# +# +# AD HOC +# +############################################################################ + +procedure main() + local warp, weft, pattern, rows, row, i, j + + warp := read() | stop("*** short file") + weft := read() | stop("*** short file") + pattern := read() | stop("*** short file") + + write(warp) + write(weft) + + rows := [] + + pattern ? { + while put(rows, move(*warp)) + } + + every i := 1 to *weft do { + row := rows[i] + every j := 1 to *warp do + if row[j] == warp[j] then writes("1") else writes("0") + } + + write() + +end diff --git a/ipl/gpacks/weaving/colrcvrt.icn b/ipl/gpacks/weaving/colrcvrt.icn new file mode 100644 index 0000000..54f4ce2 --- /dev/null +++ b/ipl/gpacks/weaving/colrcvrt.icn @@ -0,0 +1,40 @@ +############################################################################ +# +# File: colrcvrt.icn +# +# Subject: Program to convert numerical color specifications +# +# Author: Ralph E. Griswold +# +# Date: February 10, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. Should be procedure. +# +############################################################################ +# +# Requires: +# +############################################################################ + +procedure main() + + range := 255 + + while color := read() do { + color ?:= { + r := tab(upto(',')) + move(1) + g := tab(upto(',')) + move(1) + b := tab(0) + } + write((r * range), ",", (g * range), ",", (b * range)) + } + +end diff --git a/ipl/gpacks/weaving/comb.icn b/ipl/gpacks/weaving/comb.icn new file mode 100644 index 0000000..2ca4af6 --- /dev/null +++ b/ipl/gpacks/weaving/comb.icn @@ -0,0 +1,98 @@ +############################################################################ +# +# File: plexity.icn +# +# Subject: Program to count distinct weaves +# +# Author: Ralph E. Griswold +# +# Date: April 5, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program counts the distinct weaves with k color, m warp threads, +# and n wft threads. +# +# The options supported are: +# +# -k i number of colors; default 2 (the maximum supported is 10) +# -m i number of warp threads (columns); default 2 +# -n i number of weft threads (rows); default 2 +# +# To allow k up to 10 (temporary), the representation of colors goes +# from 0 to k - 1. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, k, m, n + + opts := options(args, "k+n+m+") + + k := \opts["k"] | 2 + m := \opts["m"] | 2 + n := \opts["n"] | 2 + + plexity(k, m, n) + +end + +# weaves for k combinations on an m-by-n grid +# +# presently limited to 10 combinations ... + +procedure plexity(k, m, n) + local warps, wefts, boards, weaves + + warps := [] + every put(warps, combinations(k, m)) + + wefts := [] + every put(wefts, combinations(k, n)) + + boards := [] + every put(boards, combinations(2, n * m)) + +# weaves := set() + weaves := [] + +# every insert(weaves, weave(!warps, !wefts, !boards)) + every put(weaves, weave(!warps, !wefts, !boards)) + +# write(*weaves) + + every write(!weaves) + +end + +procedure combinations(k, n) #: all combinations of k characters n times + + if n = 0 then return "" + + suspend (0 to k - 1) || combinations(k, n - 1) + +end + +procedure weave(warp, weft, board) + local n, m, weaving + + weaving := board + + every n := 1 to *weft do + every m := 1 to *warp do + weaving[m + n - 1] := if weaving[m + n - 1] == "0" + then weft[n] else warp[m] + + return weaving + +end diff --git a/ipl/gpacks/weaving/dd.icn b/ipl/gpacks/weaving/dd.icn new file mode 100644 index 0000000..e1ccfa4 --- /dev/null +++ b/ipl/gpacks/weaving/dd.icn @@ -0,0 +1,47 @@ +############################################################################ +# +# File: dd.icn +# +# Subject: Program to show drawdown from unravel -r output +# +# Author: Ralph E. Griswold +# +# Date: May 26, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: cells, tieutils +# +############################################################################ + +link cells +link tieutils + +procedure main() + + shafts := *read() | stop("short file") + treadles := *read() | stop("short file") + + dd := tie2tier(shafts, treadles, read()) | stop("short file") + + panel := makepanel(shafts, treadles, 5) + + tiercells(panel, dd) + + WAttrib(panel.window, "canvas=normal") + + WDone(panel.window) + +end diff --git a/ipl/gpacks/weaving/draw2gmr.icn b/ipl/gpacks/weaving/draw2gmr.icn new file mode 100644 index 0000000..814fc2d --- /dev/null +++ b/ipl/gpacks/weaving/draw2gmr.icn @@ -0,0 +1,73 @@ +############################################################################ +# +# File: draw2gmr.icn +# +# Subject: Program to create drawdown grammar +# +# Author: Ralph E. Griswold +# +# Date: June 15, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to convert an image astring for a drawdown to a grammar for the +# drawdown. +# +# The name of a file containing an image string drawdown is given on the +# command line, as in +# +# draw2gmr shadow.ims +# +# The file is expected to carry the suffix ".ims". If it does not, +# the name for the grammar may not be as expected. +# +############################################################################ +# +# Links: basename, imrutils, weavutil +# +############################################################################ + +link basename +link imrutils +link weavutil + +$define Different 2 # Since the only color labels are 0 and 1 + +procedure main(args) + local imr, rows, row, count, unique, axiom + + imr := imstoimr(read(open(args[1]))) | stop("*** invalid input") + + if imr.palette ~== "g2" then stop("*** invalid palette for drawdown") + + count := 0 + unique := table() + + rows := [] + + imr.pixels ? { + while row := move(imr.width) do { + if /unique[row] then unique[row] := (count +:= 1) + put(rows, unique[row]) + } + } + + axiom := "" + every axiom ||:= possym(!rows + Different) + + write("name:", basename(args[1], ".ims")) + write("comment:drawdown") + write("axiom:2") + write("gener:1") + write("2->", axiom) + + unique := sort(unique, 4) + + while row := get(unique) do + write(possym(get(unique) + Different), "->", row) + +end diff --git a/ipl/gpacks/weaving/drawdown.icn b/ipl/gpacks/weaving/drawdown.icn new file mode 100644 index 0000000..9355e1c --- /dev/null +++ b/ipl/gpacks/weaving/drawdown.icn @@ -0,0 +1,82 @@ +############################################################################ +# +# File: drawdown.icn +# +# Subject: Program to produce drawdown +# +# Author: Ralph E. Griswold +# +# Date: March 2, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces a weaving draw down from string weaving +# specification taken from standard input. Black cells are the warp, +# white cells the weft. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: cells, expander, interact, tieutils, weavutil +# +############################################################################ + +link cells +link expander +link interact +link tieutils +link weavutil + +$define MaxSize 160 + +procedure main() + local threading, treadling, panel, x, y, tieup, temp, cellsize + local shafts, treadles, treadle, i, j + + cellsize := 5 + + read() | stop("*** short file") # skip name + + threading := pfl2str(read()) | stop("*** short file") + treadling := pfl2str(read()) | stop("*** short file") + + if *threading > MaxSize then threading := left(threading, MaxSize) + if *treadling > MaxSize then treadling := left(treadling, MaxSize) + + read() | stop("*** short file") # skip warp colors + read() | stop("*** short file") # skip weft colors + + tieup := tie2tier(read(), *cset(threading)).matrix | stop("*** short file") + + panel := makepanel(*threading, *treadling, cellsize, "black", "white", "black") + + WAttrib(panel.window, "canvas=normal") + + every y := 1 to *treadling do { + treadle := tieup[sympos(treadling[y])] | { + stop("*** treadling bogon") + } + every i := 1 to *treadle do { + if treadle[i] == "0" then { + every j := 1 to *threading do { + if sympos(threading[j]) = i then + colorcell(panel, j, y, "white") + } + } + } + } + + Fg(panel.window, "black") + Bg(panel.window, "light gray") + + if TextDialog("Drawdown finished.", , , , ["Quit", "Save"]) == "Quit" then exit + else snapshot(panel.window) + +end diff --git a/ipl/gpacks/weaving/drawing.icn b/ipl/gpacks/weaving/drawing.icn new file mode 100644 index 0000000..c5fc707 --- /dev/null +++ b/ipl/gpacks/weaving/drawing.icn @@ -0,0 +1,463 @@ +############################################################################ +# +# File: drawing.icn +# +# Subject: Program to create weaving drafts +# +# Author: Ralph E. Griswold +# +# Date: March 27, 1999 +# +############################################################################ +# +# This program creates weaving drafts. This is a version of weaver +# to output the warp/weft drawdown. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: cells, expander, interact, tieutils, vsetup, weaving, weavutil +# +############################################################################ + +link cells +link expander +link interact +link tieutils +link vsetup +link weaving +link weavutil + +$include "weavdefs.icn" + +global drawdown +global mutant +global titleheight +global framewidth +global interface +global posx +global posy +global root +global threading +global tieup +global treadling +global vidgets +global weaving # current weaving draft +global tieup_cells +global tieup_pane +global tieup_panel +global drawdown_cells +global drawdown_pane +global drawdown_panel +global threading_cells +global threading_pane +global threading_panel +global treadling_cells +global treadling_pane +global treadling_panel + +$define CellSize 8 +$define TieupSize 16 +$define ThreadingSize 100 + +procedure main() + local atts + + atts := ui_atts() + + put(atts, "posx=0", "posy=0") + + interface := (WOpen ! atts) | stop("can't open window") + + framewidth := WAttrib(interface, "posx") + titleheight := WAttrib(interface, "posy") + + posx := "posx=" || (3 * framewidth) + WAttrib(interface, "width") + posy := "posy=" || WAttrib(interface, "posy") + + vidgets := ui() # set up vidgets + root := vidgets["root"] + + init() + + repeat { + case Active() of { + interface : ProcessEvent(root, , shortcuts) + drawdown_pane : process_drawdown() + tieup_pane : process_tieup() + threading_pane : process_threading() + treadling_pane : process_treadling() + } + Raise(interface) + } + +end + +procedure process_drawdown() + local coord + + if not(Event(drawdown_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(drawdown_panel, &x, &y) | fail + + return + +end + +procedure process_tieup() + local coord + + if not(Event(tieup_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(tieup_panel, &x, &y) | fail + + return + +end + +procedure process_threading() + local coord + + if not(Event(threading_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(threading_panel, &x, &y) | fail + + return + +end + +procedure process_treadling() + local coord + + if not(Event(treadling_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(treadling_panel, &x, &y) | fail + + return + +end + +procedure init() + + threading := vidgets["threading"] + treadling := vidgets["treadling"] + tieup := vidgets["tie-up"] + drawdown := vidgets["drawdown"] + + # Note: The additional rows and columns are for the threading and + # treadling colors. + + tieup_cells := makepanel(TieupSize + 1, TieupSize + 1, CellSize, , + "white" , "black") + threading_cells := makepanel(ThreadingSize, TieupSize + 1, CellSize, , + "white" , "black") + treadling_cells := makepanel(TieupSize + 1, ThreadingSize, CellSize, , + "white" , "black") + drawdown_cells := makepanel(ThreadingSize, ThreadingSize, CellSize, , + "white" , "black") + + tieup_pane := WOpen( + "label=tie-up", + "width=" || WAttrib(tieup_cells.window, "width"), + "height=" || WAttrib(tieup_cells.window, "height"), + posx, + posy + ) | bad_window(1) + tieup_panel := copy(tieup_cells) + tieup_panel.window := tieup_pane + + treadling_pane := WOpen( + "label=treadling", + "width=" || WAttrib(treadling_cells.window, "width"), + "height=" || WAttrib(treadling_cells.window, "height"), + posx, + "posy=" || (WAttrib(tieup_pane, "posy") + + WAttrib(tieup_pane, "height") + titleheight + framewidth) + ) | bad_window(2) + treadling_panel := copy(treadling_cells) + treadling_panel.window := treadling_pane + + threading_pane := WOpen( + "label=threading", + "width=" || WAttrib(threading_cells.window, "width"), + "height=" || WAttrib(threading_cells.window, "height"), + posy, + "posx=" || (WAttrib(tieup_pane, "posx") + + WAttrib(tieup_pane, "width") + 2 * framewidth) + ) | bad_window(3) + threading_panel := copy(threading_cells) + threading_panel.window := threading_pane + + drawdown_pane := WOpen( + "label=drawdown", + "width=" || WAttrib(drawdown_cells.window, "width"), + "height=" || WAttrib(drawdown_cells.window, "height"), + "posx=" || WAttrib(threading_pane, "posx"), + "posy=" || WAttrib(treadling_pane, "posy") + ) | bad_window(4) + drawdown_panel := copy(drawdown_cells) + drawdown_panel.window := drawdown_pane + + clear_panes() + + Raise(interface) + + return + +end + +procedure bad_window(i) + + Notice("Cannot open window" || i || ".") + + exit() + +end + +procedure clear_panes() + + CopyArea(tieup_cells.window, tieup_pane, 0, 0, , , 0, 0) + CopyArea(threading_cells.window, threading_pane, 0, 0, , , 0, 0) + CopyArea(treadling_cells.window, treadling_pane, 0, 0, , , 0, 0) + CopyArea(drawdown_cells.window, drawdown_pane, 0, 0, , , 0, 0) + + return + +end + +procedure drawdown_cb(vidget, value) + + case value[1] of { + "warp/weft @B" : draw_down(weaving) + "color @C" : draw_weave(weaving) + } + + return + +end + +procedure file_cb(vidget, value) + + case value[1] of { + "open @O" : open_weave() + "quit @Q" : quit() + "image @I" : draw_image() + "save @S" : save_weave() + } + + return + +end + +procedure quit() + + exit() + +end + +procedure open_weave() + local i + + repeat { + if load_file() == "Cancel" then fail + weaving := draft() + every i := 1 to 7 do + weaving[i] := pfl2str(read(dialog_value)) | { + Notice("Short file.") + close(dialog_value) + break next + } + close(dialog_value) + break + } + + if *weaving.threading > ThreadingSize then + weaving.threading := left(weaving.threading, ThreadingSize) + if *weaving.treadling > ThreadingSize then + weaving.treadling := left(weaving.treadling, ThreadingSize) + weaving.warp_colors := Extend(weaving.warp_colors, *weaving.threading) + weaving.weft_colors := Extend(weaving.weft_colors, *weaving.treadling) + + weaving.warp_colors := map(weaving.warp_colors, C1In, C1Ex) + weaving.weft_colors := map(weaving.weft_colors, C1In, C1Ex) + + weaving.tieup := tie2coltier(weaving.tieup) + + mutant := &null + + clear_panes() + + draw_down(weaving) + +end + +procedure draw_down(weaving) +# local bw # RETHINK THIS + +# bw := copy(\weaving) | { +# Notice("No weaving.") +# fail +# } + +# bw.warp_colors := repl("0", *bw.threading) +# bw.weft_colors := repl("1", *bw.treadling) +# bw.palette := "g2" + + draw_weave(weaving) + + return + +end + +procedure draw_image() + + return + +end + +procedure draw_weave(weaving, kind) + local i, treadle, j, x, y, k, shafts, treadles, color, treadle_list + local weft_colors, labels, c + static mask + + if /weaving then { + Notice("No weaving.") + fail + } + + mask := Mask + + if /mutant then { + mutant := table() + labels := weaving.warp_colors ++ weaving.weft_colors ++ + PaletteKey(weaving.palette, "white") ++ PaletteKey(weaving.palette, + "black") + every c := !labels do { + if /mutant[c] then + mutant[c] := NewColor(PaletteColor(weaving.palette, c)) | { + Notice("Ran out of colors.") + fail + } + } + } + + colorcells(tieup_panel, weaving.tieup.matrix) + + every i := 1 to *weaving.threading do + colorcell(threading_panel, i, weaving.threading[i], "black") + + every i := 1 to *weaving.treadling do + colorcell(treadling_panel, weaving.treadling[i], i, "black") + + every i := 1 to *weaving.threading do + colorcell(threading_panel, i, TieupSize + 1, + mutant[weaving.warp_colors[i]]) + + every i := 1 to *weaving.treadling do + colorcell(treadling_panel, TieupSize + 1, i, + mutant[weaving.warp_colors[i]]) + + x := 1 + + if \kind then { # RETHINK THIS + Fg(drawdown_pane, "black") + FillRectangle(drawdown_pane) + } + else { + every color := !weaving.warp_colors \ *weaving.threading do { + color := mutant[color] | { + Notice("Bad warp color specification: " || color|| ".") + fail + } + every y := 1 to *weaving.threading do { + colorcell(drawdown_panel, x, y, color) + } + x +:= 1 + } + } + + treadles := weaving.tieup.treadles + shafts := weaving.tieup.shafts + + treadle_list := list(treadles) + every !treadle_list := [] + + every i := 1 to treadles do + every j := 1 to shafts do + if weaving.tieup.matrix[i, j] == "black" then + every k := 1 to *weaving.threading do + if upto(weaving.threading[k], mask) == j then + put(treadle_list[i], k, 0) + + every y := 1 to *weaving.treadling do { + treadle := upto(weaving.treadling[y], mask) | + stop(&errout, "*** treadling bogon") + color := mutant[weaving.weft_colors[y]] | +# color := PaletteColor(weaving.palette, weaving.weft_colors[y]) | + Notice("Bad weft color specification: " || weaving.weft_colors[y] || ".") + if *treadle_list[treadle] = 0 then next # blank pick + every i := 1 to *treadle_list[treadle] - 1 by 2 do + colorcell(drawdown_panel, treadle_list[treadle][i], + treadle_list[treadle][i + 1] + y, color) + } + + return + +end + +procedure save_weave() + + if save_file() ~== "Yes" then fail + + every write(dialog_value, weaving[1 to 5]) + + write(dialog_value, tier2string(weaving.tieup)) + + write(dialog_value, weaving[7]) + + close(dialog_value) + + return + +end + +procedure shortcuts(e) + + if &meta then case map(e) of { + "b" : draw_down(weaving) + "c" : draw_weave(weaving) + "i" : draw_image() + "o" : open_weave() + "q" : quit() + "s" : save_weave() + } + + return + +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=180,136", "bg=pale gray", "label=Weaver"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,180,136:Weaver",], + ["colors:Menu:pull::101,1,50,21:Colors",colors_cb, + ["palette @P","warp","weft"]], + ["drawdown:Menu:pull::36,2,64,21:Drawdown",drawdown_cb, + ["warp/weft @B","color @C"]], + ["file:Menu:pull::0,2,36,21:File",file_cb, + ["open @O","save @S","image @I","quit @Q"]], + ["line1:Line:::0,24,180,24:",], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/drawscan.icn b/ipl/gpacks/weaving/drawscan.icn new file mode 100644 index 0000000..b3e6dfc --- /dev/null +++ b/ipl/gpacks/weaving/drawscan.icn @@ -0,0 +1,61 @@ +############################################################################ +# +# File: drawscan.icn +# +# Subject: Program to analyze scanned drawdowns +# +# Author: Ralph E. Griswold +# +# Date: May 14, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC and experimental. The parameters are setup for a 32x32 cell +# draft. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: numbers, wopen +# +############################################################################ + +link numbers +link wopen + +$define Cells 32 + +procedure main(args) + local x, y, pixel, popl, width, cellsize + + WOpen("canvas=hidden", "image=" || args[1]) | stop("*** cannot open image") + + width := WAttrib("width") + + cellsize := round(real(width) / Cells) + + writes(Cells, ",g2,") + + width := cellsize * Cells + + every y := 0 to width - cellsize / 2 by cellsize do { + every x := 0 to width - cellsize / 2 by cellsize do { + popl := table(0) + every pixel := Pixel(x + 4, y + 4, cellsize - 8, cellsize - 8) do + popl[PaletteKey("g2", pixel)] +:= 1 + popl := sort(popl, 4) + pull(popl) + writes(pull(popl)) + } + } + + WriteImage("drawscan.gif") + +end diff --git a/ipl/gpacks/weaving/drawup.icn b/ipl/gpacks/weaving/drawup.icn new file mode 100644 index 0000000..b8a3125 --- /dev/null +++ b/ipl/gpacks/weaving/drawup.icn @@ -0,0 +1,119 @@ +############################################################################ +# +# File: drawup.icn +# +# Subject: Program to analyze weaving +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces a PFD from a GIF. The number of shafts and +# treadles needed may exceed the capability of this representation. +# +# Options supported: +# +# -x i x coordinate of upper-left corner to be analyzed; default 0 +# -y i y coordinate of upper-left corner to be analyzed; default 0 +# -w i width of area to be analyzed; default entire width +# -h i height of area to be analyzed; default entire height +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: gpxop, imrutils, options, tables, weavutil, wopen +# +############################################################################ + +link gpxop +link imrutils +link options +link tables +link weavutil +link wopen + +record analysis(rows, sequence, patterns) + +procedure main(args) + local imr, threading, treadling, rows, tie, patterns, pattern, i + local symbols, symbol, opts, x, y, w, h + + opts := options(args, "x+y+w+h+") + + WOpen("image=" || args[1], "canvas=hidden") | stop("*** cannot open image") + + x := \opts["x"] | 0 + y := \opts["y"] | 0 + w := \opts["w"] | WAttrib("width") - x + h := \opts["h"] | WAttrib("height") - y + + imr := imstoimr(Capture("g2", x, y, w, h)) + + treadling := analyze(imr) + imr := imrrot90cw(imr) + threading := analyze(imr) + + write(args[1], "-drawup") + write(threading.sequence) + write(treadling.sequence) + write(repl("1", *threading.sequence)) # black warp threads + write(repl("2", *treadling.sequence)) # white weft threads + write("g2") # palette + write("01") # color keys + write(*threading.rows) # shafts + write(*treadling.rows) # treadles + + patterns := treadling.patterns + rows := treadling.rows + + symbols := table('') + + every pattern := !patterns do { + symbol := rows[pattern] + symbols[symbol] := repl("1", *threading.rows) + pattern ? { + every i := upto('1') do + symbols[symbol][sympos(threading.sequence[i])] := "0" + } + } + + symbols := sort(symbols, 3) + tie := "" + while get(symbols) do + tie ||:= get(symbols) + write(tie2pat(*threading.rows, *treadling.rows, tie)) + +end + +procedure analyze(imr) + local pattern, rows, row, count, patterns + + pattern := "" + patterns := [] + + rows := table() + + count := 0 + + imr.pixels ? { + while row := move(imr.width) do { + if /rows[row] then { + rows[row] := possym(count +:= 1) | stop("*** out of symbols") + put(patterns, row) + } + pattern ||:= rows[row] + } + } + + return analysis(rows, pattern, patterns) + +end diff --git a/ipl/gpacks/weaving/expand.icn b/ipl/gpacks/weaving/expand.icn new file mode 100644 index 0000000..d9f7483 --- /dev/null +++ b/ipl/gpacks/weaving/expand.icn @@ -0,0 +1,31 @@ +############################################################################ +# +# File: expand.icn +# +# Subject: Program to expand pattern forms +# +# Author: Ralph E. Griswold +# +# Date: June 26, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. +# +############################################################################ +# +# Links: expander +# +############################################################################ + +link expander + +procedure main() + + while write(pfl2str(read(), 8)) + +end diff --git a/ipl/gpacks/weaving/fill.icn b/ipl/gpacks/weaving/fill.icn new file mode 100644 index 0000000..24cd44f --- /dev/null +++ b/ipl/gpacks/weaving/fill.icn @@ -0,0 +1,15 @@ + +procedure fillcell(win, n, m, color) + local save_fg + + save_fg := Fg(win) + Fg(win, color) + + FillRectangle(win, (n - 1) * cellsize, (m - 1) * cellsize, cellsize, + cellsize) + + Fg(win, save_fg) + + return + +end diff --git a/ipl/gpacks/weaving/geom2gif.icn b/ipl/gpacks/weaving/geom2gif.icn new file mode 100644 index 0000000..32b55ce --- /dev/null +++ b/ipl/gpacks/weaving/geom2gif.icn @@ -0,0 +1,53 @@ +############################################################################ +# +# File: geom2gif.icn +# +# Subject: Program to convert weaving geometry to a GIF file +# +# Author: Ralph E. Griswold +# +# Date: May 11, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC AND PRELIMINARY +# +# DOESN'T WORK CORRECTLY +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: weavutil, open +# +############################################################################ + +link weavutil +link wopen + +procedure main() + local geom, sequence, img, i + + sequence := read() | stop("*** empty input file") + + geom := [] + + while put(geom, read()) + + WOpen("size=" || *sequence || "," || *sequence) | stop("*** cannot open window") + + img := *sequence || "," || "c1," + + every img ||:= geom[sympos(!sequence)] + + DrawImage(0, 0, img) | stop("DrawImage() failed") + + WDone() + +end diff --git a/ipl/gpacks/weaving/gif2geom.icn b/ipl/gpacks/weaving/gif2geom.icn new file mode 100644 index 0000000..8d6e04a --- /dev/null +++ b/ipl/gpacks/weaving/gif2geom.icn @@ -0,0 +1,74 @@ +############################################################################ +# +# File: gif2geom.icn +# +# Subject: Program to analyze weaving patterns +# +# Author: Ralph E. Griswold +# +# Date: June 15, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program does a row analysis of a GIF image, labels each unique row, +# and then outputs a string of row labels for the image and the value of +# each as a string of palette characters. +# +# The following option is supported: +# +# -p s palette name, default "c1" +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: options, weavutil, wopen +# +############################################################################ + +link options +link weavutil +link wopen + +procedure main(args) + local rows_diff, height, width, y, row, count, row_pattern, pixel, opts + local palette + + opts := options(args, "p:") + + palette := \opts["p"] | "c1" # need to check for valid palette + + WOpen("image=" || args[1], "canvas=hidden") | stop("*** cannot open image") + + rows_diff := table() + row_pattern := "" + + height := WAttrib("height") + width := WAttrib("width") + + count := 0 + + every y := 0 to height - 1 do { + row := "" + every pixel := Pixel(0, y, width, 1) do + row ||:= PaletteKey(palette, pixel) + if /rows_diff[row] then + rows_diff[row] := (count +:= 1) + row_pattern ||:= possym(rows_diff[row]) | + stop("*** too many different rows to label") + } + + write(row_pattern) + + rows_diff := sort(rows_diff, 3) + + while write(get(rows_diff)) do + get(rows_diff) + +end diff --git a/ipl/gpacks/weaving/gif2html.icn b/ipl/gpacks/weaving/gif2html.icn new file mode 100644 index 0000000..f86985b --- /dev/null +++ b/ipl/gpacks/weaving/gif2html.icn @@ -0,0 +1,94 @@ +############################################################################ +# +# File: gif2html.icn +# +# Subject: Program to create Web pages for weaving GIFs +# +# Author: Ralph E. Griswold +# +# Date: February 15, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces Web pages with images in the cells of +# tables. File names are given on the command line. The main Web +# page contains links to the pages with the images. +# +# The following options are supported: +# +# -n s page name prefix; default "images" +# -s i cell size -- typically the size of the GIFs; default 128 +# -t s page title, default "Images" +# -w i maximum width of page (for printing constraints); default 700 +# +# The main page is named <name>.html; the image pages are named +# <name>ddd.html. +# +############################################################################ +# +# Link: options +# +############################################################################ + +link options + +procedure main(args) + local td, size, n, opts, width, pages, output, count, title, mainout, file + + opts := options(args, "mn:s+t:w+") + + pages := opts["m"] + name := \opts["n"] | "image" + size := \opts["s"] | 128 + title := \opts["t"] | "Images" + width := \opts["w"] | 700 + + size +:= 1 + + n := width / size + + if n < 1 then stop("*** images too large") + + td := "<TD ALIGN=center WIDTH=\"" || size || "\" HEIGHT=\"" || size || + "\"><IMG SRC=\"" + + mainout := open(name || ".html", "w") | stop("*** cannot open main page") + + write(mainout, "<HTML><HEAD><TITLE>", title, "</TITLE></HEAD><BODY>") + + count := 0 + + repeat { + until *args = 0 do { + output := open(file := name || right(count +:= 1, 3, "0") || + ".html", "w") | stop("*** cannot open image page") + write(output, "<HTML>") + write(output, "<HEAD><TITLE>", title, right(count, 3), "</TITLE></HEAD>") + write(output, "<BODY>") + write(output, "<H2>", title, right(count, 3), "</H2>") + write(output, "<TABLE BORDER=\"1\" CELLSPACING=\"2\" CELLPADDING=\"0\">") + every 1 to 10 do { + write(output, "<TR>") + every 1 to n do { + write(output, td, get(args), "\"></TD>") | + break break + } + write(output, "</TR>") + } + write(output, "</TABLE><BR><BR>") + write(output, "</BODY>") + write(output, "</HTML>") + close(output) + write(mainout, "<A HREF=\"", file, "\">", file, "</A><BR>") + } + if *args = 0 then break + } + + write(mainout, "</BODY>") + write(mainout, "</HTML>") + +end diff --git a/ipl/gpacks/weaving/heddle.icn b/ipl/gpacks/weaving/heddle.icn new file mode 100644 index 0000000..087a69c --- /dev/null +++ b/ipl/gpacks/weaving/heddle.icn @@ -0,0 +1,426 @@ +############################################################################ +# +# File: heddle.icn +# +# Subject: Program to find thread colors for weaving +# +# Author: Will Evans +# +# Date: April 19, 1999 +# +############################################################################ +# +# Contributor: Gregg Townsend +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Heddle solves a coloring problem inspired by weaving. Given a +# multicolored rectangular pattern, assign colors to warp and weft +# threads that will allow the pattern to be woven on a loom. +# We ignore questions of structural integrity and insist only +# that each cell's color be matched by either the corresponding +# warp thread (column color) or weft thread (row color). +# +############################################################################ +# +# Usage: heddle filename +# +# Input is an image file (GIF, XBM) to be mapped to the c1 palette, +# or an image string acceptable to readims(). The maximum size is +# 256 x 256. +# +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics, imscolor, imsutils +# +############################################################################ + + +link graphics +link imscolor +link imsutils + +global opts # command options +global fname # input file name +global imstring # image string from input file +global nrows # number of rows in input image +global ncols # number of columns in input image +global palette # palette type (e.g. "c1") +global data # image data + +############################## MAIN ############################## + +procedure main(args) + local g + + *args >= 1 | stop("usage: ", &progname, " imsfile <imsfile>*") + + every (fname := !args) do { + if not readWeaving(fname) then { + write(&errout,fname," : Can't load file") + } else { + g := implicationGraph() +# writeGraph(g) + + scc(g) +# writes("finishOrder ") +# writeList(finishOrder) +# writes("visited ") +# writeForest(visited) + + if not assignColors() then { + write(&errout,fname," : Can't assign colors") +# writeForest(visited) + } else { + dpygrid(fname) + } + } + } + return +end + + + +############################## INPUT ############################## + +# readWeaving(fname) -- load image from file, convert to imstring +# if necessary + +procedure readWeaving(fname) + local f, s + + if f := WOpen("canvas=hidden", "image=" || fname) then { + if WAttrib(f, "width" | "height") > 256 then + write("image exceeds 256 x 256") & fail + imstring := Capture(f, "c1") | + (write("can't init captured image") & fail) + WClose(f) + } else { + f := open(fname) | fail + imstring := readims(f) | fail + close(f) + } + ncols := imswidth(imstring) | fail + nrows := imsheight(imstring) | fail + palette := imspalette(imstring) | fail + data := (imstring ? 3(tab(upto(',')+1), tab(upto(',')+1), tab(0))) | fail + if *data ~= nrows * ncols then + write("malformed image string: wrong data length") & fail + if nrows > 256 || ncols > 256 then + write("pattern exceeds 256 x 256") & fail + return +end + + + +######################### Graph Structure ########################### +# +# Consists of a table of lists of strings. +# The strings are vertex names. +# The table is indexed by vertex names. +# T["x1==c"] is a list of neighbors of vertex "x1==c" +# The naming convention of vertices used in loom is: +# +# <x|y><==|~=><color character> +# +# "x1==c" is a vertex that says "the first warp thread is color c" +# "y3~=c" means the third weft thread is NOT color c" +# +####################################################################### + + +######################### Depth First Search ######################## + +global visited # keep track of visited vtcs +global finishOrder # vertex list: rev. finish order +global treeNumber # DFS tree number + +$define RECURSIVE_DFS +$ifdef RECURSIVE_DFS + +procedure dfs(g,visitOrder) + local v + + finishOrder := [] # vertex list: rev. finish order + visited := table() # table of visited vtcs (holds their + treeNumber := 1 # DFS tree number) + + if /visitOrder then { + visitOrder := [] + every put(visitOrder,key(g)) + } + every /visited[v := !visitOrder] do { # loop over unvisited vertices + dfsFrom(g,v) + treeNumber +:= 1 + } + return +end + +procedure dfsFrom(g,v) + local w + + visited[v] := treeNumber # mark vertex with its DFStree number + every /visited[w := !g[v]] do { # loop over unvisited nbrs + dfsFrom(g,w) # push dfs from nbr onto tree + } + push(finishOrder,v) # store as finished + return +end + +$else + +procedure dfs(g,visitOrder) + local v, w, stack + + stack := [] # stack for DFS + finishOrder := [] # vertex list: rev. finish order + visited := table() # table of visited vtcs (holds their + treeNumber := 0 # DFS tree number) + + if /visitOrder then { # arbitrary visitOrder if not given + visitOrder := [] + every put(visitOrder,key(g)) + } + every /visited[v := !visitOrder] do { # loop over unvisited vertices + treeNumber +:= 1 + visited[v] := treeNumber # assign treeNumber + put(g[v],"*") # add mark to end of adj list + push(stack,v) # push vertex onto stack + while (v := stack[1]) do { + w := get(g[v]) # get next nbr of v + if w == "*" then { # exhausted nbrs so pop v + push(finishOrder,pop(stack)) + } else { + put(g[v],w) # put nbr at end of v's adj list + if /visited[w] then { # if w not visited then visit... + visited[w] := treeNumber + put(g[w],"*") + push(stack,w) # ...and stack + } + } + } + } +end + +$endif + +######################### Strongly Connected Components ############# +# Sets "visited" to be SCC number of vertices in g: +# If visited[v] = visited[w] then v and w in same SCC. +# Sets "finishOrder" to be SCC-topoorder of vertices: +# If (v,w) \in g then v and w in same SCC or v after w +# in "finishOrder". + +procedure scc(g) + dfs(g) + dfs(transpose(g),copy(finishOrder)) + return +end + + +######################### Transpose ################################# + +procedure transpose(g) + local h, v, w + + h := table() # table of lists + every v := key(g) do { + /h[v] := [] # create empty adj list if needed + every w := !g[v] do { + /h[w] := [] + put(h[w],v) + } + } + return h +end + + +######################### Graph from Image ########################## + +procedure implicationGraph() + local colors, i, j, c, d, g, x, y, notx, noty + + colors := set() # set of colors in image + +# Form an implication graph from the given data + g := table() # graph = table of lists + +# Put in edges caused by the color matrix + data ? { + every j := 1 to nrows do { + every i := 1 to ncols do { + c := move(1) + notx := "x"||i||"~="||c + noty := "y"||j||"~="||c + x := "x"||i||"=="||c + y := "y"||j||"=="||c + /g[notx] := [] # create empty adj lists if needed + /g[noty] := [] + /g[x] := [] + /g[y] := [] + put(g[notx],y) # xi~=c --> yj==c + put(g[noty],x) # yj~=c --> xi==c + insert(colors,c) # add color to set of seen colors + } + } + } + +# Put in edges that say color for a thread must be unique + every c := !colors do { + every i := 1 to ncols do { + every d := (c ~== !colors) do { + x := "x"||i||"=="||c + notx := "x"||i||"~="||d + /g[x] := [] # create empty adj lists if needed + /g[notx] := [] + put(g[x],notx) # xi==c --> xi~=d + } + } + every i := 1 to nrows do { + every d := (c ~== !colors) do { + y := "y"||i||"=="||c + noty := "y"||i||"~="||d + /g[y] := [] # create empty adj lists if needed + /g[noty] := [] + put(g[y],noty) # yi==c --> yi~=d + } + } + } + return g +end + +######################### Assign Colors ############################# +# If "xi==c" and "xi~=c" (or "yj==c" and "yj~=c") both occur in the same +# strongly connected component, for some character c and 1<=i<=nrows +# (1<=j<=nrows), then there is no solution. +# +# If "xi==c" is first occurrence of "xi==*" (or "yi==c" is first of "yi==*") +# in SCC-topoorder then the warp thread i (weft thread i) can be colored c. + +global colColor +global rowColor + +procedure assignColors() + local v, xy, i, op, c + + colColor := list(ncols) + rowColor := list(nrows) + every v := !finishOrder do { + v ? { # parse vertex name + xy := move(1) + i := tab(many(&digits)) + op := move(2) + c := move(1) + } + if (op == "==") then { + if (xy == "x") & (/colColor[i]) then { + if (visited[v] == visited[xy||i||"~="||c]) then fail + colColor[i] := c + } else if (xy == "y") & (/rowColor[i]) then { + if (visited[v] == visited[xy||i||"~="||c]) then fail + rowColor[i] := c + } + } + } + return +end + + +######################### OUTPUT ############################# + +# dpygrid(label) -- display grid in window + +$define BACKGROUND "pale-weak-yellow" +$define PREFSZ 800 # preferred size after scaling +$define MAXMAG 10 # maximum magnification + +$define STRIPE 6 # space for thread color(s) +$define GAP 1 # margin around image + +procedure dpygrid(label) + local s, x, y, c + static w, h, z, p, v + + p := imspalette(imstring) + w := STRIPE + GAP + ncols + GAP + STRIPE + h := STRIPE + GAP + nrows + GAP + STRIPE + z := PREFSZ / w + z >:= PREFSZ / h + z <:= 1 + z >:= MAXMAG + WOpen("width=" || (z * w), "height=" || (z * h), "bg=" || BACKGROUND) | + (write("can't open window") & fail) + + EraseArea() + DrawImage(STRIPE + GAP, STRIPE + GAP, imstring) + y := 0 + every c := !rowColor do { + Fg(PaletteColor(palette,c)) + DrawPoint(STRIPE - 1, STRIPE + GAP + y) + DrawPoint(w - STRIPE, STRIPE + GAP + y) + y +:= 1 + } + x := 0 + every c := !colColor do { + Fg(PaletteColor(palette,c)) + DrawPoint(STRIPE + GAP + x, STRIPE - 1) + DrawPoint(STRIPE + GAP + x, h - STRIPE) + x +:= 1 + } + + Zoom(0, 0, w, h, 0, 0, z * w, z * h) + + if nrows <= z * STRIPE & ncols <= z * STRIPE then + every DrawImage(1 | z * w - ncols - 1, 1 | z * h - nrows - 1, imstring) + + WAttrib("label=" || fname || ": " || label) + until Event() === QuitEvents() + WClose() + return +end + +############################## DEBUG ############################# + +procedure writeGraph(g) + local v + every v := key(g) do { + writes(v,":") + writeList(g[v]) + } + return +end + +procedure writeList(L) + writes("[") + every writes(!L,",") + write("]") + return +end + +procedure writeForest(F) + local pair, index + + index := 0 + every pair := !sort(F,2) do { + if (index ~== pair[2]) then { + write() + writes(index +:= 1,": ") + } + writes(pair[1]," ") + } + write() + return +end + + + + diff --git a/ipl/gpacks/weaving/htmtail.icn b/ipl/gpacks/weaving/htmtail.icn new file mode 100644 index 0000000..47fc456 --- /dev/null +++ b/ipl/gpacks/weaving/htmtail.icn @@ -0,0 +1,3 @@ + </body> + +</html> diff --git a/ipl/gpacks/weaving/hypo.icn b/ipl/gpacks/weaving/hypo.icn new file mode 100644 index 0000000..2b4be32 --- /dev/null +++ b/ipl/gpacks/weaving/hypo.icn @@ -0,0 +1,13 @@ +procedure main() + + every m := 2 to 5 do + every k := 2 to 5 do + write("m=", m, " k=", k, " n=", compute(m, k)) + +end + +procedure compute(m, k) + + return (2 ^ ((m ^ 2) - 3)) * (k ^ 3) + +end diff --git a/ipl/gpacks/weaving/ims2pat.icn b/ipl/gpacks/weaving/ims2pat.icn new file mode 100644 index 0000000..4ded94a --- /dev/null +++ b/ipl/gpacks/weaving/ims2pat.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: ims2pat.icn +# +# Subject: Program to convert image string to bi-level pattern +# +# Author: Ralph E. Griswold +# +# Date: February 9, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ +# +# Requires: +# +############################################################################ +# +# Links: imrutils, imsutils, patutils +# +############################################################################ + +link imrutils +link imsutils +link wopen + +procedure main() + local imr + + imr := imstoimr(read()) + + imropen(imr) + + write(pix2pat(&window, 0, 0, WAttrib("width"), WAttrib("height"))) + +end diff --git a/ipl/gpacks/weaving/lindpath.icn b/ipl/gpacks/weaving/lindpath.icn new file mode 100644 index 0000000..d724479 --- /dev/null +++ b/ipl/gpacks/weaving/lindpath.icn @@ -0,0 +1,206 @@ +############################################################################ +# +# File: lindpath.icn +# +# Subject: Program to create paths for 0L-systems +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads in a 0L-system (Lindenmayer system) consisting of +# rewriting rules in which a string is rewritten with every character +# replaced simultaneously (conceptually) by a specified string of +# symbols. +# +# Rules have the form +# +# S->SSS... +# +# where S is a character. +# +# In addition to rules, there are keywords that describe the system and how +# to draw it. These include the "axiom" on which rewriting is started and +# optionally the angle in degrees between successive lines (default 90). +# Other keywords are ignored. +# +# Keywords are followed by a colon. +# +# An example 0L-system is: +# +# X->-FX++FY- +# Y->+FX--FY+ +# F-> +# -->- +# +->+ +# axiom:FX +# angle:45.0 +# xorg:100 +# yorg:100 +# +# Here, the initial string is "FX" and angular increment is 45 degrees. +# Note that "-" is a legal character in a 0L-system -- context determines +# whether it's 0L character or part of the "->" that stands for "is +# replaced by". +# +# If no rule is provided for a character, the character is not changed +# by rewriting. Thus, the example above can be expressed more concisely +# as +# +# X->-FX++FY- +# Y->+FX--FY+ +# F-> +# axiom:FX +# angle:45.0 +# +# The recognized keywords are: +# +# axiom axiom for generation +# angle angular increment for turns +# length segment length +# xorg x origin +# yorg y origin +# comment comment; ignored +# +# Distances increase from left to right in the x direction and from top +# to bottom in the y direction. +# +# As pure-production systems, the characters are symbolic and have no +# meaning. When interpreted for drawing, the characters have the +# following meaning: +# +# F move forward by length +# f move backward by length +# + turn right by angle +# - turn left by angle +# [ save current state +# ] restore current state +# +# The file containing the 0L-systems is read from standard input. +# +# The command-line options are: +# +# -g i number of generations, default 3 +# -l i length of line segments, default 5 +# -a i angular increment in degrees (overrides angle given in +# the grammar) +# -w i window width +# -h i window height +# -x i initial x position, default mid-window +# -y i initial y position, default mid-window +# -W write out string instead of drawing +# -s take snapshot of image +# -d i delay in milliseconds between symbol interpretations; +# default 0 +# +# References: +# +# Formal Languages, Arto Salomaa, Academic Press, 1973. pp. 234-252. +# +# The Algorithmic Beauty of Plants, Przemyslaw Prusinkiewicz and +# Aristid Lindenmayer, Springer Verlag, 1990. +# +# Lindenmayer Systems, Fractals, and Plants, Przemyslaw Prusinkiewicz and +# James Hanan, Springer Verlag, 1989. +# +############################################################################ +# +# See linden.dat for an example of input data. +# +############################################################################ +# +# Requires: graphics if drawing +# +############################################################################ +# +# Links: linddraw, options, tpath, wopen +# +############################################################################ + +link linddraw +link options +link tpath +link wopen + +procedure main(args) + local line, gener, axiom, angle, opts, i, s, c, symbol, rewrite + local allchars, rhs, value, spec, x, y, length, w, h, delay + + rewrite := table() + allchars := '' # cset of all rhs characters + + opts := options(args,"g+l+a+w+h+x+y+Wsd+") + + while line := read() do + line ? { + if symbol := move(1) & ="->" then { + rhs := tab(0) + rewrite[symbol] := rhs + allchars ++:= rhs # keep track of all characters + } + else if spec := tab(upto(':')) then { + move(1) + value := tab(0) + case spec of { + "axiom": { + axiom := value + allchars ++:= rhs # axiom might have strays + } + "angle": angle := value + "xorg": x := value + "yorg": y := value + "comment": &null # ignore comments + "length": length := value + "gener": gener := value + default: write(&errout, "unknown keyword: ", spec) + } # ignore others + } + else write(&errout, "malformed input: ", tab(0)) + } + +# At this point, we have the table to map characters, but it may lack +# mappings for characters that "go into themselves" by default. For +# efficiency in rewriting, these mappings are added. + + every c := !allchars do + /rewrite[c] := c + + h := \opts["h"] | 400 + w := \opts["w"] | 400 + + angle := \opts["a"] # command-line overrides + length := \opts["l"] + gener := \opts["g"] + x := \opts["x"] + y := \opts["y"] + delay := \opts["d"] + + /angle := 90 # defaults + /length := 5 + /gener := 3 + /x := 0 + /y := 0 + /delay := 0 + + if /axiom then stop("*** no axiom") + + TPath(x, y, -90.0) + + WDelay := WFlush := 1 + + linddraw(x, y, axiom, rewrite, length, angle, gener, delay) + + WOpen("size=" || w || "," || h, "dx=" || (w / 2), + "dy=" || (h / 2)) | stop("*** cannot open window") + + DrawPath(T_path) + + Event() + +end diff --git a/ipl/gpacks/weaving/lindplot.icn b/ipl/gpacks/weaving/lindplot.icn new file mode 100644 index 0000000..33763df --- /dev/null +++ b/ipl/gpacks/weaving/lindplot.icn @@ -0,0 +1,217 @@ +############################################################################ +# +# File: lindplot.icn +# +# Subject: Program to generate sites along 0L-System +# +# Author: Ralph E. Griswold +# +# Date: June 29, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Note: This version of the program output incremental movements in 3D +# space. It is far from complete at the moment. +# +# This program reads in a 0L-system (Lindenmayer system) consisting of +# rewriting rules in which a string is rewritten with every character +# replaced simultaneously (conceptually) by a specified string of +# symbols. +# +# Rules have the form +# +# S->SSS... +# +# where S is a character. +# +# In addition to rules, there are keywords that describe the system and how +# to draw it. These include the "axiom" on which rewriting is started and +# optionally the angle in degrees between successive lines (default 90). +# The keyword "name" is the first line of the 0L-system. Other keywords +# may be present, but are ignored. +# +# Keywords are followed by a colon. +# +# An example 0L-system is: +# +# name:dragon +# X->-FX++FY- +# Y->+FX--FY+ +# F-> +# -->- +# +->+ +# axiom:FX +# angle:45.0 +# xorg:100 +# yorg:100 +# +# Here, the initial string is "FX" and angular increment is 45 degrees. +# Note that "-" is a legal character in a 0L-system -- context determines +# whether it's 0L character or part of the "->" that stands for "is +# replaced by". +# +# If no rule is provided for a character, the character is not changed +# by rewriting. Thus, the example above can be expressed more concisely +# as +# +# name:dragon +# X->-FX++FY- +# Y->+FX--FY+ +# F-> +# axiom:FX +# angle:45.0 +# +# The recognized keywords are: +# +# name name of L-system +# axiom axiom for generation +# angle angular increment for turns +# length segment length +# xorg x origin +# yorg y origin +# comment comment; ignored +# +# Distances increase from left to right in the x direction and from top +# to bottom in the y direction. +# +# As pure-production systems, the characters are symbolic and have no +# meaning. When interpreted for drawing, the characters have the +# following meaning: +# +# F move forward by length +# f move backward by length +# + turn right by angle +# - turn left by angle +# [ save current state +# ] restore current state +# +# The file containing the 0L-systems is read from standard input. +# +# The command-line options are: +# +# -n s name of 0L-system, default first one +# -g i number of generations, default 3 +# -l i length of line segments, default 5 +# -a i angular increment in degrees (overrides angle given in +# the grammar) +# -w i window width +# -h i window height +# -x i initial x position, default mid-window +# -y i initial y position, default mid-window +# -W write out string instead of drawing +# -s take snapshot of image in <name>.gif +# -d i delay in milliseconds between symbol interpretations; +# default 0 +# +# References: +# +# Formal Languages, Arto Salomaa, Academic Press, 1973. pp. 234-252. +# +# The Algorithmic Beauty of Plants, Przemyslaw Prusinkiewicz and +# Aristid Lindenmayer, Springer Verlag, 1990. +# +# Lindenmayer Systems, Fractals, and Plants, Przemyslaw Prusinkiewicz and +# James Hanan, Springer Verlag, 1989. +# +############################################################################ +# +# See linden.dat for an example of input data. +# +############################################################################ +# +# Requires: graphics if drawing +# +############################################################################ +# +# Links: lindpath, options, wopen +# +############################################################################ + +link lindpath +link options +link wopen + +procedure main(args) + local line, gener, axiom, angle, opts, i, s, c, symbol, rewrite + local allchars, rhs, value, spec, x, y, length, w, h, name, delay + + rewrite := table() + allchars := '' # cset of all rhs characters + + opts := options(args,"n:g+l+a+w+h+x+y+Wsd+") + + if name := \opts["n"] then { + while line := read() | stop("*** 0L-system not found") do + line ? { + if ="name:" & =name & pos(0) then break + } + } + else { + read() ? { # no name specified; discard name line + ="name:" + } + } | stop("*** malformed file") + + while line := read() do + line ? { + if symbol := move(1) & ="->" then { + rhs := tab(0) + rewrite[symbol] := rhs + allchars ++:= rhs # keep track of all characters + } + else if spec := tab(upto(':')) then { + move(1) + value := tab(0) + case spec of { + "axiom": { + axiom := value + allchars ++:= rhs # axiom might have strays + } + "angle": angle := value + "xorg": x := value + "yorg": y := value + "comment": &null # ignore comments + "length": length := value + "gener": gener := value + "name": break # new 0L-system + default: write(&errout, "unknown keyword: ", spec) + } # ignore others + } + else write(&errout, "malformed input: ", tab(0)) + } + +# At this point, we have the table to map characters, but it may lack +# mappings for characters that "go into themselves" by default. For +# efficiency in rewriting, these mappings are added. + + every c := !allchars do + /rewrite[c] := c + + h := \opts["h"] | 400 + w := \opts["w"] | 400 + + length := 1 # normalize length for this application + + angle := \opts["a"] # command-line overrides + length := \opts["l"] + gener := \opts["g"] + x := \opts["x"] + y := \opts["y"] + delay := \opts["d"] + + /angle := 90 # defaults + /length := 5 + /gener := 3 + /x := 0 + /y := 0 + /delay := 0 + + if /axiom then stop("*** no axiom") + + lindpath(x, y, axiom, rewrite, length, angle, gener) + +end diff --git a/ipl/gpacks/weaving/mtrxedit.icn b/ipl/gpacks/weaving/mtrxedit.icn new file mode 100644 index 0000000..b712b5f --- /dev/null +++ b/ipl/gpacks/weaving/mtrxedit.icn @@ -0,0 +1,822 @@ +############################################################################ +# +# File: mtrxedit.icn +# +# Subject: Program to create and edit binary arrays +# +# Authors: Ralph E. Griswold and Gregg M. Townsend +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This application provides a variety of facilities for creating and +# editing binary arrays. It is intended for use with weaving tie-ups +# and liftplans. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: sort, patxform, vdialog, vsetup, dialog, wopen, xcompat +# +############################################################################ + +link sort +link patxform +link vdialog +link vsetup +link dialog +link wopen +link xcompat + +$define MaxCell 24 # maximum size of grid cell + +$define GridSize (32 * 8) # size of area for edit grid +$define GridXoff (32 * 5) # x offset of grid area +$define GridYoff (32 * 2 + 6) # y offset of grid area + +$define PattXoff (32 * 14) # x offset of pattern area +$define PattYoff (32 * 2) # y offset of pattern area +$define PattWidth (32 * 8) # width of pattern area +$define PattHeight (32 * 8) # heigth of pattern area + +$define IconSize 16 # size of button icons + +$define XformXoff (16 * 2) # x offset of xform area +$define XformYoff (16 * 4) # y offset of xform area + +$define MaxPatt 128 + +$define InfoLength 40 # length of lines in info box + +global allxform # transform-all switch +global hbits # number of bits horizontally +global vbits # number of bits veritcally +global rows # row repesentation of tile +global old_pat # old pattern for undo +global cellsize # size of cell in edit grid +global pattgc # graphic context for pattern +global bordergc # border for tile/pattern +global viewgc # clipping area for viewing +global mode # pattern/tile display mode +global tile_touched # tile modification switch +global blank_pat # 8x8 blank tile +global response # switch for save dialog +global sym_state # drawing state +global sym_image_current # current drawing images +global sym_image_next # next drawing images +global symmetries # general symmetry state + +global flip_right # icon for right flip +global flip_left # icon for left flip +global flip_vert # icon for vertical flip +global flip_horiz # icon for horizontal flip +global rotate_90 # icon for 90-degree rotation +global rotate_m90 # icon for -90-degree rotation +global rotate_180 # icon for 180-degree rotation +global ident # icon for identity +global hi_ident # highlighted icon for identity +global hi_left # highlighted icon for l-flip +global hi_right # highlighted icon for r-flip +global hi_vert # highlighted icon for v-flip +global hi_horiz # highlighted icon for h-flip +global hi_rot_90 # highlighted icon for 90-rot +global hi_rot_m90 # highlighted icon for -90 rot +global hi_rot_180 # highlighted icon for 180 rot +global SymmetXoff +global SymmetYoff + +record pattrec(tile) + +procedure main(args) + local vidgets, e, i, j, x, y, v, h, input, mdigits + +# Initial state + + mdigits := '-' ++ &digits + symmetries := 0 # initially no symmetries + allxform := &null # initially not all xforms + + sym_state := [ # initially no symmetries + [1, -1, -1, -1], + [-1, -1, -1, -1] + ] + + blank_pat := "8,#0000000000000000" # 8x8 blank tile + + tile_touched := &null + +# Set up vidgets + + vidgets := ui() + +# Set up graphic contexts + + pattgc := XBind(&window, "fillstyle=textured") # for patterns + bordergc := XBind(&window, "fg=red") # for border + viewgc := XBind(&window) # for tile view + Clip(viewgc, PattXoff, PattYoff, PattWidth, PattHeight) + Clip(bordergc, PattXoff - 1, PattYoff - 1, PattWidth + 2, PattHeight + 2) + + SymmetXoff := vidgets["symregion"].ux + SymmetYoff := vidgets["symregion"].uy + +# Assign and draw the icons + + icons() + +# Initial and toggled editing images + + sym_image_next := [ + [ident, hi_rot_90, hi_rot_m90, hi_rot_180], + [hi_right, hi_left, hi_vert, hi_horiz] + ] + sym_image_current := [ + [hi_ident, rotate_90, rotate_m90, rotate_180], + [flip_right, flip_left, flip_vert, flip_horiz] + ] + + rows := pat2rows(blank_pat) + +# Initial setup of grid and view areas + + setup() | stop("*** cannot set up pattern") + +# Enter event loop + + GetEvents(vidgets["root"], , shortcuts) + +end + +############################################################################ +# +# Callback procedures +# +############################################################################ + +# file menu + +procedure file_cb(vidget, menu) + + return case menu[1] of { + "read @R" : read_tile() + "write @W" : write_tile() + "copy @C" : copy_tile() + "paste @P" : paste_tile() + "quit @Q" : exit() + } + +end + +procedure copy_tile() + local output + + output := open("/tmp/tieup", "w") | { + Notice("Cannot copy tile.") + fail + } + + write_pattern(output, pattrec(rows2pat(rows))) + + close(output) + + return + +end + +procedure paste_tile() + local input, tile + + input := open("/tmp/tieup") | { + Notice("Cannot paste tie-up file.") + fail + } + + tile := read_pattern(input) | { + Notice("Cannot process matrix.") + close(input) + fail + } + + close(input) + + rows := pat2rows(tile.tile) + + return setup() + +end + +# editing grid + +procedure grid_cb(vidget, e) + local x, y, i, j + + if e === (&lpress | &rpress | &ldrag | &rdrag) then { + j := (&x - GridXoff) / cellsize + i := (&y - GridYoff) / cellsize + if j < 0 | j >= hbits | i < 0 | i >= vbits then return + + if e === (&lpress | &ldrag) then setbit(i, j, "1") + else setbit(i, j, "0") + + tile_touched := 1 + } + + return + +end + +# symmetry buttons + +procedure symmet_cb(vidget, e) + local col, row, symcount + + if e === (&lpress | &rpress | &mpress) then { + col := (&x - SymmetXoff) / IconSize + 1 + row := (&y - SymmetYoff) / IconSize + 1 + sym_state[row, col] *:= -1 + sym_image_current[row, col] :=: sym_image_next[row, col] + place(SymmetXoff, SymmetYoff, col - 1, row - 1, + sym_image_current[row, col]) + symcount := 0 + every symcount +:= !!sym_state + if symcount = -8 then + Notice("No drawing mode enabled; pattern cannot be edited") + else if (sym_state[1, 1] = 1) & (symcount = -6) then symmetries := 0 + else symmetries := 1 + + return + } + + fail + +end + +# tile menu + +procedure tile_cb(vidget, value) + local result + + case value[1] of { + "new @N" : new_tile() + "info @I" : tile_info() + } + + return + +end + +procedure new_tile() + + case Dialog("New:", ["width", "height"], [*rows[1], *rows], 3, + ["Okay", "Cancel"]) of { + "Cancel" : fail + "Okay" : { + icheck(dialog_value) | fail + rows := list(dialog_value[2], repl("0", dialog_value[1])) + tile_touched := 1 + return setup() + } + } + + return + +end + +# transformation buttons + +procedure xform_cb(vidget, e) + local col, row + + if e === (&lpress | &rpress | &mpress) then { + old_pat := rows2pat(rows) + col := (&x - XformXoff) / IconSize + row := (&y - XformYoff) / IconSize + rows := xform(col, row) | fail + return setup() + } + +end + +############################################################################ +# +# Support procedures +# +############################################################################ + +# clear bits on current tile + +procedure clear_tile() + + rows := list(vbits, repl("0", hbits)) + + grid() + + return + +end + +# draw editing grid + +procedure grid() + local x, y + + EraseArea(GridXoff, GridYoff, GridSize - 15, GridSize - 15) + + every x := 0 to hbits * cellsize by cellsize do + DrawLine(GridXoff + x, GridYoff, GridXoff + x, + GridYoff + vbits * cellsize) + every y := 0 to vbits * cellsize by cellsize do + DrawLine(GridXoff, GridYoff + y, GridXoff + hbits * cellsize, + y + GridYoff) + + return + +end + +# check for valid integers + +procedure icheck(values) + local i + + every i := !values do + if not(integer(i)) | (i < 0) then { + Notice("Invalid value") + fail + } + + return + +end + +# assign and draw icons + +procedure icons() + local shift_up, shift_left, shift_right, shift_down, pixmap + local clear, invert, scramble, trim, enlarge, resize, crop + + shift_up := "16,#3ffe6003408141c143e140814081408140814081408140_ + 81408160033ffe0000" + shift_left := "16,#3ffe6003400140014001401140195ffd40194011400140_ + 01400160033ffe0000" + shift_right := "16,#3ffe600340014001400144014c015ffd4c014401400140_ + 01400160033ffe0000" + shift_down := "16,#3ffe60034081408140814081408140814081408143e141_ + c1408160033ffe0000" + flip_left := "16,#3ffe600340014079403940394049408149014e014e014f_ + 01400160033ffe0000" + flip_right := "16,#3ffe600340014f014e014e014901408140494039403940_ + 79400160033ffe0000" + flip_vert := "16,#3ffe6003408141c143e14081408140814081408143e141_ + c1408160033ffe0000" + flip_horiz := "16,#3ffe600340014001400144114c195ffd4c194411400140_ + 01400160033ffe0000" + rotate_90 := "16,#3ffe6003400140f141014201420142014f814701420140_ + 01400160033ffe0000" + rotate_m90 := "16,#3ffe600340014781404140214021402140f94071402140_ + 01400160033ffe0000" + rotate_180 := "16,#3ffe6003400141c140214011401140114111432147c143_ + 01410160033ffe0000" + clear := "16,#3ffe600340014001400140014001400140014001400140_ + 01400160033ffe0000" + invert := "16,#3ffe60ff40ff40ff40ff40ff40ff7fff7f817f817f817f_ + 817f817f833ffe0000" + scramble := "16,#3ffe60034c014c0d418d41814001403159b1598140194c_ + 194c0160033ffe0000" + trim := "16,#3ffe60134011407d40394011400140fd48854c857e854c_ + 8548fd60033ffe0000" + enlarge := "16,#3ffe6083418143fd418148815c017efd48854885488548_ + 8548fd60033ffe0000" + resize := "16,#3ffe6093419943fd419948915c017efd488548857e855c_ + 8548fd60033ffe0000" + crop := "16,#3ffe60034011401147fd441144114411441144115ff144_ + 01440160033ffe0000" + + ident := "16,#3ffe6003400140014001400141c141c141c14001400140_ + 01400160033ffe0000" + + hi_ident := "16,#00001ffc3ffe3ffe3ffe3ffe3e3e3e3e3e3e3ffe3ffe3f_ + fe3ffe1ffc00000000" + hi_rot_90 := "16,#00001ffc3ffe3f0e3efe3dfe3dfe3dfe307e38fe3dfe3f_ + fe3ffe1ffc00000000" + hi_rot_m90 := "16,#00001ffc3ffe387e3fbe3fde3fde3fde3f063f8e3fde3f_ + fe3ffe1ffc00000000" + hi_rot_180 := "16,#00001ffc3ffe3e3e3fde3fee3fee3fee3eee3cde383e3c_ + fe3efe1ffc00000000" + hi_right := "16,#00001ffc3ffe30fe31fe31fe36fe3f7e3fb63fc63fc63f_ + 863ffe1ffc00000000" + hi_left := "16,#00001ffc3ffe3f863fc63fc63fb63f7e36fe31fe31fe30_ + fe3ffe1ffc00000000" + hi_vert := "16,#00001ffc3f7e3e3e3c1e3f7e3f7e3f7e3f7e3f7e3c1e3e_ + 3e3f7e1ffc00000000" + hi_horiz := "16,#00001ffc3ffe3ffe3ffe3bee33e6200233e63bee3ffe3f_ + fe3ffe1ffc00000000" + +# now place the images + + place(XformXoff, XformYoff, 1, 0, shift_up) + place(XformXoff, XformYoff, 0, 1, shift_left) + place(XformXoff, XformYoff, 2, 1, shift_right) + place(XformXoff, XformYoff, 1, 2, shift_down) + place(XformXoff, XformYoff, 0, 4, flip_right) + place(XformXoff, XformYoff, 0, 5, flip_left) + place(XformXoff, XformYoff, 1, 4, flip_vert) + place(XformXoff, XformYoff, 1, 5, flip_horiz) + place(XformXoff, XformYoff, 0, 7, rotate_90) + place(XformXoff, XformYoff, 0, 8, rotate_m90) + place(XformXoff, XformYoff, 1, 7, rotate_180) + place(XformXoff, XformYoff, 0, 10, clear) + place(XformXoff, XformYoff, 1, 10, invert) + place(XformXoff, XformYoff, 2, 10, scramble) + place(XformXoff, XformYoff, 0, 12, trim) + place(XformXoff, XformYoff, 1, 12, enlarge) + place(XformXoff, XformYoff, 2, 12, resize) + place(XformXoff, XformYoff, 0, 14, crop) + + place(SymmetXoff, SymmetYoff, 0, 0, hi_ident) + place(SymmetXoff, SymmetYoff, 1, 0, rotate_90) + place(SymmetXoff, SymmetYoff, 2, 0, rotate_m90) + place(SymmetXoff, SymmetYoff, 3, 0, rotate_180) + place(SymmetXoff, SymmetYoff, 0, 1, flip_right) + place(SymmetXoff, SymmetYoff, 1, 1, flip_left) + place(SymmetXoff, SymmetYoff, 2, 1, flip_vert) + place(SymmetXoff, SymmetYoff, 3, 1, flip_horiz) + + return + +end + +# invert bits on current pattern + +procedure invert() + + rows := pinvert(rows) + + return + +end + +# place icon + +procedure place(xoff, yoff, col, row, pattern) + +# Pattern(pattgc, pattern) +# FillRectangle(pattgc, xoff + col * IconSize, + DrawImage(pattgc, xoff + col * IconSize, + yoff + row * IconSize, pattern) + + return + +end + +# terminate session + +# read pattern specification + +procedure read_pattern(file) + local line + + line := readpattline(file) | fail + + return pattrec(legaltile(getpatt(line)), getpattnote(line)) + +end + +# read and add tile to tile list + +procedure read_tile() + local input, tile + static file, line + + initial line := "1" + + repeat { + if TextDialog("Read tile:", ["file", "line"], [file, line], [60, 4]) == "Cancel" then fail + input := open(dialog_value[1]) | { + Notice("Cannot open file.") + next + } + file := dialog_value[1] + line := (0 < integer(dialog_value[2])) + every 1 to line - 1 do + read(input) | { + Notice("Not that many lines in file.") + close(input) + next + } + tile := read_pattern(input) | { + Notice("Cannot process matrix.") + close(input) + next + } + close(input) + rows := pat2rows(tile.tile) + return setup() + } + +end + +# scramble bits of current tile + +procedure bscramble() + + rows := pscramble(rows, "b") + + return + +end + +# set bits of tile + +procedure setbit(i, j, c) + local x, y, xu, yu, xv, yv, xt, yt, action + + if (symmetries = 0) & (rows[i + 1, j + 1] == c) then return # optimization + + x := GridXoff + j * cellsize + 1 # the selected cell itself + y := GridYoff + i * cellsize + 1 + xt := GridXoff + i * cellsize + 1 + yt := GridYoff + j * cellsize + 1 + + i +:= 1 # for computational convenience + j +:= 1 + + xu := GridXoff + (hbits - j) * cellsize + 1 # opposite cells + yu := GridYoff + (vbits - i) * cellsize + 1 + xv := GridXoff + (hbits - i) * cellsize + 1 + yv := GridYoff + (vbits - j) * cellsize + 1 + + action := if c = 1 then FillRectangle else EraseArea + + if sym_state[1, 1] = 1 then { # cell itself + rows[i, j] := c + action(x, y, cellsize - 1, cellsize - 1) + } + if sym_state[1, 2] = 1 then { # 90 degrees + if rows[j, -i] := c then # may be out of bounds + action(xv, yt, cellsize - 1, cellsize - 1) + } + if sym_state[1, 3] = 1 then { # -90 degrees + if rows[-j, i] := c then # may be out of bounds + action(xt, yv, cellsize - 1, cellsize - 1) + } + if sym_state[1, 4] = 1 then { # 180 degrees + rows[-i, -j] := c + action(xu, yu, cellsize - 1, cellsize - 1) + } + if sym_state[2, 1] = 1 then { # left diagonal + if rows[j, i] := c then # may be out of bounds + action(xt, yt, cellsize - 1, cellsize - 1) + } + if sym_state[2, 2] = 1 then { # right diagonal + if rows[-j, -i] := c then # may be out of bounds + action(xv, yv, cellsize - 1, cellsize - 1) + } + if sym_state[2, 3] = 1 then { # vertical + rows[-i, j] := c + action(x, yu, cellsize - 1, cellsize - 1) + } + if sym_state[2, 4] = 1 then { # horizontal + rows[i, -j] := c + action(xu, y, cellsize - 1, cellsize - 1) + } + + return + +end + +# set up editing grid and view area + +procedure setup() + local i, j + + hbits := *rows[1] + vbits := *rows + + if (hbits | vbits) > 80 then { # based on cell size >= 3 + Notice("Dimensions too large") + fail + } + if hbits > MaxPatt then mode := &null # too large for pattern + + cellsize := MaxCell # cell size on window + cellsize >:= GridSize / (vbits + 4) + cellsize >:= GridSize / (hbits + 4) + + grid() + + every i := 1 to hbits do + every j := 1 to vbits do + if rows[j, i] == "1" then + FillRectangle(GridXoff + (i - 1) * cellsize, + GridYoff + (j - 1) * cellsize, cellsize, cellsize) + + return + +end + +# keyboard shortcuts + +procedure shortcuts(e) + + if &meta then case map(e) of { + "c" : copy_tile() + "i" : tile_info() + "n" : new_tile() + "p" : paste_tile() + "q" : exit() + "r" : read_tile() + "z" : undo_xform() + "w" : write_tile() + } + + return + +end + +# return number of bits set in tile for sorting + +procedure tile_bits(x) + + return tilebits(pat2rows(x.tile)) + +end + +# show information about tile + +procedure tile_info() + local line1, line2, pattern, bits, density + + pattern := rows2pat(rows) + bits := tilebits(rows) + density := left(bits / real(*rows[1] * *rows), 6) + + line1 := left(*rows[1] || "x" || *rows || " b=" || bits || " d=" || + density, InfoLength) + line2 := if *pattern > InfoLength then pattern[1+:(InfoLength - 3)] || + "..." else left(pattern, InfoLength) + + Notice(line1, line2) + + return + +end + +# return tile size for sorting + +procedure tile_size(x) + local dims + + dims := tiledim(x.tile) + + return dims.w * dims.h + +end + +# undo transformation + +procedure undo_xform() + + rows := pat2rows(old_pat) + + return setup() + +end + +# write pattern + +procedure write_pattern(file, pattern) + + write(file, pattern.tile) + + return + +end + +# write tile + +procedure write_tile() + local output + + repeat { + if SaveDialog("Write tie-up") == "Cancel" then fail + output := open(dialog_value, "w") | { + Notice("Cannot open file for writing.") + next + } + write_pattern(output, pattrec(rows2pat(rows))) + close(output) + return + } + +end + +# handle transformation + +procedure xform(col, row) + local result + static params + + tile_touched := 1 + + return case col of { + 0: case row of { + 1: pshift(rows, -1, "h") + 4: pflip(rows, "r") + 5: pflip(rows, "l") + 7: protate(rows, 90) + 8: protate(rows, -90) + 10: list(vbits, repl("0", hbits)) + 12: ptrim(rows) + 14: { + if /allxform then { + case Dialog("Crop:", ["left", "right", "top", "bottom"], + 0, 3, ["Okay", "Cancel"]) of { + "Cancel": fail + "Okay": { + icheck(dialog_value) | fail + result := copy(params := dialog_value) + push(result, rows) + pcrop ! result + } + } + } + } + default: fail + } + 1: case row of { + 0: pshift(rows, -1, "v") + 2: pshift(rows, 1, "v") + 4: pflip(rows, "v") + 5: pflip(rows, "h") + 7: protate(rows, 180) + 10: pinvert(rows) + 12: { + if /allxform then { + case Dialog("Enlarge:", ["left", "right", "top", "bottom"], + 0, 3, ["Okay", "Cancel"]) of { + "Cancel": fail + "Okay": { + icheck(dialog_value) | fail + result := copy(params := dialog_value) + push(result, rows) + pborder ! result + } + } + } + } + default: fail + } + 2: case row of { + 1: pshift(rows, 1, "h") + 10: pscramble(rows, "b") + 12: { + if /allxform then { + case Dialog("Center:", ["width", "height"], [*rows[1], *rows], + 3, ["Okay", "Cancel"]) of { + "Cancel": fail + "Okay": { + icheck(dialog_value) | fail + result := copy(params := dialog_value) + push(result, rows) + pcenter ! result + } + } + } + } + default: fail + } + default: fail + } + +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=427,419", "bg=pale gray", "label=Penelope"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,427,419:Penelope",], + ["file:Menu:pull::0,0,36,21:file",file_cb, + ["read @R","write @W","copy @C","paste @P","quit @Q "]], + ["line1:Line:::27,22,427,22:",], + ["symmetries:Label:::25,340,70,13:symmetries",], + ["tile:Menu:pull::38,0,36,21:tile",tile_cb, + ["new @N","info @I"]], + ["transformations:Label:::5,33,105,13:transformations",], + ["symregion:Rect:grooved::25,367,70,38:",symmet_cb], + ["info:Rect:invisible::147,368,251,31:",], + ["xform:Rect:grooved::26,58,58,256:",xform_cb], + ["grid:Rect:grooved::145,58,251,256:",grid_cb], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/pat2tie.icn b/ipl/gpacks/weaving/pat2tie.icn new file mode 100644 index 0000000..e46a504 --- /dev/null +++ b/ipl/gpacks/weaving/pat2tie.icn @@ -0,0 +1,37 @@ +############################################################################ +# +# File: pat2tie.icn +# +# Subject: Program to convert patterns to tie-ups +# +# Author: Ralph E. Griswold +# +# Date: January 29, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ +# +# Links: patutils, tieutils +# +############################################################################ + +link patutils +link tieutils + +procedure main() + local tieup, pat, matrix + + while pat := read() do { + matrix := pat2rows(pat) + tieup := tie(*matrix[1], *matrix, matrix) + write(tier2string(tieup)) + } + +end diff --git a/ipl/gpacks/weaving/pdbmake.icn b/ipl/gpacks/weaving/pdbmake.icn new file mode 100644 index 0000000..bb0b1a9 --- /dev/null +++ b/ipl/gpacks/weaving/pdbmake.icn @@ -0,0 +1,60 @@ +############################################################################ +# +# File: paletier.icn +# +# Subject: Program to build programmer-defined palettes +# +# Author: Ralph E. Griswold +# +# Date: June 4, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program builds palette database (PDBs) from color lists. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: palettes, xcode +# +############################################################################ + +link palettes +link xcode + +record pdb(table) + +procedure main(args) + local file, input, clist, key_letters, line + + every file := !args do { + input := open(file) | { + write(&errout, "*** cannot open ", file) + next + } + clist := [] + every line := read(input) do { + line ?:= tab(upto('\t')) + put(clist, line) + } + close(input) + if *clist = 0 then { + write(&errout, "*** empty color list") + next + } + if *clist > 36 then key_letters := &cset + else key_letters := &digits || &letters + CreatePalette(file, key_letters[1:*clist + 1], clist) | + write(&errout, "*** CreatePalette() failed") + } + + xencode(pdb(palette_names), &output) + +end diff --git a/ipl/gpacks/weaving/pfd2gif.icn b/ipl/gpacks/weaving/pfd2gif.icn new file mode 100644 index 0000000..bffc5e2 --- /dev/null +++ b/ipl/gpacks/weaving/pfd2gif.icn @@ -0,0 +1,41 @@ +############################################################################ +# +# File: pfd2gif.icn +# +# Subject: Program to create woven image from pattern-form draft +# +# Author: Ralph E. Griswold +# +# Date: June 13, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads a pattern-form draft and creates a GIF image of the +# correspnding weave. If command-line arguments are given, they are +# used as atrtibutes for the window in which the woven image is created. +# +############################################################################ +# +# Links: weavegif, weavutil +# +############################################################################ + +link weavegif +link weavutil + +$include "weavdefs.icn" + +procedure main(attribs) + local i, pfd + + put(attribs, "canvas=hidden") + + pfd := expandpfd(readpfd(&input)) | stop("*** bad draft") + + WriteImage(weavegif(pfd, attribs), pfd.name || ".gif") + +end diff --git a/ipl/gpacks/weaving/pfd2gmr.icn b/ipl/gpacks/weaving/pfd2gmr.icn new file mode 100644 index 0000000..f3829f2 --- /dev/null +++ b/ipl/gpacks/weaving/pfd2gmr.icn @@ -0,0 +1,86 @@ +############################################################################ +# +# File: pfd2gmr.icn +# +# Subject: Program to convert weaving drafts to weaving grammars +# +# Author: Ralph E. Griswold +# +# Date: June 16, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program converts pattern-form drafts (pfds) to weave pattern +# grammars (wpgs). +# +############################################################################ +# +# Links: convert, weavutil +# +############################################################################ + +link convert +link weavutil + +procedure main() + local pfd, row, rows, unique, symbols, matrix, k, plan + + pfd := readpfd() | stop("*** missing or malformed pattern-form draft") + + plan := if \pfd.liftplan then martor(pfd.liftplan) else martor(pfd.tieup) + + rows := plan[1] # CRUDE; FIX IT + unique := plan[2] + + write("name:", pfd.name) + write("comment: ex pfd2wpg ", &dateline) + write("axiom:@") + write("gener:1") + write("@->H.R.A.E.P.K.S.T.U.L") + write("H->", pfd.threading) + write("R->", pfd.treadling) + write("A->", pfd.warp_colors) + write("E->", pfd.weft_colors) + write("P->", pfd.palette) + write("K->", pfd.colors) + write("S->", pfd.shafts) + write("T->", pfd.treadles) + if \pfd.liftplan then write("L->", rows) + else write("U->", rows) + write("end:") + write("name:", pfd.name, "_toks") + + every k := key(unique) do + write(unique[k], "->", radcon(k, 2, 16)) + + write("end:") + +end + +procedure martor(pat) + local matrix, unique, rows, symbols, row + + matrix := pat2tier(pat).matrix + + unique := table() + + rows := "" + + symbols := create !&lcase + + every row := !matrix do { + if /unique[row] then unique[row] := @symbols | { + write(&errout, *unique) + write(&errout, rows) + stop("*** out of symbols") + } + rows ||:= unique[row] + } + + return [rows, unique] + +end diff --git a/ipl/gpacks/weaving/pfd2ill.icn b/ipl/gpacks/weaving/pfd2ill.icn new file mode 100644 index 0000000..83acee2 --- /dev/null +++ b/ipl/gpacks/weaving/pfd2ill.icn @@ -0,0 +1,330 @@ +############################################################################ +# +# File: pfd2ill.icn +# +# Subject: Program to create weaving drafts +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This program creates Encapsulated PostScript for pattern-form drafts +# +# The following options are supported: +# +# -g draw grid lines on drawdown +# -h hold windows open in visible (-v) mode +# -i write image files +# -p add showpage for printing +# -s i cell size, default 6 +# -v show images during creation; default, don't +# +# +# Other options to be added include the control of layout and orientation. +# +# Names of pattern-form drafts are taken from the command line. For each, +# four Encapsulated PostScript files are created: +# +# <base name>_tieup.eps (if given) +# <base name>_liftplan.eps (if given) +# <base name>_threading.eps +# <base name>_treadling.eps +# <base name>_drawdown.eps +# <base name>_pattern.eps (colored "drawdown") +# +# Future plans call for handling "shaftplans" specifying what diagrams +# are wanted. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: basename, interact, options, psrecord, weavutil +# +############################################################################ + +link basename +link interact +link options +link psrecord +link weaving +link weavutil +link ximage + +global canvas +global cellsize +global gridlines +global hold +global images +global name +global printing +global weaving # current weaving draft + +$define CellSize 6 + +procedure main(args) + local opts, input, file + + opts := options(args, "ghips+v") + + if /opts["p"] then printing := 1 + images := opts["i"] + if \opts["v"] then { + canvas := "canvas=normal" + hold := opts["h"] # only if images are visible + } + else canvas := "canvas=hidden" + + gridlines := opts["g"] + + cellsize := \opts["s"] | CellSize + + while file := get(args) do { + input := open(file) | { + Notice("Cannot open " || file) + next + } + name := basename(file, ".pfd") + weaving := expandpfd(readpfd(input)) + weaving.tieup := pat2tier(weaving.tieup) + weaving.liftplan := pat2tier(\weaving.liftplan) + draw_panes() + close(input) + } + +end + +procedure clear_pane(win, n, m, size) + local x, y, width, height, save_fg + + width := n * size + 1 + height := m * size + 1 + + save_fg := Fg(win) + + Fg(win, "black") + + every x := 0 to width by size do + DrawLine(win, x, 0, x, height) + + every y := 0 to height by size do + DrawLine(win, 0, y, width, y) + + Fg(win, save_fg) + + return + +end + +procedure draw_panes() + local i, j, x, y, treadle, k, treadle_list, c, color + local tieup_win, threading_win, treadling_win, liftplan_win + local drawdown_win, pattern_win + + if \weaving.tieup then { + + tieup_win := WOpen(canvas, "width=" || (cellsize * weaving.treadles), + "height=" || (cellsize * weaving.shafts)) + + PSStart(tieup_win, name || "_tieup.eps") + + clear_pane(tieup_win, weaving.treadles, weaving.shafts, cellsize) + + every i := 1 to weaving.shafts do + every j := 1 to weaving.treadles do { + if weaving.tieup.matrix[j, i] == "1" then + fillcell(tieup_win, j, i, "black") + } + + PSDone(printing) + + if \images then WriteImage(tieup_win, name || "_tieup.gif") + + } + + if \weaving.liftplan then { + + liftplan_win := WOpen(canvas, "width=" || (cellsize * weaving.shafts), + "height=" || (cellsize * *weaving.treadling)) + + PSStart(liftplan_win, name || "_liftplan.eps") + + clear_pane(liftplan_win, weaving.shafts, *weaving.treadling, cellsize) + + every i := 1 to *weaving.treadling do + every j := 1 to weaving.treadles do { + if weaving.liftplan.matrix[i, j] == "1" then + fillcell(liftplan_win, j, i, "black") + } + + PSDone(printing) + + if \images then WriteImage(liftplan_win, name || "_liftplan.gif") + + } + + threading_win := WOpen(canvas, "width=" || (cellsize * *weaving.threading), + "height=" || (cellsize * (weaving.shafts))) + + PSStart(threading_win, name || "_threading.eps") + + clear_pane(threading_win, *weaving.threading, weaving.shafts + 1, cellsize) + + every i := 1 to *weaving.threading do + fillcell(threading_win, i, weaving.threading[i] + 1, "black") + + PSDone(printing) + + every i := 1 to *weaving.threading do + fillcell(threading_win, i, 1, PaletteColor(weaving.palette, + weaving.colors[sympos(weaving.warp_colors[i])])) + + if \images then WriteImage(threading_win, name || "_threading.gif") + + treadling_win := WOpen(canvas, "height=" || (cellsize * *weaving.treadling), + "width=" || (cellsize * (weaving.treadles))) + + PSStart(treadling_win, name || "_treadling.eps") + + clear_pane(treadling_win, weaving.treadles + 1, *weaving.treadling, cellsize) + every i := 1 to *weaving.treadling do + fillcell(treadling_win, weaving.treadling[i] + 1, i, "black") + + PSDone(printing) + + every i := 1 to *weaving.treadling do + fillcell(treadling_win, 1, i, PaletteColor(weaving.palette, + weaving.colors[sympos(weaving.warp_colors[i])])) + + if \images then WriteImage(treadling_win, name || "_treadling.gif") + + pattern_win := WOpen(canvas, "width=" || (cellsize * *weaving.threading), + "height=" || (cellsize * *weaving.treadling)) + + PSStart(pattern_win, name || "_pattern.eps") + + clear_pane(pattern_win, weaving.shafts, weaving.treadles, cellsize) + + if *cset(weaving.warp_colors) = 1 then { # warp solid black + Fg(pattern_win, PaletteColor(weaving.palette, + weaving.colors[sympos(weaving.warp_colors[1])])) + FillRectangle(pattern_win, 0, 0, *weaving.threading * cellsize, + *weaving.treadling * cellsize) + } + else { + every i := 0 to *weaving.threading - 1 do { # warp striped + Fg(pattern_win, PaletteColor(weaving.palette, + weaving.colors[sympos(weaving.warp_colors[i + 1])])) + FillRectangle(pattern_win, i * cellsize, 0, cellsize - 1, + *weaving.treadling * cellsize) + } + } + + Fg(pattern_win, "black") + + treadle_list := list(weaving.treadles) + every !treadle_list := [] + + every i := 1 to weaving.treadles do + every j := 1 to weaving.shafts do + if weaving.tieup.matrix[i, j] == "1" then + every k := 1 to *weaving.threading do + if sympos(weaving.threading[k]) == j then + put(treadle_list[i], k, 0) + + every y := 1 to *weaving.treadling do { + treadle := sympos(weaving.treadling[y]) + + color := PaletteColor(weaving.palette, + weaving.colors[sympos(weaving.weft_colors[y])]) + if *treadle_list[treadle] = 0 then next # blank pick + every i := 1 to *treadle_list[treadle] by 2 do + fillcell(pattern_win, treadle_list[treadle][i], y, color) + } + + Fg(pattern_win, "black") + + if \gridlines then { + every x := 0 to WAttrib(pattern_win, "width") by cellsize do + DrawLine(pattern_win, x, 0, x, WAttrib(pattern_win, "height")) + every y := 0 to WAttrib(pattern_win, "height") by cellsize do + DrawLine(pattern_win, 0, y, WAttrib(pattern_win, "width"), y) + } + + PSDone(printing) + + if \images then WriteImage(pattern_win, name || "_pattern.gif") + + drawdown_win := WOpen(canvas, "width=" || (cellsize * *weaving.threading), + "height=" || (cellsize * *weaving.treadling)) + + PSStart(drawdown_win, name || "_drawdown.eps") + + clear_pane(drawdown_win, weaving.shafts, weaving.treadles, cellsize) + + Fg(drawdown_win, "black") + + FillRectangle(drawdown_win, 0, 0, *weaving.threading * cellsize, + *weaving.treadling * cellsize) + + treadle_list := list(weaving.treadles) + every !treadle_list := [] + + every i := 1 to weaving.treadles do + every j := 1 to weaving.shafts do + if weaving.tieup.matrix[i, j] == "1" then + every k := 1 to *weaving.threading do + if sympos(weaving.threading[k]) == j then + put(treadle_list[i], k, 0) + + every y := 1 to *weaving.treadling do { + treadle := sympos(weaving.treadling[y]) + if *treadle_list[treadle] = 0 then next # blank pick + every i := 1 to *treadle_list[treadle] by 2 do + fillcell(drawdown_win, treadle_list[treadle][i], y, "white") + } + + Fg(drawdown_win, "black") + + if \gridlines then { + every x := 0 to WAttrib(drawdown_win, "width") by cellsize do + DrawLine(drawdown_win, x, 0, x, WAttrib(drawdown_win, "height")) + every y := 0 to WAttrib(drawdown_win, "height") by cellsize do + DrawLine(drawdown_win, 0, y, WAttrib(drawdown_win, "width"), y) + } + + PSDone(printing) + + if \images then WriteImage(drawdown_win, name || "_drawdown.gif") + + if \hold then { + repeat { + if Event(Active()) === "q" then break + } + } + + every WClose(tieup_win | \liftplan_win | threading_win | treadling_win | + pattern_win, drawdown_win) + + return + +end + +procedure fillcell(win, n, m, color) + local save_fg + + save_fg := Fg(win) + Fg(win, color) + + FillRectangle(win, (n - 1) * cellsize, (m - 1) * cellsize, cellsize, + cellsize) + + Fg(win, save_fg) + + return + +end diff --git a/ipl/gpacks/weaving/pfd2wif.icn b/ipl/gpacks/weaving/pfd2wif.icn new file mode 100644 index 0000000..398eed3 --- /dev/null +++ b/ipl/gpacks/weaving/pfd2wif.icn @@ -0,0 +1,147 @@ +############################################################################ +# +# File: pfd2wif.icn +# +# Subject: Program to produce WIF from PFD +# +# Author: Ralph E. Griswold +# +# Date: June 13, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces a WIF from a pattern-form draft. +# +############################################################################ +# +# Links: weavutil +# +############################################################################ + +link weavutil + +procedure main() + local pfd, i, lift_table, line + + pfd := readpfd(&input) | stop("*** cannot read pfd") + + if \pfd.liftplan then { + lift_table := table() + i := 0 + pfd.liftplan ? { + while line := tromp(move(pfd.shafts)) do { + i +:= 1 + lift_table[sympos(i)] := line + } + } + } + + write("[WIF]") + write("Version=1.1") + write("Date=" || &dateline) + write("Developers=ralph@cs.arizona.edu") + write("Source Program=pfd2wif.icn") + + write("[CONTENTS]") + write("Color Palette=yes") + write("Text=yes") + write("Weaving=yes") + write("Tieup=yes") + write("Color Table=yes") + write("Threading=yes") + if /pfd.liftplan then write("Treadling=yes") + write("Warp colors=yes") + write("Weft colors=yes") + write("Warp=yes") + write("Weft=yes") + if \pfd.liftplan then write("Liftplan=yes") + + write("[COLOR PALETTE]") + write("Entries=", *pfd.colors) + write("Form=RGB") + write("Range=0," || 2 ^ 16 - 1) + + write("[TEXT]") + write("Title=", pfd.name) + write("Author=Ralph E. Griswold") + write("Address=5302 E. 4th St., Tucson, AZ 85711-2304") + write("EMail=ralph@cs.arizona.edu") + write("Telephone=520-881-1470") + write("FAX=520-325-3948") + + write("[WEAVING]") + write("Shafts=", pfd.shafts) + write("Treadles=", pfd.treadles) + write("Rising shed=yes") + + write("[WARP]") + write("Threads=", *pfd.threading) + write("Units=Decipoints") + write("Thickness=10") + + write("[WEFT]") + write("Threads=", *pfd.treadling) + write("Units=Decipoints") + write("Thickness=10") + + # These are provided to produce better initial configurations when + # WIFs are imported to some weaving programs. + + write("[WARP THICKNESS]") + write("[WEFT THICKNESS]") + + write("[COLOR TABLE]") + + every i := 1 to *pfd.colors do + write(i, "=", PaletteColor(pfd.palette, pfd.colors[i])) + + write("[THREADING]") + every i := 1 to *pfd.threading do + write(i, "=", sympos(pfd.threading[i])) + + if /pfd.liftplan then { + write("[TREADLING]") + every i := 1 to *pfd.treadling do + write(i, "=", sympos(pfd.treadling[i])) + } + + write("[WARP COLORS]") + every i := 1 to *pfd.warp_colors do + write(i, "=", sympos(pfd.warp_colors[i])) + + write("[WEFT COLORS]") + every i := 1 to *pfd.weft_colors do + write(i, "=", sympos(pfd.weft_colors[i])) + + write("[TIEUP]") + pat2tie(pfd.tieup) ? { + every i := 1 to pfd.treadles do + write(i, "=", tromp(move(pfd.shafts))) + } + + if *\pfd.liftplan > 0 then { + write("[LIFTPLAN]") + pat2tie(pfd.liftplan) ? { + every i := 1 to *pfd.treadling do + write(i, "=", lift_table[pfd.treadling[i]]) + } + } + +end + +procedure tromp(treadle) + local result + + result := "" + + treadle ? { + every result ||:= upto("1") || "," + } + + return result[1:-1] + +end diff --git a/ipl/gpacks/weaving/plexity.icn b/ipl/gpacks/weaving/plexity.icn new file mode 100644 index 0000000..3ae788e --- /dev/null +++ b/ipl/gpacks/weaving/plexity.icn @@ -0,0 +1,157 @@ +############################################################################ +# +# File: plexity.icn +# +# Subject: Program to count distinct weaves +# +# Author: Ralph E. Griswold +# +# Date: April 6, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program counts the distinct weaves with k color, m warp threads, +# and n wft threads. +# +# The options supported are: +# +# -k i number of colors; default 2 (the maximum supported is 10) +# -m i number of warp threads (columns); default 2 +# -n i number of weft threads (rows); default 2 +# +# To allow k up to 10 (temporary), the representation of colors goes +# from 0 to k - 1. +# +############################################################################ +# +# Links: imxform, options +# +############################################################################ + +link imxform +link options + +global symlist + +procedure main(args) + local opts, k, m, n + + opts := options(args, "k+n+m+") + + k := \opts["k"] | 2 + m := \opts["m"] | 2 + n := \opts["n"] | 2 + + syminit(m, n) + + plexity(k, m, n) + +end + +# weaves for k combinations on an m-by-n grid +# +# presently limited to 10 combinations ... + +procedure plexity(k, m, n) + local warps, wefts, boards, weaves, test + + warps := [] + every put(warps, combinations(k, m)) + + wefts := [] + every put(wefts, combinations(k, n)) + + boards := [] + every put(boards, combinations(2, n * m)) + + weaves := set() + + every test := weave(!warps, !wefts, !boards) do + if not member(weaves, symmetries(test)) then + insert(weaves, test) + + write(*weaves) + +end + +procedure combinations(k, n) #: all combinations of k characters n times + + if n = 0 then return "" + + suspend (0 to k - 1) || combinations(k, n - 1) + +end + +procedure weave(warp, weft, board) + local i, j, weaving, row + + weaving := "" + j := 0 + + board ? { + while row := move(*warp) do { + j +:= 1 + every i := 1 to *row do { + if row[i] == "0" then row[i] := weft[j] else row[i] := warp[i] + } + weaving ||:= row + } + } + + return weaving + +end + +procedure syminit(m, n) + local str, rows + + str := "" + + every str ||:= !&letters \ (m * n) + + symlist := [str] + + rows := str2rows(str, m, n) + + every 1 to 3 do put(symlist, rows2str(rows := imxrotate(rows, "cw"))) + + return + +end + +procedure symmetries(weave) + + suspend map(symlist[1], !symlist, weave) + +end + +procedure str2rows(str, m, n) + local rows, i + + rows := list(n) + + i := 1 + + str ? { + while rows[i] := move(m) do + i +:= 1 + } + + return rows + +end + +procedure rows2str(rows) + local str + + str := "" + + every str ||:= !rows + + return str + +end diff --git a/ipl/gpacks/weaving/plotgrid.icn b/ipl/gpacks/weaving/plotgrid.icn new file mode 100644 index 0000000..df32112 --- /dev/null +++ b/ipl/gpacks/weaving/plotgrid.icn @@ -0,0 +1,194 @@ +############################################################################ +# +# File: plotgrid.icn +# +# Subject: Program to create grid plots for sequence drafts +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This program produces grid plots as specificed in the include +# file, include.wvp, which is produced by seqdraft.icn. +# +############################################################################ +# +# Requires: Version 9 graphics and large integers +# +############################################################################ +# +# Links: cells, convert, expander, weaving, weavutil, lists, mirror, +# tieutils, wopen, numbers, weaveseq +# +############################################################################ +# +# Note: The include file may contain link declarations. +# +############################################################################ + +link convert +link expander +link weaving +link weavutil +link lists +link mirror +link numbers +link tieutils +link wopen +link weaveseq + +$include "include.wvp" + +$ifdef Link +Link +$endif + +global cmod +global colors +global height +global shafts +global width +global threading +global tieup +global tieups +global treadling +global treadles +global warp_colors +global weft_colors + +$define CellSize 4 + +procedure main() + + init() + + plot() + +end + +# Initialize the weaving. + +procedure init() + local m, n, v + + shafts := Shafts + treadles := Treadles + + colors := Colors + + height := Length + width := Breadth + + threading := [] + every put(threading, |sconvert(Threading, shafts)) \ width + + treadling := [] + every put(treadling, |sconvert(Treadling, treadles)) \ height + + warp_colors := [] + every put(warp_colors, |sconvert(WarpColors, *colors)) \ width + + weft_colors := [] + every put(weft_colors, |sconvert(WeftColors, *colors)) \ height + +$ifdef Reflect + threading |||:= lreverse(threading[1:-1]) + treadling |||:= lreverse(treadling[1:-1]) + warp_colors |||:= lreverse(warp_colors[1:-1]) + weft_colors |||:= lreverse(weft_colors[1:-1]) + width := 2 * width - 1 + height := 2 * height - 1 +$endif + +$ifdef DeBug + write(image(threading)) + write(image(treadling)) + write(image(warp_colors)) + write(image(weft_colors)) +$endif + + tieup := tie2tier(shafts, treadles, Tieup).matrix + + return + +end + +# Create the plots. + +procedure plot() + local threading_pane, warp_pane, treadling_pane, weft_pane, tieup_pane + local tr_width, th_width, tr_height, th_height, comp, i, j + + threading_pane := makepanel(*threading, shafts, CellSize) + + every i := 1 to *threading do + colorcell(threading_pane, i, threading[i], "black") + + WAttrib(threading_pane.window, "label=threading sequence") + + th_width := WAttrib(threading_pane.window, "width") + th_height := WAttrib(threading_pane.window, "height") + + warp_pane := makepanel(*warp_colors, shafts, CellSize) + + every i := 1 to *warp_colors do + colorcell(warp_pane, i, warp_colors[i], "black") + + treadling_pane := makepanel(treadles, *treadling, CellSize) + + tr_width := WAttrib(treadling_pane.window, "width") + tr_height := WAttrib(treadling_pane.window, "height") + + every i := 1 to *treadling do + colorcell(treadling_pane, treadles - treadling[i] + 1, i, "black") + + weft_pane := makepanel(treadles, *weft_colors, CellSize) + + every i := 1 to *weft_colors do + colorcell(weft_pane, treadles - weft_colors[i] + 1, i, "black") + + tieup_pane := makepanel(treadles, shafts, CellSize) + + every i := 1 to shafts do + every j := 1 to treadles do + if tieup[j, i] == "1" then + colorcell(tieup_pane, j, i, "black") + + comp := WOpen( + "canvas=hidden", + "width=" || (2 * tr_width + th_width), + "height=" || (2 * th_height + tr_height) + ) | stop("cannot open comp window") + + CopyArea(threading_pane.window, comp, , , , , tr_width, 0) + CopyArea(treadling_pane.window, comp, , , , , 0, th_height) + CopyArea(warp_pane.window, comp, , , , , tr_width, tr_height + th_height) + CopyArea(weft_pane.window, comp, , , , , th_width + tr_width, th_height) + CopyArea(tieup_pane.window, comp, , , , , 0, 0) + + WAttrib(comp, "canvas=normal") + + WDone(comp) + + return + +end + +procedure shortcuts(e) + + if &meta then case map(e) of { + "q" : exit() + "w" : weave() + } + + return + +end + +procedure sconvert(s, n) + + return abs(integer(s) % n) + 1 + +end diff --git a/ipl/gpacks/weaving/plugger.icn b/ipl/gpacks/weaving/plugger.icn new file mode 100644 index 0000000..8f20fec --- /dev/null +++ b/ipl/gpacks/weaving/plugger.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: plugger.icn +# +# Subject: Program to plug holes in body include file +# +# Author: Ralph E. Griswold +# +# Date: November 17, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. +# +############################################################################ + +$define LINK "\"GIF/bgener/bgener002.gif\"" +$define THUMB "\"Blocks/ad_hoc1_thumb.gif\"" + +procedure main() + + write("body := [") + + while line := read() do { + if find(LINK, line) then { + line ? { + write(image(tab(find(LINK))), ",") + move(*LINK) + write(",") + write(image(tab(find(THUMB))), ",") + move(*THUMB) + write(",") + write(image(tab(0)), ",") + } + } + else write(image(line), ",") + } + + write("]") + +end diff --git a/ipl/gpacks/weaving/randweav.icn b/ipl/gpacks/weaving/randweav.icn new file mode 100644 index 0000000..b6f0463 --- /dev/null +++ b/ipl/gpacks/weaving/randweav.icn @@ -0,0 +1,254 @@ +############################################################################ +# +# File: randweav.icn +# +# Subject: Program to create random weavable patterns +# +# Author: Gregg M. Townsend +# +# Date: April 6, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Randweav is an interactive program for generating random +# weavable patterns. The top and left rows of the displayed +# pattern are a "key" to the vertical and horizontal threads +# of an imaginary loom. The colors of the other cells are chosen +# so that each matches either the vertical or horizontal thread +# with which it is aligned. +# +# The interactive controls are as follows: +# +# Colors Specifies the number of different colors from which +# the threads are selected. +# +# If "cycle warp" is checked, the vertical thread colors +# repeat regularly. If "cycle weft" is checked, the +# horizontal thread colors repeat regularly. +# +# RENDER When pressed, generates a new random pattern. +# Pressing the Enter key or space bar does the same thing. +# +# Side Specifies the number of threads along each side +# of the pattern. The pattern is always square. +# +# Bias Specifies as a percentage the probability that the +# vertical thread will determine the color of a pixel. +# +# If "perfect" is checked, vertical and horizontal +# threads alternate perfectly, ignoring the bias value. +# +# Save Brings up a dialog for saving the pattern as an image. +# +# Quit Exits the program. +# +# Note that the mouse must be over a numeric field to type in +# a new value. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: random, vsetup +# +############################################################################ + +link random +link vsetup + + +global vidgets # table of vidgets +global root # root vidget +global region # pattern region + +global hidwin # hidden window for saving to file + +global allcolors # string of all palette colors + +global maxsiz # maximum pattern size +global patsize # pattern size selected + +$define PALETTE "c1" # color palette +$define PREFCOLORS "06NBCDFsHIJM?!" # preferred colors + + +procedure main(args) + + randomize() + allcolors := PREFCOLORS || (PaletteChars(PALETTE) -- PREFCOLORS) + + Window ! put(ui_atts(), args) # open window + vidgets := ui() # set up vidgets + root := vidgets["root"] + region := vidgets["region"] + VSetState(vidgets["vcyclic"], 1) # default "cycle warp" on + VSetState(vidgets["hcyclic"], 1) # default "cycle weft" on + + hidwin := WOpen("canvas=hidden", # open hidden window + "width=" || region.uw, "height=" || region.uh) + + maxsiz := region.uw # set maximum size + maxsiz >:= region.uh + + render() # draw once without prompting + GetEvents(root, , all) # then wait for events +end + + +# all(a, x, y) -- process all events, checking for keyboard shortcuts + +procedure all(a, x, y) + if a === !" \n\r" then render() # draw new pattern for SPACE, CR, LF + else if &meta then case a of { + !"qQ": exit() # exit for @Q + !"sS": save() # save image for @S + } + return +end + + +# render() -- draw a new pattern according to current parameters + +procedure render() + local ncolors, bias + local s, x, y, w, h, z, k + static prevsize + + ncolors := txtval("colors", 1, *allcolors) # retrieve "Colors" setting + patsize := txtval("side", 1, maxsiz) # retrieve "Side" setting + bias := txtval("bias", 0, 100) # retrieve "Bias" setting + + k := (shuffle(PREFCOLORS) | allcolors)[1+:ncolors] # pick a color set + s := genpatt(patsize, k, bias / 100.0) # generate a pattern + DrawImage(hidwin, 0, 0, s) # draw on hidden win + + z := maxsiz / patsize # calculate scaling + x := region.ux + (region.uw - z * patsize) / 2 + y := region.uy + (region.uh - z * patsize) / 2 + + # copy to main window with enlargement + if prevsize ~===:= patsize then + EraseArea(region.ux, region.uy, region.uw, region.uh) # erase old pattern + Zoom(hidwin, &window, 0, 0, patsize, patsize, x, y, z * patsize, z * patsize) + + return +end + + +# genpatt(size, colors, bias) -- generate a new pattern as DrawImage() string + +procedure genpatt(size, colors, bias) + local warp, weft, perfect, s, x, y, w + + # choose thread colors + warp := genthreads(size, colors, VGetState(vidgets["vcyclic"])) + weft := genthreads(size, colors, VGetState(vidgets["hcyclic"])) + + # initialize output string (including first row) + s := size || "," || PALETTE || "," || warp + + perfect := VGetState(vidgets["perfect"]) + + # fill in remaining rows + every y := 2 to size do { + w := ?weft[y] # get weft color + s ||:= w # put in first column + if \perfect then + every x := 2 to size do # fill the rest (perfect case) + s ||:= if ((x + y) % 2) = 0 then w else warp[x] + else + every x := 2 to size do # fill the rest (random case) + s ||:= if ?0 > bias then w else warp[x] + } + + return s +end + + +# genthreads(n, colors, cyclic) -- generate a set of warp or weft threads + +procedure genthreads(n, colors, cyclic) + local s + + if \cyclic then + return repl(shuffle(colors), 1 + n / *colors)[1+:n] + + s := "" + every 1 to n do s ||:= ?colors + return s +end + + + +# txtval(s, min, max) -- get numeric value from named vidget and clamp to range + +procedure txtval(s, min, max) + local v, n + + v := vidgets[s] # find the vidget + VEvent(v, "\r", v.ax, v.ay) # set RETURN event to update state + n := integer(VGetState(v)) | min # retrieve int value, else use minimum + n <:= min # limit value by min and max + n >:= max + VSetState(v, n) # update vidget with validated value + return n # return value +end + + +# save() -- present dialog box and save pattern as image file + +procedure save() + local g + + g := WAttrib("gamma") # save old gamma value + WAttrib("gamma=1.0") # don't gamma-correct on write + repeat case OpenDialog("Save pattern as:") of { + "Cancel": { + WAttrib("gamma=" || g) + fail + } + "Okay": { + if WriteImage(hidwin, dialog_value, 0, 0, patsize, patsize) then + break + else + Notice("cannot write file:", dialog_value) + } + } + WAttrib("gamma=" || g) # restore gamma value + return +end + + +procedure quit() + exit() +end + + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=380,492", "bg=pale gray", "label=weaver"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,380,492:weaver",], + ["bias:Text::3:285,37,87,19:Bias: \\=60",], + ["colors:Text::3:10,9,87,19:Colors: \\=6",], + ["hcyclic:Button:checkno:1:5,56,97,20:cycle weft",], + ["perfect:Button:checkno:1:281,57,76,20:perfect",], + ["quit:Button:regular::293,462,78,20:quit @Q",quit], + ["render:Button:regular::159,24,72,36:RENDER",render], + ["save:Button:regular::8,462,78,20:save @S",save], + ["side:Text::3:285,8,87,19:Side: \\=90",], + ["vcyclic:Button:checkno:1:5,36,97,17:cycle warp",], + ["outline:Rect:sunken::153,18,84,48:",], + ["region:Rect:grooved::8,84,364,364:",], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/sdb2wvp.icn b/ipl/gpacks/weaving/sdb2wvp.icn new file mode 100644 index 0000000..46f9d2c --- /dev/null +++ b/ipl/gpacks/weaving/sdb2wvp.icn @@ -0,0 +1,51 @@ +############################################################################ +# +# File: sdb2wvp.icn +# +# Subject: Program to convert sequence-draft data bases to include files +# +# Author: Ralph E. Griswold +# +# Date: May 23, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. +# +# Command-line arguments are converted into $defines in the output. +# +############################################################################ +# +# Links: basename, weavutil, io, tables, xcode +# +############################################################################ + +link basename +link weavutil +link io +link tables +link xcode + +procedure main(args) + local line, output, path, database, spec, name + + weaving2 # mention to prevent deletion + + database := xdecode(&input) | stop("*** cannot decode input") + + put(args, "Background", "Reflect") # run in background + + every spec := database[!keylist(database)] do { + name := spec.name || ".wvp" + output := open(name, "w") | + stop("*** cannot open ", name, " for writing") + every write(output, "$define ", !args) + close(output) + write_spec(name, spec) + } + +end diff --git a/ipl/gpacks/weaving/seqdraft.icn b/ipl/gpacks/weaving/seqdraft.icn new file mode 100644 index 0000000..08eafc4 --- /dev/null +++ b/ipl/gpacks/weaving/seqdraft.icn @@ -0,0 +1,1878 @@ +############################################################################ +# +# File: seqdraft.icn +# +# Subject: Program to create sequence-based weaving drafts +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This is a program forcreating sequence-based weaving drafts. +# +# To create a woven image from a draft, it writes an include file and then +# compiles and executes seqweave.icn, which includes this file, to produce +# the image. +# +############################################################################ +# +# Requires: Version 9 graphics, system(), /tmp, gridplot.icn and +# seqweave.icn. +# +############################################################################ +# +# Links: weavutil, interact, io, tables, vsetup, xcode, weaving, expander, +# ximage, palettes, patutils +# +############################################################################ +# +link expander +link interact +link io +link navitrix +link palettes +link patutils +link tables +link vsetup +link weaving +link weavutil +link xcode +link ximage + +global db_entries # list of specifications in database +global sdb_file # name of database file +global database # database of specifications +global def_entries # list of definitions +global open_proc # procedure needing navitrix +global spec # current specification +global touched # database changed switch +global vidgets # table of interface tools +global symmetry # symmetry vidget + +global current_db +global current_lib +global defn_db +global expr_db +global plte_db +global ties_db +global defn_lib +global expr_lib +global plte_lib +global ties_lib + +global lib_procs +global lib_type +global defn_procs +global expr_procs +global plte_procs +global ties_procs +global read_def, write_def, paste_def, copy_def, new_tie +global display_tie, display_def, read_pal, write_pal, paste_pal, copy_pal +global display_pal + +record procs(new, read, write, copy, paste, display) +record pdb(table) + +$define NameDefault "untitled_01" +$define ThreadingDefault "seq(0)" +$define TreadlingDefault "seq(0)" # treadled as drawn in +$define WarpColorsDefault "seq(0)" +$define WeftColorsDefault "seq(0)" +$define BreadthDefault "128" +$define LengthDefault "128" +$define ShaftsDefault "10" +$define TreadlesDefault "10" +$define LinksDefault [] +$define PaletteDefault "g2" +$define ColorsDefault "PaletteChars(Palette)" + +$define DefWidth 120 # width of definition field +$define ExprWidth 120 # width of expression field +$define NameWidth 40 # width of name field +$define SymWidth 15 # width of definition field +$define FieldWidth (SymWidth + 1) + +procedure main() + local root, root_cur, shortcuts_cur, process + + nav_init() + + init() + + root := vidgets["root"] + + repeat { # event loop + case Active() of { + &window : { + root_cur := root + shortcuts_cur := shortcuts + process := "weavport" + } + nav_window : { + root_cur := nav_root + shortcuts_cur := nav_keyboard + process := "navitrix" + } + } + ProcessEvent(root_cur, , shortcuts_cur) + case process of { + "weavport" : next + "navitrix" : { + case nav_state of { + "Cancel" : nav_state := &null + "Okay" : { + open_proc() + nav_state := &null + } + default : next + } + WAttrib(nav_window, "canvas=hidden") + } + } + process := "weavport" + } + +end + +# Set parameters for smooth blend + +procedure blend_spec() + + spec.colors := "PaletteChars(Palette)" + spec.warp_colors := "seq(0)" + spec.weft_colors := "seq(0)" + + palette() + + return + +end + +# Clear the table of definitions. + +procedure clear_defs() + + if AskDialog("Do you really want to clear the definition table?") == + "No" then fail + + spec.defns := table() + refresh_lib() + + return + +end + +# Clear the database of specifications (a default one is then added). + +procedure clear_sdb() + + if AskDialog("Are you sure you want to clear the current database?") == + "No" then fail + + database := table() + + sdb_file := &null + + new_spec() + + refresh_sdb() + + return + +end + +procedure swapt_cb() + + spec.threading :=: spec.treadling + + refresh_sdb() + + return + +end + +procedure swapc_cb() + + spec.warp_colors :=: spec.weft_colors + + refresh_sdb() + + return + +end + +procedure color_writ_cb() + + spec.weft_colors := spec.warp_colors + + refresh_sdb() + + return + +end + +# Specify colors from palette + +procedure colors() + local input, line, c + static file, number + + repeat { + if TextDialog("Colors:", , spec.colors, ExprWidth) == "Cancel" then fail + spec.colors := dialog_value[1] + return + } + +end + +# Edit specification comments. + +procedure comments() + + repeat { + case TextDialog("Comments:", , spec.comments, ExprWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default" : { + spec.comments := &dateline # default comments + next + } + "Okay" : { + spec.comments := dialog_value[1] + break + } + } + } + + return + +end + +# Callback for selection of an item from the expressions text-list. + +procedure configuration_cb(vidget, value) + + case vidget.id of { + "drawdown" : drawdown_spec() + "blend" : blend_spec() + } + + return + +end + +procedure database_cb(vidget, value) + + case value[1] of { + "load @L" : open_file(load_db) + "save" : save_db() + "clear" : clear_db() + } + + return + +end + +procedure copy_tie() + local output + + output := open("/tmp/tieup", "w") | { + Notice("Cannot copy.") + fail + } + + write(output, spec.tieup) + + close(output) + + return + +end + +# Make the expression in the current dialog into a definition. + +procedure define(s) + + if TextDialog("Add definition:", ["name", "definition"], [, s], + [SymWidth, ExprWidth]) == "Cancel" then fail + + spec.defns[dialog_value[1]] := dialog_value[2] + refresh_lib() + + return + +end + +procedure dir_tieup_cb() + local row, i, tie + + row := "1" || repl("0", spec.shafts - 1) + + tie := row + + every i := 1 to spec.treadles - 1 do + tie ||:= rotate(row, -i) + + spec.tieup := tie2pat(spec.shafts, spec.treadles, tie) + + refresh_sdb() + + return + +end + +# Display all the current definitions. + +procedure display_defs() + local definition, lines, i + + if *def_entries = 0 then { + Notice("The definition table is empty.") + fail + } + + lines := [] + + every definition := !def_entries do + put(lines, left(definition, 12) || + left(spec.defns[definition], ExprWidth)) + + push(lines, "", "name definition ") + + Notice ! lines + + return + +end + +# Display a specification. + +procedure display_spec(dspec) + local lines, s, lst + + /dspec := spec + + lines := [ + "Specifications:", + "", + left("Name", FieldWidth) || dspec.name, + left("Breadth", FieldWidth) || dspec.breadth, + left("Length", FieldWidth) || dspec.length, + left("Shafts", FieldWidth) || dspec.shafts, + left("Treadles", FieldWidth) || dspec.treadles, + left("Threading", FieldWidth) || dspec.threading, + left("Treadling", FieldWidth) || dspec.treadling, + left("Warp Colors", FieldWidth) || dspec.warp_colors, + left("Weft Colors", FieldWidth) || dspec.weft_colors, + left("Tieup", FieldWidth) || dspec.tieup, + left("Palette", FieldWidth) || dspec.palette, + left("Colors", FieldWidth) || dspec.colors, + left("Comments", FieldWidth) || (\dspec.comments | "") + ] + + if *dspec.defns > 0 then { + put(lines, "", "Definitions:", "") + every put(lines, left(s := !keylist(dspec.defns), FieldWidth) || + (\dspec.defns[s] | "") \ 1) + } + + Notice ! lines + + return + +end + +# Set parameters for drawdown. + +procedure drawdown_spec() + + spec.palette := "g2" + spec.colors := image("01") + spec.warp_colors := "|0" + spec.weft_colors := "|1" + + return + +end + +# Duplicate the current specification and make it current. + +procedure dupl_spec() + local head, serial, count, i, name + static notdigit + + initial notdigit := &cset -- &digits + + spec.name ? { # SHOULD CHECK TO AVOID OVERWRITING EXISTING + i := 0 + every i := upto(notdigit) + head := tab(i) + head ||:= tab(many(notdigit)) + serial := tab(0) + if *serial = 0 then serial := 0 + count := serial + 1 + if *count <= *serial then count := right(count, *serial, "0") + else count := "1" || repl("0", *count - 1) + name := head || count + } | { + Notice("Name generation failed.") + fail + } + + repeat { + if \database[name] then { + case TextDialog("Name in use.", "new name", spec.name, 30) of { + "Cancel" : fail + "Okay" : { + name := dialog_value[1] + next + } + } + } + else break + } + + spec := copy(spec) + spec.name := name + spec.defns := copy(spec.defns) + + database[name] := spec + + refresh_lib() + + refresh_sdb() + + return + +end + +# Items for the File menu. + +procedure file_cb(vidgets, value) + + case value[1] of { + "generate" : weaveit() + "open @O" : open_file(load_sdb) + "save @S" : save_sdb() + "save as @U" : save_as_sdb() + "export @X" : write_draft() + "export all" : write_all() + "import" : read_draft() + "revert @V" : revert() + "show grids" : show_grids() + "quit @Q" : quit() + "clear @Z" : clear_sdb() + } + + return + +end + +# Set the height. + +procedure height() + + repeat { + case TextDialog("Height:", , spec.length, NameWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default": { + spec.length := LengthDefault + next + } + "Okay" : { + spec.length := dialog_value[1] + break + } + } + } + + return + +end + +# Initialize the application. + +procedure init() + local atts + + atts := ui_atts() + push(atts, "posx=10", "posy=10") + + (WOpen ! atts) | ExitNotice("Cannot open interface window.") + + vidgets := ui() + + symmetry := vidgets["symmetry"] + + VSetState(symmetry, "none") + VSetState(vidgets["library"], "expressions") + + database := table() + + # As yet undefined procedures + + read_def := write_def := paste_def := copy_def := display_def := new_tie := + display_tie := write_pal := paste_pal := copy_pal := read_pal := + display_pal := 1 + + defn_procs := procs(new_def, read_def, write_def, copy_def, paste_def, display_def) + plte_procs := procs(new_pal, read_pal, write_pal, copy_pal, paste_pal, display_pal) + ties_procs := procs(new_tie, read_tie, write_tie, copy_tie, paste_tie, display_tie) + + lib_procs := ties_procs + lib_type := "tdb" + + + defn_db := table() + expr_db := table() + plte_db := table() + ties_db := table() + defn_lib := table() + expr_lib := table() + plte_lib := table() + ties_lib := table() + + current_db := ties_db + current_lib := ties_lib + + new_spec(1) + + touched := &null + + return + +end + +procedure launch() + + if system("mtrxedit &") ~= 0 then + Notice("Cannot launch tie-up editor.") + + Raise() + +end + +procedure libraries_cb(vidget, value) + + lib_procs := case value of { + "definitions" : defn_procs + "expressions" : expr_procs + "palettes" : plte_procs + "tie-ups" : ties_procs + } + + lib_type := case value of { + "definitions" : "ddb" + "expressions" : "edb" + "palettes" : "pdb" + "tie-ups" : "tdb" + } + + return + +end + + +# Callback for selection from the definitions text-list. + +procedure lib_cb(vidget, value) + local i + static fields, selections + + initial { + fields := ["threading", "treading"] + selections := [1, 1] + } + + if /value then fail + + case lib_type of { + "ddb": { + if TextDialog(value, , value) == "Cancel" then fail + spec.defns[value] := dialog_value[1] + } + "edb" : { + if ToggleDialog(, fields, selections) == "Cancel" then fail + selections := dialog_value + if \selections[1] then spec.threading := current_lib[value] + if \selections[2] then spec.treadling := current_lib[value] + } + "pdb" : { + spec.palette := value + colors() + } + "tdb" : update_loom(pat2tier(current_lib[value])) + } + + refresh_sdb() + + return + +end + +# Load a specification database. If sw is null, it replaces the current +# database. If sw is 1, it is merged with the current database. If sw +# is 2, the database reverts to the last one loaded. + +procedure load_sdb(sw) + local input, db, caption, name + + input := open(nav_file) | { + return FailNotice("Cannot open " || image(nav_file) || ".") + } + + db := xdecode(input) | { + Notice("Cannot decode database.") + fail + } + + sdb_file := nav_file + + close(input) + + if type(db) == ("list" | "sdb") then { + name := db[2] + db := db[1] + } + else { + Notice("Bad database format.") + fail + } + + database := if sw === 1 then tblunion(database, db) else db + + if type(db) ~== "table" then { + Notice("Internal error in loading specification database.") + fail + } + + refresh_sdb(name) + refresh_lib() # NEED TO SET UP + + return + +end + +# Load a database. + +procedure load_db() + local input, db, caption, name + + initial (ddb, edb, pdb, tdb, Palette_) # protect from voracious linker + + input := open(nav_file) | { + return FailNotice("Cannot open " || image(nav_file) || ".") + } + + db := xdecode(input) | { + Notice("Cannot decode database.") + close(input) + fail + } + + close(input) + + if type(db) ~== lib_type then { + Notice("Bad database format: " || type(db) || ".") + fail + } + + db := db.table + + refresh_db(db) + + return + +end + +# Configure loom. + +procedure loom() + local tie_line + + repeat { + if TextDialog("Loom:", ["shafts", "treadles"], + [spec.shafts, spec.treadles], 3) == "Cancel" then fail + spec.shafts <- (0 < dialog_value[1]) & + spec.treadles <- (0 < dialog_value[2]) | { + Notice("Invalid specification.") + next + } + refresh_sdb() + return + } + +end + +# Add (or overwrite) definition. + +procedure new_def() + + if TextDialog("Add definition:", ["name", "definition"], , + [SymWidth, ExprWidth]) == "Cancel" then fail + + spec.defns[dialog_value[1]] := dialog_value[2] + refresh_lib() + + return + +end + +# Create a fresh, empty definitions table. + +procedure new_defs() + + spec.defns := table() + + return + +end + +# Create a new specification from the default. + +procedure new_spec(sw) + + spec := weaving() + spec.name := NameDefault + spec.breadth := BreadthDefault + spec.length := LengthDefault + spec.shafts := ShaftsDefault + spec.treadles := TreadlesDefault + spec.threading := ThreadingDefault + spec.treadling := TreadlingDefault + spec.palette := PaletteDefault + spec.colors := ColorsDefault + spec.warp_colors := WarpColorsDefault + spec.weft_colors := WeftColorsDefault + spec.comments := &dateline + + new_defs() + + if /sw then rename_spec() + + dir_tieup_cb() + + database[spec.name] := spec + refresh_sdb() + + return + +end + +# Set procedure for using file from navitrix. + +procedure open_file(p) + + WAttrib(nav_window, "canvas=normal") + + open_proc := p + + return + +end + +procedure palette() + + repeat { + case TextDialog("Palette:", , spec.palette, ExprWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default" : { + spec.palette := PaletteDefault + next + } + "Okay" : { + spec.palette := dialog_value[1] + break + } + } + } + + colors() + + return + +end + +# Items for the Parameters menu. + +procedure parameters_cb(vidget, value) + + case vidget.id of { + "threading" : threading() + "treadling" : treadling() + "warp" : warp_colors() + "weft" : weft_colors() + "width" : width() + "height" : height() + "loom" : loom() + "palette" : palette() + "colors" : colors() + } + + return + +end + +procedure paste_tie() + local input, tieup + + input := open("/tmp/tieup") | { + Notice("Cannot paste.") + fail + } + + tieup := read(input) | { + Notice("Cannot process tie-up.") + close(input) + fail + } + + close(input) + + update_loom(tieup) + + refresh_sdb() + + return + +end + +procedure update_loom(tieup) + local dims + + dims := tiledim(tieup) + spec.shafts := dims.h + spec.treadles := dims.w + spec.tieup := tieup + + return + +end + +# Quit the application. + +procedure quit() + + if /touched then exit() + + case SaveDialog("Save specification database?", sdb_file) of { + "Cancel" : fail + "No" : exit() + "Yes" : { + save_sdb() + exit() + } + } + + return + +end + +# Read draft. + +procedure read_draft() + local path, file_type, input, pfd + static file + + repeat { + file_type := TextDialog("Read draft:", , file, 60, + ["PFD", "WVP", "WIF", "PWL", "Cancel"]) + if file_type == "Cancel" then fail + file := dialog_value[1] + input := open(file) | { + Notice("Cannot open file.") + next + } + case file_type of { + "PFD": { + pfd := expandpfd(readpfd(input)) | { + Notice("Could not decode PFD.") + next + } + spec.name := pfd.name + spec.threading := "!" || image(pfd.threading) + spec.treadling := "!" || image(pfd.treadling) + spec.warp_colors := "!" || image(pfd.warp_colors) + spec.weft_colors := "!" || image(pfd.weft_colors) + spec.palette := pfd.palette + spec.colors := image(pfd.colors) + spec.shafts := pfd.shafts + spec.treadles := pfd.treadles + spec.tieup := pfd.tieup + } + default : { + Notice(file_type || " not supported.") + next + } + } + close(input) + return + } + + refresh_sdb() + +end + +procedure read_file() + + return read_tie() # FOR NOW + +end + +procedure read_tie() + local input, tieup, dims + + repeat { + if OpenDialog("Read tie-up:") == "Cancel" then fail + input := open(dialog_value) | { + Notice("Cannot open file.") + next + } + tieup := read(input) | { + Notice("Cannot read tie-up.") + close(input) + next + } + close(input) + dims := tiledim(tieup) + spec.shafts := dims.w + spec.treadles := dims.h + spec.tieup := tieup + refresh_sdb() + return + } + +end + +# Refresh the database + +procedure refresh_db(db) + + current_db := db + + case lib_type of { + "edb" : expr_db := db + "pdb" : plte_db := db + } # FINISH + + VSetItems(vidgets["db"], keylist(db)) + + touched := 1 + + return + +end + +# Refresh the database + +procedure refresh_lib(lib) + + if /lib then fail # NEEDS SETUP + + current_lib := lib + + VSetItems(vidgets["lib"], keylist(lib)) + + touched := 1 + + return + +end + +# Refresh the specification database. + +procedure refresh_sdb(name, sw) + + VSetItems(vidgets["specifications"], db_entries := keylist(database)) + + if \name then spec := database[name] + else spec := database[db_entries[-1]] + + update() + + if /sw then touched := 1 + + return + +end + +# Edit the specification name. + +procedure rename_spec(sw) + local old_name, name + + old_name := spec.name + name := spec.name + + if OpenDialog("Name:", name) == "Cancel" then fail + else { + spec.name := dialog_value + database[spec.name] := spec + if /sw then delete(database, old_name) + refresh_sdb() + } + + return + +end + +# Revert to last saved database + +procedure revert() + local tbl, input + + input := open(\sdb_file) | { + Notice("Cannot open specificationdatabase.") + fail + } + + tbl := xdecode(input) | { + Notice("Cannot decode database.") + fail + } + + close(input) + + if type(tbl) == "sdb" then { + name := tbl[2] + tbl := tbl[1] + } + else { + Notice("Bad database format.") + fail + } + + database := tbl + + refresh_sdb(name) + refresh_lib() + + return + +end + +# Save the current database to a specified file. + +procedure save_as_sdb() + local output, file + + repeat { + if OpenDialog("Save specification database:", sdb_file) == "Cancel" then fail + file := dialog_value + if exists(file) then { + if AskDialog("Overwrite existing file?") == "No" then fail + } + output := open(file, "w") | { + Notice("Cannot open database file for writing.") + next + } + sdb_file := file + xencode(sdb(database, spec.name), output) + close(output) + touched := &null + return + } + +end + +# Save the current table of definitions to a file. + +procedure save_defs() + local output, file + + repeat { + if OpenDialog("Save definitions:") == "Cancel" then fail + file := dialog_value + if exists(file) then { + if AskDialog("Overwrite existing file?") == "No" then next + } + output := open(file, "w") | { + Notice("Cannot open definitions file for writing.") + next + } + xencode(spec.defns, output) + close(output) + return + } + +end + +# Save the current database. + +procedure save_sdb() + local output + + if /sdb_file then { # NEEDS WORK + repeat{ + if OpenDialog("Save specification database:") == "Cancel" then fail + sdb_file := dialog_value + break + } + } + + output := open(sdb_file, "w") | { + Notice("Cannot write database file.") + sdb_file := "" + fail + } + + xencode(sdb(database, spec.name), output) + + close(output) + + touched := &null + + return + +end + +# Keyboard shortcuts. + +procedure shortcuts(e) + + if e === "\r" then weaveit() # quick generation initiation + else if &meta then case map(e) of { + "0" : write(ximage(database)) # ... undocumented + "1" : launch() # ... undocumented + "2" : show_error() # ... only available as a shortcut + "3" : () + "4" : () + "5" : () + "6" : () + "7" : () + "8" : () + "9" : () + "a" : () + "b" : () + "c" : lib_procs.copy() # Update menu + "d" : dupl_spec() # File menu + "e" : write_draft() # File menu + "f" : () + "g" : show_grids() # File menu + "h" : () + "i" : display_spec() # Specification menu + "j" : () + "k" : comments() + "l" : open_file(load_db) # Database menu + "m" : rename_spec() + "n" : new_spec() # Specification menu + "o" : open_file(load_sdb) # File menu + "p" : lib_procs.paste() # Update menu + "q" : quit() # File menu + "r" : lib_procs.read() # Update menu + "s" : save_sdb() # File menu + "t" : () + "u" : save_as_sdb() # File menu + "v" : revert() # File menu + "w" : lib_procs.write() # Update menu + "x" : write_draft() # file menu + "y" : () + "z" : clear_sdb() # File menu + } + + return + +end + +procedure show_error() + local input, log + + input := open("/tmp/err") | { + Notice("Cannot open error log.") + fail + } + + log := ["Error log:", ""] + + while put(log, read(input)) + + close(input) + + Notice ! log + + return + +end + +# Show plots of grids +# +# COMBINE CODE WITH weaveit() + +procedure show_grids() + local path, i, tie_line + + WAttrib("pointer=watch") + + write_spec("include.wvp", spec, "w", VGetState(symmetry)) | { + Notice("Cannot open include file for writing.") + fail + } + + path := dpath("plotgrid.icn") | { + Notice("Fatal error; cannot find grid plotting program.") + fail + } + + remove("/tmp/err") + + if system("icont -s " || path || " >/dev/null 2>/tmp/err") ~= 0 then { + Notice("Error during compilation.") + WAttrib("pointer=arrow") + fail + } + + if system("plotgrid >/dev/null 2>/tmp/err") ~= 0 then { + Notice("Runtime error.") + WAttrib("pointer=arrow") + fail + } + + Raise() + + WAttrib("pointer=arrow") + + return + +end + +# Callback for item selected from specifications list. + +procedure spec_cb(vidget, value) + local state + static db, sw + + initial db := vidgets["specifications"] + + if /value then return # deselected item + + if \sw then { # prevent loop from internal call + sw := &null + return + } + + state := VGetState(db) # save state to restore position + + repeat { + case TextDialog("Specification " || value, , , , + ["Delete", "Display", "Okay", "Cancel"], 3) of { + "Cancel" : fail + "Okay" : { +# spec.name := value +# spec := database[spec.name] + refresh_lib() + sw := 1 + refresh_sdb(value, sw) + VSetState(db, state) + return + } + "Delete" : { + if value == spec.name then { + Notice("You cannot delete the current specification.") + next + } + delete(database, value) + refresh_sdb() + return + } + "Display" : { + display_spec(database[value]) + next + } + } + } + +end + +# Items for the Specification menu. + +procedure specification_cb(vidget, value) + + case value[1] of { + "new @N" : new_spec() + "duplicate @D" : dupl_spec() + "rename @M" : rename_spec() + "comment @K" : comments() + "display @I" : display_spec() + } + + return + +end + +procedure str_draw_cb() + + spec.threading := "seq()" + spec.treadling := "seq()" + + refresh_sdb() + + return + +end + +# Edit the threading specification. + +procedure threading() + local input, line + static file, number + + initial number := 1 + + repeat { + case TextDialog("Threading:", , spec.threading, ExprWidth, + ["Read", "Define", "Default", "Copy Treadling", "Okay", "Cancel"], 5) of { + "Read" : { + repeat { + if TextDialog("Threading file:", ["name", "line"], + [file, number], [60, 5]) == "Cancel" then fail + input := open(dialog_value[1]) | { + Notice("Cannot open file.") + next + } + file := dialog_value[1] + every 1 to number do + line := read(input) | { + Notice("Short file.") + close(input) + break next + } + spec.threading := line + close(input) + break + } + } + "Define" : { + define(dialog_value[1]) + break + } + "Cancel" : fail + "Default" : { + spec.threading := ThreadingDefault + next + } + "Copy Treadling" : { + spec.threading := spec.treadling + next + } + "Okay" : { + spec.threading := dialog_value[1] + break + } + } + } + + return + +end + +procedure to_db_cb() + + return + +end + +procedure db_all_to_lib_cb() + local lib + + case lib_type of { + "pdb": lib := plte_lib := current_db + } # FINISH + + refresh_lib(lib) + + return + +end + +# Edit the treadling expression. + +procedure treadling() + local file, input, line + static number + + initial number := 1 + + repeat { + case TextDialog("Treadling:", , spec.treadling, ExprWidth, + ["Read", "Define", "Default", "Copy Threading", "Okay", "Cancel"], 5) of { + "Define" : { + define(dialog_value[1]) + break + } + "Cancel" : fail + "Read" : { + repeat { + if TextDialog("Treadling file:", ["name", "line"], + [file, number], [60, 5]) == "Cancel" then fail + input := open(dialog_value[1]) | { + Notice("Cannot open file.") + next + } + file := dialog_value[1] + every 1 to number do + line := read(input) | { + Notice("Short file.") + close(input) + break next + } + spec.treadling := line + close(input) + break + } + } + "Default": { + spec.treadling := TreadlingDefault + next + } + "Copy Threading": { + spec.treadling := spec.threading + next + } + "Okay" : { + spec.treadling := dialog_value[1] + break + } + } + } + + return + +end + +procedure tromp_writ_cb() + + spec.treadling := spec.threading + + refresh_sdb() + + return + +end + +# Update the display on the interface +# GET RID OF REVERSIBLE DRAWING IN FAVOR OF ERASURE + +procedure update() + static previous_name, sx, sy + + initial { + sx := vidgets["placeholder"].ax + sy := vidgets["placeholder"].ay + WAttrib("leading") + 2 # AD HOC + } + + # Update selection information on interface. + + WAttrib("drawop=reverse") + + DrawString(sx, sy, \previous_name) + DrawString(sx, sy, spec.name) + + WAttrib("drawop=copy") + + previous_name := spec.name + + return + +end + +procedure update_cb(vidget, value) + + case value[1] of { + "read @R" : lib_procs.read() + "write @W" : lib_procs.write() + "copy @C" : lib_procs.copy() + "paste @P" : lib_procs.paste() + "new" : lib_procs.new() + } + + return + +end + +procedure warp_colors() + local input, line + static file, number + + repeat { + case TextDialog("Warp colors:", , spec.warp_colors, ExprWidth, + ["Read", "Define", "Default", "Copy Weft Colors", "Okay", "Cancel"], 5) of { + "Read" : { + repeat { + if TextDialog("Color file:", ["name", "line"], + [file, number], [60, 5]) == "Cancel" then fail + input := open(dialog_value[1]) | { + Notice("Cannot open file.") + next + } + file := dialog_value[1] + every 1 to number do + line := read(input) | { + Notice("Short file.") + close(input) + break next + } + spec.warp_colors := line + close(input) + break + } + } + "Define" : { + define(dialog_value[1]) + break + } + "Cancel" : fail + "Default" : { + spec.warp_colors := WarpColorsDefault + next + } + "Okay" : { + spec.warp_colors := dialog_value[1] + break + } + "Copy Weft Colors" : { + spec.warp_colors := spec.weft_colors + next + } + } + } + + return + +end + +# Create a weaving from the current specification. + +procedure weaveit() + local path, i, tie_line, pdb + + WAttrib("pointer=watch") + + write_spec("include.wvp", spec, "w", VGetState(symmetry)) | { + Notice("Cannot open include file for writing.") + fail + } + + path := dpath("seqweave.icn") | { + Notice("Fatal error; cannot find weaving generation program.") + fail + } + + pdb := open("/tmp/pdb", "w") | { + Notice("Cannot write palette information.") + fail + } + + xencode(plte_lib, pdb) + + close(pdb) + + remove("/tmp/err") + + if system("icont -s " || path || " >/dev/null 2>/tmp/err") ~= 0 then { + Notice("Error during compilation.") + WAttrib("pointer=arrow") + fail + } + + if system("seqweave >/dev/null 2>/tmp/err") ~= 0 then { + Notice("Runtime error.") + WAttrib("pointer=arrow") + fail + } + + Raise() + + WAttrib("pointer=arrow") + + return + +end + +procedure weft_colors() + local input, line + static file, number + + repeat { + case TextDialog("Weft colors:", , spec.weft_colors, ExprWidth, + ["Read", "Define", "Default", "Copy Warp Colors", "Okay", "Cancel"], 5) of { + "Read" : { + repeat { + if TextDialog("Color file:", ["name", "line"], + [file, number], [60, 5]) == "Cancel" then fail + input := open(dialog_value[1]) | { + Notice("Cannot open file.") + next + } + file := dialog_value[1] + every 1 to number do + line := read(input) | { + Notice("Short file.") + close(input) + break next + } + spec.weft_colors := line + close(input) + break + } + } + "Define" : { + define(dialog_value[1]) + break + } + "Cancel" : fail + "Default" : { + spec.weft_colors := WeftColorsDefault + next + } + "Okay" : { + spec.weft_colors := dialog_value[1] + break + } + "Copy Warp Colors" : { + spec.weft_colors := spec.warp_colors + next + } + } + } + + return + +end + +# Edit the width. + +procedure width() + + repeat { + case TextDialog("Breadth:", , spec.breadth, NameWidth, + ["Default", "Okay", "Cancel"], 2) of { + "Cancel" : fail + "Default" : { + spec.breadth := BreadthDefault + next + } + "Okay" : { + spec.breadth := dialog_value[1] + break + } + } + } + + return + +end + +# Write the all drafts. + +procedure write_all() + local path, file_type, file, spec + + repeat { + case TextDialog("Save drafts for all:", , , , + ["PFD", "WVP", "WIF", "PWL", "TIE", "Cancel"]) of { + "PFD" : { + path := dpath("wvp2pfd.icn") | { + Notice("Cannot open conversion program.") + next + } + WAttrib("pointer=watch") + every spec := !database do { + file := spec.name || ".pfd" + write_spec("include.wvp", spec, VGetState(symmetry)) + if system("icont -s " || path || " -x > " || file) ~= 0 then { + Notice("Attempt to write pattern-form draft failed.") + WAttrib("pointer=arrow") + break break + } + } + WAttrib("pointer=arrow") + return + } + "WVP" : { + WAttrib("pointer=watch") + every spec := !database do { + file := spec.name || ".wvp" + write_spec(file, spec, , VGetState(symmetry)) + } + WAttrib("pointer=arrow") + return + } + "Cancel" : fail + default : { + Notice(file_type || " not supported yet.") + next + } + } + } + +end + +# Write draft for current specification. + +procedure write_draft() + local path, file_type, file + + repeat { + file_type := TextDialog("Save draft:", , spec.name, 60, + ["WVP", "PFD", "WIF", "PWL", "TIE", "Cancel"]) + if file_type == "Cancel" then fail + file := dialog_value[1] + if exists(file) then { + if AskDialog("Overwrite existing file?") == "No" then next + } + case file_type of { + "WVP" : { + file ||:= ".wvp" + write_spec(file, spec, , VGetState(symmetry)) + return + } + "PFD" : { + file ||:= ".pfd" + WAttrib("pointer=watch") + write_spec("include.wvp", spec, , VGetState(symmetry)) + path := dpath("wvp2pfd.icn") | { + Notice("Cannot open conversion program.") + fail + } + if system("icont -s " || path || " -x > " || file) ~= 0 then { + Notice("Attempt to write pattern-form draft failed.") + WAttrib("pointer=arrow") + break + } + WAttrib("pointer=arrow") + return + } + default : { + Notice(file_type || " not supported.") + next + } + } + } + +end + +procedure write_file() + + return write_tie() # FOR NOW + +end + +procedure write_tie() + local output + + repeat { + if OpenDialog("Write tie-up:") == "Cancel" then fail + output := open(dialog_value, "w") | { + Notice("Cannot open file for writing.") + next + } + write(output, spec.tieup) + close(output) + return + } + +end + +procedure save_db(); return; end +procedure clear_db(); return; end +procedure new_pal(); return; end +procedure as_thread_cb2(); return; end +procedure bands_cb(); return; end +procedure clr_as_warp_cb(); return; end +procedure db_to_lib_cb(); return; end +procedure lib_all_to_db_cb(); return; end +procedure lib_to_db(); return; end +procedure str_draw_th_cb(); return; end +procedure str_draw_tr_cb(); return; end +procedure swapc_tb(); return; end +procedure th_peak_cb(); return; end +procedure tieup_cb(); return; end +procedure tr_peak_cb(); return; end +procedure warp_straight_cb(); return; end +procedure warp_peak_cb(); return; end +procedure weft_peaks_cb(); return; end +procedure weft_straight_cb(); return; end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=610,460", "bg=pale gray", "label=Sequence Drafting"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,610,460:Sequence Drafting",], + ["as_thread:Button:check::130,388,105,20:as threaded",as_thread_cb2], + ["bands:Button:check::380,370,105,20:bands",bands_cb], + ["blend:Button:check::378,282,105,20:blend",configuration_cb], + ["clr_as_warp:Button:check::261,388,105,20:as warp",clr_as_warp_cb], + ["colors:Button:check::483,205,105,20:color keys",parameters_cb], + ["colorw:Button:check::261,300,105,20:as weft",color_writ_cb], + ["database:Menu:pull::136,1,64,21:Database",database_cb, + ["load @L","save","clear"]], + ["db:List:w::189,58,130,165:",], + ["db_all_to_lib:Button:regular::150,99,35,20:<<",db_all_to_lib_cb], + ["db_to_lib:Button:regular::150,153,35,20:<",db_to_lib_cb], + ["drawdown:Button:check::378,264,105,20:drawdown",configuration_cb], + ["dt:Button:check::380,352,105,20:direct",dir_tieup_cb], + ["file:Menu:pull::1,1,36,21:File",file_cb, + ["generate","open @O","save @S","save as @U","export @X", + "export all","import","revert @V","clear @Z","show grids", + "quit @Q"]], + ["height:Button:check::483,169,105,20:height",parameters_cb], + ["label1:Label:::48,39,49,13:library",], + ["label10:Label:::270,244,77,13:warp colors",], + ["label11:Label:::38,244,49,13:library",], + ["label12:Label:::515,244,56,13:symmetry",], + ["label2:Label:::219,39,56,13:database",], + ["label3:Label:::391,412,42,13:draft:",], + ["label4:Label:::384,244,91,13:configuration",], + ["label5:Label:::152,244,63,13:threading",], + ["label6:Label:::500,37,70,13:parameters",], + ["label7:Label:::152,330,63,13:treadling",], + ["label8:Label:::401,331,42,13:tie-up",], + ["label9:Label:::273,331,77,13:weft colors",], + ["lib:List:w::15,58,130,165:",lib_cb], + ["lib_all_to_db:Button:regular::150,74,35,20:>>",lib_all_to_db_cb], + ["lib_to_db:Button:regular::150,178,35,20:>",lib_to_db], + ["library:Choice::4:14,263,106,84:",libraries_cb, + ["definitions","expressions","palettes","tie-ups"]], + ["line1:Line:::0,23,729,23:",], + ["loom:Button:check::483,133,105,20:loom",parameters_cb], + ["palette:Button:check::483,187,105,20:palette",parameters_cb], + ["sd:Button:check::130,263,105,20:straight",str_draw_th_cb], + ["specification:Menu:pull::38,1,99,21:Specification",specification_cb, + ["new @N","duplicate @D","rename @M","comment @K","display @I"]], + ["specifications:List:w::342,58,130,165:",spec_cb], + ["specs:Label:::381,39,42,13:drafts",], + ["str_draw:Button:check::130,352,105,20:straight",str_draw_tr_cb], + ["swapc:Button:check::261,417,105,20:swap",swapc_tb], + ["swapt:Button:check::130,417,105,20:swap",swapt_cb], + ["symmetry:Choice::4:494,262,99,84:",, + ["none","horizontal","vertical","both"]], + ["th_peak:Button:check::130,281,105,20:peaks",th_peak_cb], + ["threading:Button:check::483,61,105,20:threading",parameters_cb], + ["tieup:Menu:pull::250,1,50,21:Tie-up",tieup_cb, + ["display","rotate 90 cw","rotate 90 ccw","rotate 180","flip horizontal", + "flip vertical","flip left diagonal","flip right diagonal","shift horizontal","shift vertical", + "invert"]], + ["tr_peak:Button:check::130,370,105,20:peaks",tr_peak_cb], + ["treadling:Button:check::483,79,105,20:treadling",parameters_cb], + ["tromp:Button:check::130,299,105,20:as treadled",tromp_writ_cb], + ["update:Menu:pull::199,1,50,21:Update",update_cb, + ["new","read @R","write @W","copy @C","paste @P", + "display"]], + ["waor_straight:Button:check::261,264,105,20:straight",warp_straight_cb], + ["warp:Button:check::483,97,105,20:warp colors",parameters_cb], + ["warp_peak:Button:check::261,282,105,20:peaks",warp_peak_cb], + ["weft:Button:check::483,115,105,20:weft colors",parameters_cb], + ["weft_peaks:Button:check::261,370,105,20:peaks",weft_peaks_cb], + ["weft_straight:Button:check::261,352,105,20:straight",weft_straight_cb], + ["width:Button:check::483,151,105,20:width",parameters_cb], + ["placeholder:Rect:invisible::438,408,125,23:",], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/seqweave.icn b/ipl/gpacks/weaving/seqweave.icn new file mode 100644 index 0000000..f7ef54b --- /dev/null +++ b/ipl/gpacks/weaving/seqweave.icn @@ -0,0 +1,220 @@ +############################################################################ +# +# File: seqweave.icn +# +# Subject: Program to create woven images from sequence drafts +# +# Author: Ralph E. Griswold +# +# Date: June 13, 1999 +# +############################################################################ +# +# This program produces woven images as specificed in the include +# file, include.wvp, which is produced by seqdraft.icn. +# +############################################################################ +# +# Requires: Version 9 graphics and large integers +# +############################################################################ +# +# Links: convert, expander, weaving, weavutil, lists, mirror, options, +# tieutils, wopen, numbers, palettes, weaveseq, xcode, io, palettes, +# patutils +# +############################################################################ +# +# Note: The include file may introduce link declarations. +# +############################################################################ + +link convert +link expander +link io +link lists +link mirror +link numbers +link options +link palettes +link patutils +link tieutils +link weaving +link weavutil +link wopen +link weaveseq +link xcode +link ximage + +$include "include.wvp" + +$ifdef Link +#########################Whasis +Link +$endif + +global cmod +global colors +global debug +global height +global shafts +global width +global threading +global tieup +global tieups +global treadling +global treadles +global warp_colors +global weft_colors + +record pdb(table) + +procedure main(args) + local opts + + opts := options(args, "d") + + debug := opts["d"] + + init() + + weave() + +$ifdef Save + WriteImage(Name || ".gif") + exit() +$endif + + repeat case Event() of { # process low-level user events + !"zZ" : ZDone() + !"qQ" : exit() + "s" : WriteImage(Name || ".gif") + } + +end + +# Initialize the weaving. + +procedure init() + local m, n, v, input, palettes + + pdb() # prevent linker discard + Palette_() + Color_() + palette_names + + if input := open("/tmp/pdb") then { + palette_names := xdecode(input) | stop("*** cannot decode palette database") + close(input) + } + else palette_names := table() + + shafts := Shafts + treadles := Treadles + + colors := Colors | stop("*** invalid color specification") + + height := Length + width := Breadth + + threading := [] + every put(threading, |sconvert(Threading, shafts)) \ width + + treadling := [] + every put(treadling, |sconvert(Treadling, treadles)) \ height + + warp_colors := [] + every put(warp_colors, |sconvert(WarpColors, *colors)) \ width + + weft_colors := [] + every put(weft_colors, |sconvert(WeftColors, *colors)) \ height + +$ifdef Hidden + WOpen("canvas=hidden", "size=" || width || "," || height) | + stop("Cannot open window for weaving.") +$else + WOpen("size=" || width || "," || height) | + stop("Cannot open window for weaving.") +$endif + +$ifdef DeBug + write(threading) + write(treadling) + write(warp_colors) + write(weft_colors) +$endif + + tieup := pat2tier(Tieup).matrix + + return + +end + +# Create the weaving. + +procedure weave() + local x, y, color, treadle, i, j, win + + # Initialize warp. + + if *cset(warp_colors) = 1 then { # solid warp ground + Fg(PaletteColor(Palette, colors[warp_colors[1]])) + FillRectangle() + } + else { + x := 0 + every color := !warp_colors do { + Fg(PaletteColor(Palette, colors[color])) | { + write(&errout, "Bad warp color key: ", image(color)) + write(&errout, "Colors: ", ximage(warp_colors)) + stop("Warp colors: ", ximage(warp_colors)) + } + DrawLine(x, 0, x, *treadling - 1) + x +:= 1 + } + } + + every y := 0 to *treadling - 1 do { + if *Pending() > 0 then + if Event() === "q" then exit() + treadle := tieup[treadling[y + 1]] + every i := 1 to *treadle do { + if treadle[i] == "0" then { + every j := 1 to *threading do { + if threading[j] == i then { + Fg(PaletteColor(Palette, colors[weft_colors[y + 1]])) | + stop("Bad weft color label.", "y=" || y) + DrawPoint(j - 1, y) # OPTIMIZE WITH DrawLine() + } + } + } + } + } + + case Reflect of { + "both" : { + win := mirror() + WClose() + WAttrib(win, "canvas=normal") + &window := win + } + } + +end + +procedure shortcuts(e) + + if &meta then case map(e) of { + "q" : exit() + "w" : weave() + } + + return + +end + +procedure sconvert(s, n) + + return abs(integer(s)) % n + 1 + +end diff --git a/ipl/gpacks/weaving/shadow.icn b/ipl/gpacks/weaving/shadow.icn new file mode 100644 index 0000000..ddf260e --- /dev/null +++ b/ipl/gpacks/weaving/shadow.icn @@ -0,0 +1,102 @@ +############################################################################ +# +# File: shadow.icn +# +# Subject: Program to build pattern-form drafts for shadow weaves +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is based on the Painter weave "Shadow Op Art". +# +# Supported options are: +# +# -b s palindrome base sequence, default "8214365" +# -c s warp colors, default "01" +# -d s weft colors, default "10" +# -n s name, default "untitled_shadow_weave" +# -p s palette, default "g2" +# -t s tie-up, default "8,#8040201008040201" # DIRECT TIE-UP +# +# The first non-option command-line argument is a transposition vector for +# the anchors; default 1234567. The second non-option command-line argument +# is a transposition vector for the palindromes; default the anchor +# transposition vector. +# +# For example, +# +# shadow 7654321 +# +# reverses the default order of both the anchors and palindromes. +# +############################################################################ +# +# Links: options, strings +# +############################################################################ + +link options +link strings + +global anchor_indices +global palindrome_indices +global palindrome_basis +global palindromes + +procedure main(args) + local expression, name, opts, tie_up, warp_colors, weft_colors, palette + local i, anchor_vector, palindrome_vector + + opts := options(args, "b:n:t:c:d:p:") + + anchor_vector := \args[1] | "1234567" + palindrome_vector := \args[2] | anchor_vector + + palindrome_basis := \opts["b"] | "8214365" + weft_colors := \opts["c"] | "01" + warp_colors := \opts["d"] | "10" + palette := \opts["p"] | "g2" + name := \opts["n"] | "untitled_shadow_weave" + tie_up := \opts["t"] | "8,#8040201008040201" + + anchor_indices := transpose("1234567", "1234567", anchor_vector) + palindrome_indices := transpose("1234567", "1234567", palindrome_vector) + + palindromes := list(*palindrome_basis) + + every i := 1 to *palindrome_basis do + palindromes[i] := "[" || palindrome_basis[1:i] || "!" || palindrome_basis[i] || "]" + + expression := "[" || threading(anchor_indices[1]) || "|]" + + write(name) + write(expression) + write(expression) + write(warp_colors) + write(weft_colors) + write(palette) + write(tie_up) + write() + +end + +procedure threading(i) + local result + + if i > *palindrome_basis then return "" + + result := "-[" || anchor_indices[i] || "-[" || + palindromes[anchor_indices[i]] || threading(i + 1) || "]]" + + if i = 1 then result := result[2:0] + + return result + +end diff --git a/ipl/gpacks/weaving/shadpapr.icn b/ipl/gpacks/weaving/shadpapr.icn new file mode 100644 index 0000000..0205314 --- /dev/null +++ b/ipl/gpacks/weaving/shadpapr.icn @@ -0,0 +1,106 @@ +############################################################################ +# +# File: shadpaper.icn +# +# Subject: Program to generate mutant shadow weave wallpaper +# +# Author: Ralph E. Griswold +# +# Date: April 10, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is based on the Painter weave "Shadow Op Art". +# +############################################################################ +# +# Links: random, tieutils, weavegif, weavutil +# +############################################################################ + +link random +link tieutils +link weavegif +link weavutil + +global anchors +global palpat +global palindromes + +procedure main(args) + local tieup, palette, mutant, win, colorways, i + + randomize() + + # In this instantiation, the tieup and palindrome sequence + # basis are fixed. Anchors are shuffled (permuted randomly), + # but the palindromes attached to the anchors. That is, + # the anchors and attached palindromes are permuted together. + + # The c1 palette is used and pairs of contrasting colors + # selected at random. Note: Colors that are browser-safe + # need to be used. + + anchors := "1234567" + palpat := "82143657" + colorways := ["eJ", ",A", "A5", "@z"] + tieup := tie2tier("8;8;1010101001010101101010010101011010100101_ + 010110101001010101101010") + palette := "c1" + + palindromes := list(*palpat) + + every i := 1 to *palpat do + palindromes[i] := "[" || palpat[1:i] || "!" || palpat[i] || "]" + + mutant := draft() + mutant.name := "Shadow Weave Variation" + mutant.palette := palette + mutant.tieup := tieup + + every 1 to 10 do { + anchors := shuffle(anchors) + mutant.threading := "[" || thread(1) || "|]" + anchors := shuffle(anchors) + mutant.treadling := "[" || thread(1) || "|]" +# mutant.warp_colors := ?colorways +# mutant.weft_colors := reverse(mutant.warp_colors) +# win := weavegif(expandpfd(mutant)) +# WriteImage(win, "weaving.gif") +# WClose(win) + mutant.warp_colors := "60" + mutant.weft_colors := "06" + win := weavegif(expandpfd(mutant)) + WriteImage(win, "bandw.gif") + WDelay(win, 10000) + WClose(win) + } + + # Because of a memory leak (possibly in X), it is necessary to + # terminate this program at intervals and start up a new version. + + system("wallpapr &") + + exit() + +end + +# Compute sequence as pattern-form. + +procedure thread(i) + local result + + if i = *palpat then return "" + + result := "-[" || anchors[i] || "-[" || palindromes[i] || + thread(i + 1) || "]]" + + if i = 1 then result := result[2:0] + + return result + +end diff --git a/ipl/gpacks/weaving/showrav.icn b/ipl/gpacks/weaving/showrav.icn new file mode 100644 index 0000000..743befc --- /dev/null +++ b/ipl/gpacks/weaving/showrav.icn @@ -0,0 +1,197 @@ +############################################################################ +# +# File: showrav.icn +# +# Subject: Program to display woven pattern +# +# Author: Gregg M. Townsend +# +# Date: June 23, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Showrav displays an unraveled weaving using shading to show how +# the threads (actually, they look more like ribbons) pass over +# and under each other. It reads raw output of the form produced +# by "unravel -r". At any intersection where both the warp and +# weft threads are the correct color, the thread is chosen randomly. +# +# Usage: showrav [winoptions] file... +# +# Window commands are: +# q quit +# r render again with different random choices +# s save image +# <SP> advance to next file +# <BS> go back one file +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics, interact, random +# +############################################################################ + + + +link graphics +link interact +link random + + +$define CMAX 12 # maximum cell size +$define CMIN 3 # minimum cell size (overrides WMAX/HMAX) + + +global normal, lighter, darker # mapping strings for c1 palette colors + +global cols, rows, data + +global WMAX, HMAX # maximum window size + +global W # cell size +global B # border width + + +procedure main(args) + local n + + Window("canvas=hidden", "size=1000,800", args) # that's MAXIMUM size + WMAX := WAttrib("width") # user may override + HMAX := WAttrib("height") + + if *args = 0 then stop("usage: ", &progname, " [winoptions] file...") + + setcolors() + randomize() + n := 1 + load(args[n]) + render() + + repeat case Event() of { + !QuitEvents(): exit() + !"rR": render() + !"sS": snapshot() + !" \n\r": { + if n < *args then { + load(args[n +:= 1]) + render() + } + } + !" \b\d": { + if n > 1 then { + load(args[n -:= 1]) + render() + } + } + } +end + + +procedure load(fname) + local f, s + + f := open(fname) | stop("cannot open ", fname) + cols := read(f) + rows := read(f) + data := read(f) + close(f) + + (*\cols * *\rows = *\data) | stop("malformed input: ", fname) + W := WMAX / *cols + W >:= HMAX / *rows + W >:= CMAX + W <:= CMIN + B := W / 6 + B <:= 1 + + s := "size=" || (W * *cols) || "," || (W * *rows) + WAttrib(s, "label=" || fname, "canvas=normal") + return +end + + +procedure render() + local x, y, c + + every x := 1 to *cols do + warp(x, cols[x]) + + data ? { + every y := 1 to *rows do { + every x := 1 to *cols do { + c := move(1) + if c ~== rows[y] then + vert(x, y, c) + else if c ~== cols[x] then + horz(x, y, c) + else + either(x, y, c) + } + } + } + return +end + + + +procedure warp(x, c) + local h + + x := W * (x - 1) + h := W * *rows + Fg(PaletteColor("c1", map(c, normal, lighter))) + FillRectangle(x, 0, B, h) + Fg(PaletteColor("c1", c)) + FillRectangle(x + B, 0, W - 2 * B, h) + Fg(PaletteColor("c1", map(c, normal, darker))) + FillRectangle(x + W, 0, -B, h) + return +end + + +procedure vert(x, y, c) + # nothing to do; let warp thread show through + return +end + + +procedure horz(x, y, c) + x := W * (x - 1) + y := W * (y - 1) + Fg(PaletteColor("c1", map(c, normal, lighter))) + FillRectangle(x, y, W, B) + Fg(PaletteColor("c1", c)) + FillRectangle(x, y + B, W, W - 2 * B) + Fg(PaletteColor("c1", map(c, normal, darker))) + FillRectangle(x, y + W, W, -B) + return +end + + +procedure either(x, y, c) + static procs + initial procs := [horz, vert] + return (?procs)(x, y, c) +end + + +procedure setcolors() + + lighter := "2234565^[&Cpabc,;+*`ijklmABCDEFGHIJKLMNOPQRSTUVWXYZ" + normal := "0123456789?!ABCDEFGHIJKLMNOPQRSTUVWXYZnopqrstuvwxyz" + darker := "1012344MKCp0NOPQRSTUVWXYZnopqrstuvwxyz0000000000000" + + lighter ||:= "#$&,;+*`<([{^6666666666666#$&,;+*`<([{^" + normal ||:= "abcdefghijklm#$&,;+*`<([{^@%|.:-/'>)]}=" + darker ||:= "@%|.:-/'>)]}=@%|.:-/'>)]}=nopqrstuvwxyz" + + return +end diff --git a/ipl/gpacks/weaving/spray.icn b/ipl/gpacks/weaving/spray.icn new file mode 100644 index 0000000..2a546cd --- /dev/null +++ b/ipl/gpacks/weaving/spray.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: spray.icn +# +# Subject: Program to manipulate bibliographical records +# +# Author: Ralph E. Griswold +# +# Date: March 25, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ + +procedure main() + + while line := read() do { + rec := [] + line ? { + while field := tab(upto('\t')) do { + put(rec, field) + move(1) + } + if not pos(0) then put(rec, tab(0)) + } + every write(!rec) + write() + } + +end diff --git a/ipl/gpacks/weaving/tdialog.icn b/ipl/gpacks/weaving/tdialog.icn new file mode 100644 index 0000000..44e8662 --- /dev/null +++ b/ipl/gpacks/weaving/tdialog.icn @@ -0,0 +1,53 @@ +############################################################################ +# +# File: tdialog.icn +# +# Subject: Procedure for threading/treadling sequences +# +# Author: Ralph E. Griswold +# +# Date: May 10, 1999 +# +############################################################################ +# +# This dialog procedure handles the editing and manipulation of the +# threading and treadling sequences for seqdraft. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: dsetup +# +############################################################################ + +link dsetup + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure t_db(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["t_db:Sizer::1:0,0,587,348:Threading and Treadling",], + ["cancel:Button:regular::313,310,50,20:Cancel",], + ["copy1:Button:regular::163,68,105,20:Copy Treadling",], + ["copy2:Button:regular::163,228,105,20:Copy Treadling",], + ["default1:Button:regular::333,70,56,20:Default",], + ["default2:Button:regular::333,228,56,20:Default",], + ["define1:Button:regular::407,69,49,20:Define",], + ["define2:Button:regular::407,228,49,20:Define",], + ["label1:Label:::231,7,126,13:Threading Sequence",], + ["label2:Label:::231,154,126,13:Treadling Sequence",], + ["line1:Line:::447,3,495,3:",], + ["line2:Line:::0,125,594,125:",], + ["line3:Line:::2,280,596,280:",], + ["okay:Button:regular::244,310,50,20:Okay",], + ["read1:Button:regular::284,70,35,20:Read",], + ["read2:Button:regular::284,228,35,20:Read",], + ["text1:Text::79:18,31,563,19:\\=",], + ["text2:Text::79:10,184,563,19:\\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/testdraw.icn b/ipl/gpacks/weaving/testdraw.icn new file mode 100644 index 0000000..96dbd0c --- /dev/null +++ b/ipl/gpacks/weaving/testdraw.icn @@ -0,0 +1,18 @@ +link wopen + +procedure main() + + ims := read() + + ims ? { + size := tab(upto(',')) + } + WOpen("size=" || size || "," || size) | stop("*** cannot open file") + + DrawImage(0, 0, ims) | stop("*** DrawImage() failed") + + WriteImage("testscan.gif") + + ZDone() + +end diff --git a/ipl/gpacks/weaving/thm2html.icn b/ipl/gpacks/weaving/thm2html.icn new file mode 100644 index 0000000..8accc8d --- /dev/null +++ b/ipl/gpacks/weaving/thm2html.icn @@ -0,0 +1,75 @@ +############################################################################ +# +# File: thm2html.icn +# +# Subject: Program to create web pages for weaving thumbnails +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. Skeleton was derived from a CyberStudio page. +# +# The name of a directory <d> is given on the command line. It is expected +# that GIF/<d> contains full-sized GIF files and that GIF/<d>/thumbs +# contains thumbnails. The output is a page named <d>.html that contains +# an array of thumbnails with links to Web pages in HTML/<d> that contain +# individual pages with images and the corresponding .wvp files. +# +# The thumbnails are assumed to be 64x64. +# +############################################################################ +# +# Links: basename, options +# +############################################################################ + +link basename + +procedure main(args) + local head, body, tail, title, i, name, directory, input + + name := args[1] | stop("*** no directory given") + + directory := name + + title := "Sequence-Based Weaves" + +$include "thmhead" +$include "thmbody" +$include "thmtail" + + head[5] := title + head[35] := name + + every write(!head) + + input := open("ls GIF/" || directory || "/*.gif", "p") + + repeat { + i := 5 # offset to first placeholder + every 1 to 8 do { + name := read(input) | { + every write(body[1 to i - 2]) + write(body[-1]) + break break + } + name := basename(name, ".gif") + body[i] := image("HTML/" || directory || "/" || + name || ".html") + body[i + 2] := image("GIF/" || directory || "/thumbs/" || name || + ".gif") + i +:= 5 # offset to next placeholder + } + every write(!body) + } + + every write(!tail) + +end diff --git a/ipl/gpacks/weaving/thmtail.icn b/ipl/gpacks/weaving/thmtail.icn new file mode 100644 index 0000000..60f0cd6 --- /dev/null +++ b/ipl/gpacks/weaving/thmtail.icn @@ -0,0 +1,6 @@ +tail := [ +"\t\t</table>", +"\t</body>", +"", +"</html>" +] diff --git a/ipl/gpacks/weaving/tie2pat.icn b/ipl/gpacks/weaving/tie2pat.icn new file mode 100644 index 0000000..694b015 --- /dev/null +++ b/ipl/gpacks/weaving/tie2pat.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: tie2pat.icn +# +# Subject: Procedure to convert tie-ups to patterns +# +# Author: Ralph E. Griswold +# +# Date: January 28, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ +# +# Links: patutils, tieutils +# +############################################################################ + +link patutils +link tieutils + +procedure tie2pat(tie) + local tieup, matrix + + tieup := tiematrix(tie) + matrix := tieup.matrix + return rows2pat(matrix) + +end diff --git a/ipl/gpacks/weaving/tieimage.icn b/ipl/gpacks/weaving/tieimage.icn new file mode 100644 index 0000000..b6e8cf8 --- /dev/null +++ b/ipl/gpacks/weaving/tieimage.icn @@ -0,0 +1,65 @@ +############################################################################ +# +# File: tieimage.icn +# +# Subject: Program to create images for tie-ups +# +# Author: Ralph E. Griswold +# +# Date: March 6, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces GIF images for tie-ups given in a file named +# on the command line. +# +# The following options are supported: +# +# -b s background, default "white" +# -f s foreground, default "black" +# -s i Cell size; default 10. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: options, tieutils, wopen +# +############################################################################ + +link options +link tieutils +link wopen + +procedure main(args) + local tie, panel, count, input, prefix, opts, size, fg, bg + + opts := options(args, "b:f:s+") + + bg := \opts["b"] | "white" + fg := \opts["f"] | "black" + size := \opts["s"] | 10 + + input := open(args[1]) | stop("*** cannot open file") + + args[1] ? { + prefix := tab(upto('.')) | "tie" + } + + prefix ||:= "_" + + count := 0 + + while tie := read(input) do { + panel := showtie(tie, size, fg, bg) + WriteImage(panel.window, prefix || right(count +:= 1, 3, "0") || ".gif") + WClose(panel.window) + } + +end diff --git a/ipl/gpacks/weaving/tieutils.icn b/ipl/gpacks/weaving/tieutils.icn new file mode 100644 index 0000000..7f5bb4b --- /dev/null +++ b/ipl/gpacks/weaving/tieutils.icn @@ -0,0 +1,222 @@ +############################################################################ +# +# File: tieutils.icn +# +# Subject: Procedures related to weaving tie-ups +# +# Author: Ralph E. Griswold +# +# Date: June 15, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# imr2tie(imr) converts g2 image record to tie-ip +# +# pat2tie(pat) converts bi-level pattern to tie-up string +# +# pat2tier(pat) converts bi-level pattern to tie-up record +# +# showtie(s, size, fg, bg) +# produces a hidden window for the tie-up as a matrix +# with the specified foreground and background colors +# +# testtie(s) succeeds if s is a valid tie-up but fails otherwise +# +# tie2imr(s) converts tie-up to g2 image record +# +# tie2pat(tie) converts tie-up to bi-level pattern +# +# tie2coltier(s) creates a black/white color tieup-record for +# tie-up s +# +# tie2tier(s) creates a 0/1 tie-up record for tie-up s +# +# tier2rstring(r) creates a tie-up string from a tie-up record +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: cells, wopen, patutils, imrutils +# +############################################################################ + +link cells +link wopen +link patutils +link imrutils + +record tie(shafts, treadles, matrix) + +procedure imr2tie(imr) #: convert image record to tie-up + + return imr.width || ";" || *imr.pixels / imr.width || ";" || imr.pixels + +end + +procedure pat2tie(pat) #: convert pattern to tie-up string + local matrix, tieup, shafts, treadles + + pat ? { # OLD-STYLE BIT STRING TIE-UP + if shafts := tab(upto(',')) & + move(1) & + treadles := tab(upto(',')) & + move(1) then { + matrix := list(shafts) + while put(matrix, move(treadles)) + } + else matrix := pat2rows(pat) + } + + tieup := tie(*matrix[1], *matrix, matrix) + + return tier2string(tieup) + +end + +procedure pat2tier(pat) #: convert pattern to tie-up record + local matrix + + matrix := pat2rows(pat) + + return tie(*matrix[1], *matrix, matrix) + +end + +# Set up empty palette grid + +procedure showtie(tieup, cellsize, fg, bg) #: create image of tie-up + local x, y, panel, row, n, m, color + + /cellsize := 10 + + tieup ?:= { + n := tab(upto(';')) & + move(1) & + m := tab(upto(';')) & + move(1) & + tab(0) + } | stop("*** invalid tieup") + + panel := makepanel(n, m, cellsize, fg, bg) + + tieup ? { + y := 1 + while row := move(n) do { + every x := 1 to n do { + color := if row[x] == "1" then "black" else "white" + colorcell(panel, x, y, color) + } + y +:= 1 + } + } + + return panel + +end + +procedure testtie(s) #: test validity of tie-up s + local n, m, bits + + s ? { + n := (0 < integer(tab(upto(';')))) & + move(1) & + m := (0 < integer(tab(upto(';')))) & + move(1) & + bits := tab(0) + } | fail # bad header + + if *(cset(bits) -- '01') > 0 then fail # illegal characters + + if *bits ~= (n * m) then fail # wrong length + + return s + +end + +procedure tie2imr(tie) #: convert tie-up to image record + local width + + tie ? { + width := tab(upto(';')) + move(1) + tab(upto(';') + 1) + return imstoimr(width || ",g2," || tab(0)) + } + +end + +procedure tie2pat(shafts, treadles, tie) #: convert tie-up record to ims + local tieup, matrix + + tieup := tie2tier(shafts, treadles, tie) + matrix := tieup.matrix + return rows2pat(matrix) + +end + +procedure tie2tier(shafts, treadles, tieup) #: create 0/1 tie-up record + local matrix + + matrix := [] + + tieup ? { + every 1 to treadles do + put(matrix, move(shafts)) + } + + return tie(shafts, treadles, matrix) + +end + +procedure tie2coltier(tieup) #: create color tie-up record + local result, shafts, treadles, rec + + result := [] + + if not upto(';', tieup) then # old-style tie-up + tieup := "8;8;" || tieup + + tieup ? { + ( + shafts := tab(upto(';')) & + move(1) & + treadles := tab(upto(';')) & + move(1) + ) | stop("*** invalid tieup") + every 1 to shafts do + put(result, tcolors(move(treadles))) + } + + return tie(shafts, treadles, result) + +end + +procedure tcolors(s) + local i, result + + result := [] + + every i := 1 to *s do + put(result, if s[i] == "0" then "black" else "white") + + return result + +end + +procedure tier2string(rec) #: convert tie-up record to string + local result + + result := "" + + every result ||:= !rec.matrix + + return result + +end diff --git a/ipl/gpacks/weaving/tpath.icn b/ipl/gpacks/weaving/tpath.icn new file mode 100644 index 0000000..e5dcb94 --- /dev/null +++ b/ipl/gpacks/weaving/tpath.icn @@ -0,0 +1,88 @@ +############################################################################ +# +# File: tpath.icn +# +# Subject: Procedures to create paths using Turtle Graphics +# +# Author: Ralph E. Griswold +# +# Date: December 27, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. Does *not* require graphics. +# +############################################################################ +# +# Links: gobject, turtle +# +############################################################################ + +link gobject +link turtle + +invocable all + +global T_path +global TDraw_t +global TDrawto_t + +procedure TPath(x, y, d) #: start turtle path + + TInit := TReset := 1 # disable turtle initializations + DrawLine := PathPoint + + T_stack := [] + T_scale := 1.0 + T_x := \x | 0 + T_y := \y | 0 + T_deg := d | -90.0 + T_path := [Point(T_x, T_y)] + + return + +end + +procedure PathPoint(W, x1, y1, x2, y2) #: put point on path + + return put(T_path, Point(x2, y2)) + +end + +procedure pathtoargs(path) #: convert path to argument list + local args, pt + + args := [] + + every pt := !path do + put(args, pt.x, pt.y) + + return args + +end + +procedure argstopath(args) # convert argument list to path + local path + + path := [] + + while put(path, Point(get(args), get(args))) + + return path + +end + +procedure DrawPath(path) #: draw path + static drawline + + initial drawline := proc("DrawLine", 0) + + drawline ! pathtoargs(path) + + return + +end diff --git a/ipl/gpacks/weaving/unravel.icn b/ipl/gpacks/weaving/unravel.icn new file mode 100644 index 0000000..b15750b --- /dev/null +++ b/ipl/gpacks/weaving/unravel.icn @@ -0,0 +1,727 @@ +############################################################################ +# +# File: unravel.icn +# +# Subject: Program to find thread colors for weaving +# +# Author: Gregg M. Townsend +# +# Date: June 23, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Unravel solves a coloring problem inspired by weaving. Given a +# multicolored rectangular pattern, assign colors to warp and weft +# threads that will allow the pattern to be woven on a loom. +# We ignore questions of structural integrity and insist only +# that each cell's color be matched by either the corresponding +# warp thread (column color) or weft thread (row color). +# +############################################################################ +# +# Usage: unravel [-bdnrtv] filename +# +# -b: run in batch mode (don't show results in window) +# -d: show details of solution on &error +# -n: no shortcuts: retain solid & duplicate rows & cols +# -r: raw output on &output of columns, rows, grid data +# -t: include timing breakdown in result message +# -v: write verbose commentary on &output +# +# Input is an image file (GIF, XBM) to be mapped to the c1 palette +# (these require graphics, even in batch mode) or an image string +# acceptable to readims(). The maximum size is 256 x 256. +# +# After analysis, the pattern is declared "solved" or "insoluble". +# This result is displayed in the title of the result window and +# printed on standard error output. +# +# The output window shows an enlarged copy of the pattern with row +# and column color assignments along the top, bottom, and sides. +# With an insoluble or pattern, colors just reflect the program +# state at termination. Type "q" in the window to exit. +# +# A one-line result summary is always written to &errout. The -d +# option adds two more lines giving the row and column assignments, +# with the colors coded by the "c1" color palette. +# +# With the -r option, three lines are written to &output: +# column colorings +# row colorings +# grid data +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics, imscolor, imsutils, numbers, options, random +# +############################################################################ + + + +link graphics +link imscolor +link imsutils +link numbers +link options +link random + + + +record vector( # one row or column + index, # index of this row/column (1-based) + label, # row/column label: "rnnn" or "cnnn" + mchar, # char used in mapping + cells, # string of colors in row/column cells + live, # string of colors in active row/column cells + fam, # color family + ignored # non-null if to be ignored (if solved, or if redundant) +) + +record family( # a family of vectors that must all be the same color + vset, # set of vectors + color # assigned color (null if not yet set) +) + + + +global opts # command options +global fname # input file name +global logfile # output file for logging, if -v specified +global t1,t2,t3,t4,t5 # &time measurements + +global imstring # image string of original pattern specification +global data # raw cell data +global rows # list of row vectors +global cols # list of column vectors + +global mapchars # string of chars used for col & row mapping +global rowvalid # valid columns in row +global colvalid # valid columns in column + + + +############################## CONTROL ############################## + + + +procedure main(args) + local n, v + + opts := options(args, "bdnrtv") + if \opts["v"] then + logfile := &output + else + log := 1 # disable logging function + + *args = 1 | stop("usage: ", &progname, " [-bdnrtv] imsfile") + fname := get(args) + imstring := load(fname) | abort("can't load file") + t1 := &time + + setpattern(imstring) | abort("can't parse pattern string") + setmaps() # initialize mapping strings + loggrid() # show problem diagram + t2 := &time + + if /opts["n"] then { # if not -n, then reduce problem + while dupls(rows | cols) | solids() do + setmaps() # reduce problem size + loggrid() # show reduced problem + } + t3 := &time + + # check for quads until no longer worthwhile + while (not trivial()) & quad(rows | cols) do { + setmaps() # reduce problem size + loggrid() # show reduced problem + } + t4 := &time + + log("choosing colors arbitrarily") + every v := active(rows | cols) do # will solve or show impossible + setcolor(v, ?v.live) + setmaps() # should detect solved problem + + abort("didn't finish!") +end + + + +############################## INPUT ############################## + + + +# load(fname) -- load image from file, convert to imstring if necessary + +procedure load(fname) + local f, s + + if f := WOpen("canvas=hidden", "image=" || fname) then { + if WAttrib(f, "width" | "height") > 256 then + abort("image exceeds 256 x 256") + s := Capture(f, "c1") + WClose(f) + return s + } + + f := open(fname) | fail + s := readims(f) | fail + close(f) + return s +end + + + +# setpattern(im) -- initialize pattern data from image string + +procedure setpattern(im) + local ncols, nrows, i, j, s + + mapchars := string(&cset) + + imstring := im + ncols := imswidth(imstring) | fail + nrows := imsheight(imstring) | fail + data := (imstring ? 3(tab(upto(',')+1), tab(upto(',')+1), tab(0))) | fail + if *data ~= nrows * ncols then + abort("malformed image string: wrong data length") + if nrows > 256 || ncols > 256 then + abort("pattern exceeds 256 x 256") + + rows := [] + data ? while addvector(rows, "r", move(ncols)) + + cols := [] + every i := 1 to ncols do { + s := "" + every j := i to *data by ncols do + s ||:= data[j] + addvector(cols, "c", s) + } + return +end + + + +# addvector(vlist, lchar, data) -- add new vector to vlist, labeled with lchar + +procedure addvector(vlist, lchar, data) + local v, f + + v := vector() + f := family() + v.index := *vlist + 1 + v.label := lchar || v.index + v.mchar := mapchars[*vlist + 1] + v.cells := data + v.fam := f + f.vset := set() + insert(f.vset, v) + put(vlist, v) + return +end + + + +############################## ANALYSIS ############################## + + + +# solids() -- check for families with remaining members all one color +# +# succeeds if it accomplishes anything + +procedure solids() + local f, v, n + + log("checking for solids (r,c)") + n := 0 + every v := active(rows) | active(cols) do { + if *cset(v.live) = 1 then { + setcolor(v, v.live[1]) + n +:= 1 + } + } + return 0 < n +end + + + +# dupls(vlist) -- check for duplicate (identical) vectors in a list +# +# succeeds if it accomplishes anything + +procedure dupls(vlist) + local s, t, v, w, n + + log("checking for duplicates (", vlist[1].label[1], ")") + t := table() + n := 0 + + every v := active(vlist) do { + s := v.cells + if not (/t[s] := v) then { + samecolor(t[s], v) + v.ignored := 1 # set inactive + n +:= 1 + } + } + + return 0 < n +end + + + + +# trivial() -- succeed if this is a trivial case +# +# A trivial case is one that can be solved by coloring remaining +# vectors arbitrarily with any of the colors they contain. +# (Color one vector, force others, repeat until done.) + +procedure trivial() + local c, s, cs, union, isectn + + if *rowvalid < 3 & *colvalid < 3 then + return # trivial (2x2 or smaller) + if *rowvalid < 2 | *colvalid < 2 then + return # trivial (1xn) + + union := '' + isectn := &cset + + every cs := cset(active(rows | cols).live) do { + union ++:= cs + isectn **:= cs + } + + if *union < 3 then + return # trivial (bilevel or solid pattern) + +# If a pattern can be permuted into a solid color except for +# one diagonal line (or parts of one), then it is trivially solved. + + if *isectn = 1 then { # if single background color + c := string(isectn) + every s := active(rows | cols).live do { + s ? { + tab(many(c)) + move(1) + tab(many(c)) + if not pos(0) then + fail # if not a diagonal case + } + } + log("found diagonal case") + return # trivial (diagonal case) + } + + fail # not a trivial case +end + + + +# quad(vlist) -- find a 2x2 forcing subproblem +# +# Looks for AABC pattern with AA oriented along one vector of vlist. +# Succeeds after finding one quad pattern and forcing colors. + +procedure quad(vlist) + local wlist, a, b, c, s, t, x1, x2, y1, y2, ss, ts + + log("checking quads (", vlist[1].label[1], ")") + every put(wlist := [], active(vlist)) + shuffle(wlist) # for better chance of quick solution + + every x1 := 1 to *wlist do { + s := wlist[x1].live # potential AA vector + ss := cset(s) + every x2 := (x1 ~= (1 to *wlist)) do { + t := wlist[x2].live # potential BC vector + ts := cset(t) + if *(ss ++ ts) < 3 then + next + every y1 := 1 to *s do { + a := s[y1] + b := t[y1] + if a == b then next + if *(ts -- a -- b) = 0 + then next + every y2 := y1 + 1 to *s do { + if s[y2] ~== a then next + # now have found AA at subscripts y1, y2 + c := t[y2] + if c == (a | b) then next + log("found pattern: ", a, a, b, c, " ", + wlist[x1].label, " ", wlist[x2].label, + " [", y1, "] [", y2, "]") + setcolor(wlist[x1], a) + return # return after finding and forcing one + } + } + } + } + fail +end + + + +# active(vlist) -- generate vlist entries that are not being ignored + +procedure active(vlist) + local v + + every v := !vlist do + if /v.ignored then + suspend v +end + + + +############################## MANIPULATION ############################## + + + +# setmaps() -- recompute mapping strings for ignoring cols and rows + +procedure setmaps() + local v + + rowvalid := vectmap(cols) + colvalid := vectmap(rows) + + every v := active(rows) do + v.live := map(rowvalid, mapchars[1+:*cols], v.cells) + every v := active(cols) do + v.live := map(colvalid, mapchars[1+:*rows], v.cells) + + if *colvalid = 0 | *rowvalid = 0 then + success() + return +end + + + +# vectmap(vlist) -- concatenate mapping chars of non-ignored vector entries + +procedure vectmap(vlist) + local s, v + + s := "" + every v := active(vlist) do + s ||:= v.mchar + return s +end + + + +############################## CONSTRAINTS ############################## + + + +# samecolor(v, w) -- link together two vectors that must be the same color + +procedure samecolor(v, w) + local vfam, wfam, f, x + + vfam := v.fam + wfam := w.fam + if vfam === wfam then { + log("samecolor ", v.label, " ", w.label, ": ", + *vfam.vset, " vectors already linked") + return + } + + if \vfam.color ~== \wfam.color then + insoluble("cannot merge " || v.label || " and " || w.label) + + f := family() + f.vset := vfam.vset ++ wfam.vset + f.color := \vfam.color | \wfam.color | &null + every x := !f.vset do + x.fam := f + + log("samecolor ", v.label, " ", w.label, ": ", *f.vset, " vectors") + return +end + + + +# setcolor(v, c) -- force vector v to color c, checking consequences + +procedure setcolor(v, c) + local f, fc + static depth, todo + initial { + depth := 0 + todo := set() + } + + f := v.fam + fc := f.color + if \v.ignored & fc === c then + return + + log("setcolor ", v.label, " ", c) + + if \fc ~== c then { + f.color := &null + insoluble(v.label || " cannot be both " || fc || " and " || c) + } + + f.color := c + v.ignored := 1 # set inactive + insert(todo, v) # but make note check forcings + + if depth > 0 then # avoid deep recursion + return + + # check forcings only if not nested + + depth +:= 1 + while v := ?todo do { + ckforce(v) + delete(todo, v) + } + depth -:= 1 + return +end + + + +# ckforce(v) -- check for forced colorings of vectors intersecting v + +procedure ckforce(v) + local c, cs, vlist + + log("checking consequences of coloring ", v.label, " ", v.fam.color) + + cs := &cset -- v.fam.color + vlist := case v.label[1] of { + "r": cols + "c": rows + default: abort("bad label in ckforce(): ", v.label) + } + + v.cells ? while tab(upto(cs)) do + setcolor(vlist[&pos], move(1)) + return +end + + + +############################## LOGGING ############################## + + + +# log(s,...) -- write a log message + +procedure log(args[]) + if *args > 0 then + push(args, " ", &time - t1, "t=") + push(args, logfile) + write ! args +end + + + +# loggrid() -- write grid diagram to logfile + +$define LBLSIZE 4 # number of rows to allow for vertical column labels +$define PADUPTO 32 # space between columns if no more than this many + +procedure loggrid() + local i, r, c, n, pad + + if /logfile then + return + + log("loggrid: ", *rowvalid, " x ", *colvalid) + + if *cols <= PADUPTO then + pad := " " + + # col labels + every i := 1 to LBLSIZE do { + writes(logfile, " ") + every c := active(cols) do + writes(logfile, pad, right(c.label, LBLSIZE)[i]) + write(logfile) + } + write(logfile) + + # rows: labels, data, color[s] + every r := active(rows) do { + i := r.index + writes(logfile, right(r.label, 5), " ") + every writes(logfile, pad, !r.live) + write(logfile, " ", \r.fam.color | " ") + } + + # bottom label: column color + write(logfile) + writes(logfile, " ") + every c := active(cols) do + writes(logfile, pad, \c.fam.color | " ") + write(logfile) + + return +end + + + +############################## TERMINATION ############################## + + + +# abort(s,...) -- abort due to error + +procedure abort(s[]) + push(s, ": ", fname, " ") + stop ! s +end + + + +# insoluble(reason) -- terminate run, because no solution is possible + +procedure insoluble(reason) + log() + log("no solution possible: ", reason) + done("insoluble") +end + + + +# success() -- report successful solution + +procedure success() + local v, r, c + + log() + log("solution found!") + + every v := !rows | !cols do # set colors for don't-cares + /v.fam.color := ?v.cells + + every (!rows | !cols).ignored := &null # to get them printed + setmaps() # likewise + + r := c := "" + every r ||:= (!rows).fam.color + every c ||:= (!cols).fam.color + done("solved", r, c) +end + + + +# done(label, rowcolors, colcolors) -- display final resolution, and exit + +procedure done(label, rowcolors, colcolors) + local fn, s1, s2, s3, s4, s5, s6 + + loggrid() + log() + flush(\logfile) + + if /opts["t"] then + write(&errout, " ", left(label, 11), fname) + else { + t5 := &time + /t4 := t5 + /t3 := t5 + /t2 := t5 + s1 := frn((t1 - 0) / 1000.0, 7, 2) # loading time + s2 := frn((t2 - t1) / 1000.0, 6, 2) # parsing + s3 := frn((t3 - t2) / 1000.0, 6, 2) # solids & duplicates + s4 := frn((t4 - t3) / 1000.0, 6, 2) # quads + s5 := frn((t5 - t4) / 1000.0, 6, 2) # arbitrary + s6 := frn((t5 - t1) / 1000.0, 8, 2) # total excl loading + write(&errout, s1, s2, s3, s4, s5, s6, " ", left(label, 11), fname) + } + + if \opts["d"] then { # if details wanted + write(&errout, " cols: ", \colcolors) + write(&errout, " rows: ", \rowcolors) + } + flush(&errout) + + if \opts["r"] & \colcolors then { # if raw data wanted (and if solved) + write(colcolors) + write(rowcolors) + every writes(active(rows).live) + write() + flush(&output) + } + + if /opts["b"] then { # if not batch mode, display in window + dpygrid(label) + WDone() + } + exit() +end + + + +# dpygrid(label) -- display grid in window + +$define BACKGROUND "pale-weak-blue-cyan" +$define PREFSZ 800 # preferred size after scaling +$define MAXMAG 10 # maximum magnification + +$define STRIPE 2 # space for thread color(s) +$define GAP 1 # margin around image + +procedure dpygrid(label) + local s + static w, h, z, p, v + + initial { + p := imspalette(imstring) + w := STRIPE + GAP + *cols + GAP + STRIPE + h := STRIPE + GAP + *rows + GAP + STRIPE + z := PREFSZ / w + z >:= PREFSZ / h + z <:= 1 + z >:= MAXMAG + WOpen("width=" || (z * w), "height=" || (z * h), "bg=" || BACKGROUND) | + abort("can't open window") + } + + EraseArea() + DrawImage(STRIPE + GAP, STRIPE + GAP, imstring) + every v := !rows do { + dpycolor(v, p, STRIPE - 1, STRIPE + GAP + v.index - 1) + dpycolor(v, p, w - STRIPE, STRIPE + GAP + v.index - 1) + } + every v := !cols do { + dpycolor(v, p, STRIPE + GAP + v.index - 1, STRIPE - 1) + dpycolor(v, p, STRIPE + GAP + v.index - 1, h - STRIPE) + } + Fg("black") + + Zoom(0, 0, w, h, 0, 0, z * w, z * h) + + if *rows <= z * STRIPE & *cols <= z * STRIPE then + every DrawImage(1 | z * w - *cols - 1, 1 | z * h - *rows - 1, imstring) + + WAttrib("label=" || fname || ": " || label) + return +end + + + +# dpycolor(v, p, x, y) -- display assigned color, if any + +procedure dpycolor(v, p, x, y) + if Fg(PaletteColor(p, \v.fam.color)) then + DrawPoint(x, y) +end diff --git a/ipl/gpacks/weaving/wallpapr.icn b/ipl/gpacks/weaving/wallpapr.icn new file mode 100644 index 0000000..c1c30a0 --- /dev/null +++ b/ipl/gpacks/weaving/wallpapr.icn @@ -0,0 +1,96 @@ +############################################################################ +# +# File: wallpapr.icn +# +# Subject: Program to generate mutant shadow weave wallpaper +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is based on the Painter weave "Shadow Op Art". +# +############################################################################ +# +# Links: random, tieutils, weavegif, weavutil +# +############################################################################ + +link random +link tieutils +link weavegif +link weavutil + +global anchors +global palpat +global palindromes + +procedure main(args) + local tieup, palette, mutant, win1, win2, colorways, i + + randomize() + + # In this instantiation, the tieup and palindrome sequence + # basis are fixed. Anchors are shuffled (permuted randomly), + # but the palindromes attached to the anchors. That is, + # the anchors and attached palindromes are permuted together. + + anchors := "1234567" + palpat := "82143657" + tieup := "8,#8040201008040201" # NOTE: this is direct tie-up + palette := "g2" + + palindromes := list(*palpat) + + every i := 1 to *palpat do + palindromes[i] := "[" || palpat[1:i] || "!" || palpat[i] || "]" + + mutant := draft() + mutant.name := "Shadow Weave Variation" + mutant.shafts := 8 + mutant.treadles := 8 + mutant.colors := PaletteChars(palette) + mutant.palette := palette + mutant.tieup := tieup + + every 1 to 10 do { + anchors := shuffle(anchors) + mutant.threading := mutant.treadling := "[" || thread(1) || "|]" + mutant.warp_colors := "12" + mutant.weft_colors := "21" + win2 := weavegif(expandpfd(mutant), ["canvas=hidden"]) + WriteImage(win2, "bandw.gif") + WDelay(win2, 10000) + WClose(win2) + } + + # Because of a memory leak (possibly in X), it is necessary to + # terminate this program at intervals and start up a new version. + + system("wallpapr &") + + exit() + +end + +# Compute sequence as pattern-form. + +procedure thread(i) + local result + + if i = *palpat then return "" + + result := "-[" || anchors[i] || "-[" || palindromes[i] || + thread(i + 1) || "]]" + + if i = 1 then result := result[2:0] + + return result + +end diff --git a/ipl/gpacks/weaving/wdialog.icn b/ipl/gpacks/weaving/wdialog.icn new file mode 100644 index 0000000..61eef92 --- /dev/null +++ b/ipl/gpacks/weaving/wdialog.icn @@ -0,0 +1,53 @@ +############################################################################ +# +# File: wdialog.icn +# +# Subject: Procedure for warp/weft sequences +# +# Author: Ralph E. Griswold +# +# Date: May 10, 1999 +# +############################################################################ +# +# This dialog procedure handles the editing and manipulation of the +# warp and weft sequences for seqdraft. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: dsetup +# +############################################################################ + +link dsetup + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure 3_db(win, deftbl) +static dstate +initial dstate := dsetup(win, + ["3_db:Sizer::1:0,0,587,348:Warp and Weft",], + ["cancel:Button:regular::313,310,50,20:Cancel",], + ["copy1:Button:regular::163,68,105,20:Copy Weft",], + ["copy2:Button:regular::163,228,105,20:Copy Warp",], + ["default1:Button:regular::333,70,56,20:Default",], + ["default2:Button:regular::333,228,56,20:Default",], + ["define1:Button:regular::407,69,49,20:Define",], + ["define2:Button:regular::407,228,49,20:Define",], + ["label1:Label:::235,8,91,13:Warp Sequence",], + ["label2:Label:::235,154,91,13:Weft Sequence",], + ["line1:Line:::447,3,495,3:",], + ["line2:Line:::0,125,594,125:",], + ["line3:Line:::2,280,596,280:",], + ["okay:Button:regular::244,310,50,20:Okay",], + ["read1:Button:regular::284,70,35,20:Read",], + ["read2:Button:regular::284,228,35,20:Read",], + ["text1:Text::79:18,31,563,19:\\=",], + ["text2:Text::79:10,184,563,19:\\=",], + ) +return dpopup(win, deftbl, dstate) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/weavdefs.icn b/ipl/gpacks/weaving/weavdefs.icn new file mode 100644 index 0000000..1a59a0e --- /dev/null +++ b/ipl/gpacks/weaving/weavdefs.icn @@ -0,0 +1,24 @@ +############################################################################ +# +# File: weavdefs.icn +# +# Subject: Definitions for weaving applications +# +# Author: Ralph E. Griswold +# +# Date: May 25, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These definitions are used in some weaving programs. +# +############################################################################ + +$define C1Ex "!#$%&'()*+,-./:;<=>?@[]^`{|}" # special characters in c1 +$define C1In &cset[162+:28] # safe replacements + +$define Mask ("123456789" || &letters || &cset[162:-1]) # NEEDS FIXING diff --git a/ipl/gpacks/weaving/weavegif.icn b/ipl/gpacks/weaving/weavegif.icn new file mode 100644 index 0000000..cf7a0b5 --- /dev/null +++ b/ipl/gpacks/weaving/weavegif.icn @@ -0,0 +1,94 @@ +############################################################################ +# +# File: weavegif.icn +# +# Subject: Procedure to produce a woven image from a draft +# +# Author: Ralph E. Griswold +# +# Date: June 13, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces a woven image from a pattern-form draft, which +# is passed to it as it's first argument. Window attributes may be +# passed as a list in the second argument +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: interact +# +############################################################################ + +link interact + +procedure weavegif(weave, attribs) #: create GIF from PDF + local x, y, color, treadle, i, j, treadle_list, shafts, k, treadles + local win, palette, colors, width, height, warp_colors, weft_colors + local threading, treadling, matrix + + /attribs := [] + + threading := weave.threading + treadling := weave.treadling + warp_colors := weave.warp_colors + weft_colors := weave.weft_colors + palette := weave.palette + colors := weave.colors + treadles := weave.treadles + shafts := weave.shafts + matrix := (pat2tier(weave.tieup)).matrix + + put(attribs, "label=" || weave.name, "size=" || *threading || "," || + *treadling) + + win := (WOpen ! attribs) | { + Notice("Cannot open window for woven image.") + fail + } + + # Draw warp threads as "background". + + every i := 0 to *threading - 1 do { + Fg(win, PaletteColor(palette, + colors[sympos(warp_colors[i + 1])])) + DrawLine(win, i, 0, i, *treadling - 1) + } + + # Precompute points at which weft threads are on top. + + treadle_list := list(treadles) + every !treadle_list := [win] + + every i := 1 to treadles do + every j := 1 to shafts do + if matrix[i, j] == "0" then + every k := 1 to *threading do + if sympos(threading[k]) == j then + put(treadle_list[i], k - 1, 0) + + # "Overlay" weft threads. + + every y := 1 to *treadling do { + treadle := sympos(treadling[y]) | + stop(&errout, "*** treadling bogon") + Fg(win, PaletteColor(palette, + weave.colors[sympos(weft_colors[y])]) | + stop("bad weft color specification: ", + weave.colors[sympos(weft_colors[y])])) + WAttrib(win, "dy=" || (y - 1)) + if *treadle_list[treadle] = 1 then next # blank pick + DrawPoint ! treadle_list[treadle] + } + + return win + +end diff --git a/ipl/gpacks/weaving/weaver.icn b/ipl/gpacks/weaving/weaver.icn new file mode 100644 index 0000000..7485526 --- /dev/null +++ b/ipl/gpacks/weaving/weaver.icn @@ -0,0 +1,520 @@ +############################################################################ +# +# File: weaver.icn +# +# Subject: Program to create weaving drafts +# +# Author: Ralph E. Griswold +# +# Date: May 30, 1999 +# +############################################################################ +# +# This program creates weaving drafts. +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: cells, expander, interact, psrecord, tieutils, vsetup, weaving, +# weavutil +# +############################################################################ + +link cells +link expander +link interact +link psrecord +link tieutils +link vsetup +link weaving +link weavutil + +global drawdown +global mutant +global interface +global plane +global root +global threading +global tieup +global treadling +global vidgets +global weaving # current weaving draft +global tieup_cells +global tieup_pane +global tieup_panel +global drawdown_cells +global drawdown_pane +global drawdown_panel +global threading_cells +global threading_pane +global threading_panel +global treadling_cells +global treadling_pane +global treadling_panel +global psstart +global psdone + +$define CellSize 5 +$define TieupSize 8 +$define ThreadingSize 175 + +procedure main() + local atts + + atts := ui_atts() + + put(atts, "posx=0", "posy=0") + + interface := (WOpen ! atts) | stop("can't open window") + + # Keep user interface separate from draft interface because of + # screen layout considerations, if nothing else. Could "weave" + # image on interface. + + vidgets := ui() # set up vidgets + root := vidgets["root"] + + init() + + repeat { + while *Pending() > 0 do + ProcessEvent(root, , shortcuts) + } + +end + +procedure colors_cb() + + return + +end + +procedure options_cb(vidget, value) + + case value[1] of { + "PostScript On" : ps(1) + "PostScript Off" : ps() + } + + return + +end + +procedure ps(sw) + + if \sw then { + psstart := PSStart + psdone := PSDone + } + else { + psstart := -1 + psdone := -1 + } + + return + +end + +procedure process_drawdown() + local coord + + if not(Event(drawdown_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(drawdown_panel, &x, &y) | fail + + return + +end + +procedure process_tieup() + local coord + + if not(Event(tieup_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(tieup_panel, &x, &y) | fail + + return + +end + +procedure process_threading() + local coord + + if not(Event(threading_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(threading_panel, &x, &y) | fail + + return + +end + +procedure process_treadling() + local coord + + if not(Event(treadling_pane) === (&lpress | &rpress | &mpress)) then + fail + + coord := cell(treadling_panel, &x, &y) | fail + + return + +end + +procedure init() + + threading := vidgets["threading"] + treadling := vidgets["treadling"] + tieup := vidgets["tie-up"] + drawdown := vidgets["drawdown"] + + # Note: The additional rows and columns are for the threading and + # treadling colors. + + tieup_cells := makepanel(TieupSize, TieupSize, CellSize, , + "white" , "black") | bad_panel("tieup") + threading_cells := makepanel(ThreadingSize, TieupSize + 1, CellSize, , + "white" , "black") | bad_panel("threading") + treadling_cells := makepanel(TieupSize + 1, ThreadingSize, CellSize, , + "white" , "black") | bad_panel("treadling") + drawdown_cells := makepanel(ThreadingSize, ThreadingSize, CellSize, , + "white" , "black") | bad_panel("drawdown") + + plane := WOpen( + "label=draft", + "width=" || (WAttrib(tieup_cells.window, "width") + + WAttrib(threading_cells.window, "width") + 2 * CellSize), + "height=" || (WAttrib(tieup_cells.window, "height") + + WAttrib(treadling_cells.window, "height") + 2 * CellSize) + ) + + tieup_pane := Clone( + plane, + "dx=0", + "dy=0", + "width=" || (WAttrib(tieup_cells.window, "width") + + WAttrib(drawdown_cells.window, "width")), + "height=" || (WAttrib(tieup_cells.window, "height") + + WAttrib(drawdown_cells.window, "height")), + ) | bad_window("tieup") + + tieup_panel := copy(tieup_cells) + tieup_panel.window := tieup_pane + WAttrib(tieup_pane, "canvas=normal") + + treadling_pane := Clone( + plane, + "dx=0", + "dy=" || (WAttrib(tieup_cells.window, "height") + 2 * CellSize), + "width=" || WAttrib(treadling_cells.window, "width"), + "height=" || WAttrib(treadling_cells.window, "height"), + ) | bad_window("treadling") + + treadling_panel := copy(treadling_cells) + treadling_panel.window := treadling_pane + + threading_pane := Clone( + plane, + "dx=" || (WAttrib(tieup_cells.window, "width") + 2 * CellSize), + "dy=0", + "width=" || WAttrib(threading_cells.window, "width"), + "height=" || (WAttrib(threading_cells.window, "height") + + WAttrib(tieup_pane, "width")) + ) | bad_window("threading") + + threading_panel := copy(threading_cells) + threading_panel.window := threading_pane + WAttrib(threading_pane, "canvas=normal") + + drawdown_pane := Clone( + plane, + "dx=" || (WAttrib(tieup_cells.window, "width") + 2 * CellSize), + "dy=" || (WAttrib(tieup_cells.window, "height") + 2 * CellSize), + "width=" || (WAttrib(drawdown_cells.window, "width") + + WAttrib(tieup_cells.window, "width")), + "height=" || (WAttrib(drawdown_cells.window, "height") + + WAttrib(tieup_cells.window, "height")) + ) | bad_window("drawdown") + + drawdown_panel := copy(drawdown_cells) + drawdown_panel.window := drawdown_pane + WAttrib(drawdown_pane, "canvas=normal") + + clear_panes() + + Raise(interface) + + ps() # start with PostScript disabled + + return + +end + +procedure bad_window(s) + + Notice("Cannot open window for " || s || ".") + + exit() + +end + +procedure bad_panel(s) + + Notice("Cannot crate panel for " || s || ".") + + exit() + +end + +procedure clear_panes() + + CopyArea(tieup_cells.window, tieup_pane, 0, 0, , , CellSize, CellSize) + CopyArea(threading_cells.window, threading_pane, 0, 0, , , 0, 0) + CopyArea(treadling_cells.window, treadling_pane, 0, 0, , , 0, 0) + CopyArea(drawdown_cells.window, drawdown_pane, 0, 0, , , 0, 0) + + return + +end + +procedure drawdown_cb(vidget, value) + + case value[1] of { + "warp/weft @B" : draw_down(weaving) + "color @C" : draw_weave(weaving) + } + + return + +end + +procedure file_cb(vidget, value) + + case value[1] of { + "open @O" : open_weave() + "quit @Q" : quit() + "image @I" : draw_image() + "save @S" : save_weave() + } + + return + +end + +procedure quit() + + psdone() + + exit() + +end + +procedure open_weave() + local i, input + static name + + repeat { + if OpenDialog("Open draft:", name) == "Cancel" then fail + name := dialog_value + input := open(name) | { + Notice("Cannot open file.") + next + } + weaving := expandpfd(readpfd(input)) + close(input) + break + } + + mutant := &null + + clear_panes() + + draw_down(weaving) + +end + +procedure draw_down(weaving) +# local bw # RETHINK THIS + +# bw := copy(\weaving) | { +# Notice("No weaving.") +# fail +# } + +# bw.warp_colors := repl("0", *bw.threading) +# bw.weft_colors := repl("1", *bw.treadling) +# bw.palette := "g2" + + draw_weave(weaving) + + return + +end + +procedure draw_image() + + return + +end + +procedure draw_weave(weaving, kind) + local i, treadle, j, x, y, k, treadle_list, c, color + + if /weaving then { + Notice("No weaving.") + fail + } + + WAttrib(interface, "pointer=watch") + WAttrib(plane, "pointer=watch") + + if /mutant then { + mutant := table() + every c := !weaving.colors do { + if /mutant[c] then { + color := PaletteColor(weaving.palette, c) + color := NewColor(color) # may fail -- SHOULD GIVE WARNING + mutant[c] := color + } + } + } + + psstart(tieup_panel.window, "tieup.ps") + + every i := 1 to weaving.shafts do + every j := 1 to weaving.treadles do + colorcell(tieup_panel, i + 1, j + 1, + if weaving.tieup.matrix[i, j] == "0" then "white" else "black") + + psdone() + + psstart(threading_panel.window, "threading.ps") + + every i := 1 to *weaving.threading do + colorcell(threading_panel, i, weaving.threading[i] + 1, "black") + + psdone() + + psstart(treadling_panel.window, "treadling.ps") + + every i := 1 to *weaving.treadling do + colorcell(treadling_panel, weaving.treadling[i] + 1, i, "black") + + every i := 1 to *weaving.threading do + colorcell(threading_panel, i, 1, + mutant[weaving.colors[sympos(weaving.warp_colors[i])]]) + + every i := 1 to *weaving.treadling do + colorcell(treadling_panel, 1, i, + mutant[weaving.colors[sympos(weaving.warp_colors[i])]]) + + x := 1 + + psstart(drawdown_panel.window, "dd1.ps") + + every color := weaving.colors[sympos(!weaving.warp_colors)] do { + color := \mutant[color] | { + Notice("Bad warp color specification: " || color|| ".") + exit() + } + every y := 1 to *weaving.threading do { + colorcell(drawdown_panel, x, y, color) + } + x +:= 1 + } + + psdone() + + treadle_list := list(weaving.treadles) + every !treadle_list := [] + + + every i := 1 to weaving.treadles do + every j := 1 to weaving.shafts do + if weaving.tieup.matrix[i, j] == "1" then + every k := 1 to *weaving.threading do + if sympos(weaving.threading[k]) == j then + put(treadle_list[i], k, 0) + + + psstart(drawdown_panel.window, "dd2.ps") + + every y := 1 to *weaving.treadling do { + treadle := sympos(weaving.treadling[y]) | { + Notice("Treadling bogon.") + exit() + } + + color := \mutant[weaving.colors[sympos(weaving.weft_colors[y])]] | + Notice("Bad weft color specification: " || weaving.weft_colors[y] || + ".") + if *treadle_list[treadle] = 0 then next # blank pick + every i := 1 to *treadle_list[treadle] by 2 do + colorcell(drawdown_panel, treadle_list[treadle][i], y, color) + } + + psdone() + + WAttrib(interface, "pointer=arrow") + WAttrib(plane, "pointer=arrow") + + return + +end + +procedure save_weave() + + if save_file() ~== "Yes" then fail + + every write(dialog_value, weaving[1 to 5]) + + write(dialog_value, tier2string(weaving.tieup)) + + write(dialog_value, weaving[7]) + + close(dialog_value) + + return + +end + +procedure shortcuts(e) + + if &meta then case map(e) of { + "b" : draw_down(weaving) + "c" : draw_weave(weaving) + "i" : draw_image() + "o" : open_weave() + "q" : quit() + "s" : save_weave() + } + + return + +end + +#===<<vib:begin>>=== modify using vib; do not remove this marker line +procedure ui_atts() + return ["size=252,198", "bg=pale gray", "label=Weaver"] +end + +procedure ui(win, cbk) +return vsetup(win, cbk, + [":Sizer:::0,0,252,198:Weaver",], + ["colors:Menu:pull::101,1,50,21:Colors",colors_cb, + ["palette @P","warp","weft"]], + ["drawdown:Menu:pull::36,1,64,21:Drawdown",drawdown_cb, + ["warp/weft @B","color @C"]], + ["file:Menu:pull::0,1,36,21:File",file_cb, + ["open @O","save @S","image @I","quit @Q"]], + ["line1:Line:::0,23,250,23:",], + ["options:Menu:pull::151,2,57,21:Options",options_cb, + ["PostScript On","PostScript Off"]], + ) +end +#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/gpacks/weaving/weaveseq.icn b/ipl/gpacks/weaving/weaveseq.icn new file mode 100644 index 0000000..c1f899e --- /dev/null +++ b/ipl/gpacks/weaving/weaveseq.icn @@ -0,0 +1,47 @@ +############################################################################ +# +# File: weaveseq.icn +# +# Subject: Procedures for sequence drafting +# +# Author: Ralph E. Griswold +# +# Date: May 19, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ +# +# Links: seqfncs, curves, math, random +# +############################################################################ + +link curves +link math +link random +link seqfncs + +procedure apos(c) #: character position relative to "a" + + return ord(c) - ord("a") # may be negative ... + +end + +procedure code_name(s) + + s := map(s) + + s ? { + while upto(&lcase) do { + i := apos(move(1)) + suspend i + } + } + +end diff --git a/ipl/gpacks/weaving/weavrecs.icn b/ipl/gpacks/weaving/weavrecs.icn new file mode 100644 index 0000000..90526f0 --- /dev/null +++ b/ipl/gpacks/weaving/weavrecs.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: weavrecs.icn +# +# Subject: Declarations for weaving language +# +# Author: Ralph E. Griswold +# +# Date: May 2, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These record declarations are used in awl.icn. +# +############################################################################ + +record block(name, p1, p2) +record concatenation(name, p1, p2) +record rundownup(name, p1, p2, symbols) +record extension(name, p, i) +record interleaving(name, p1, p2) +record palindroid(name, p1) +record palindrome(name, s1, s2) +record pbox(name, p1, p2) +record permutation(name, p1, p2) +record repetition(name, p1, i) +record rotation(name, p, i) +record sequence(name, s) +record template(name, p1, p2) +record runupdown(name, p1, p2, symbols) +record runupdownto(name, p1, p2, symbols) +record runupto(name, p1, p2, symbols) diff --git a/ipl/gpacks/weaving/weavutil.icn b/ipl/gpacks/weaving/weavutil.icn new file mode 100644 index 0000000..1da6085 --- /dev/null +++ b/ipl/gpacks/weaving/weavutil.icn @@ -0,0 +1,248 @@ +############################################################################ +# +# File: weavutil.icn +# +# Subject: Procedures to support numerical weavings +# +# Author: Ralph E. Griswold +# +# Date: June 13, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links: expander, patutils, tables, tieutils +# +############################################################################ + +link expander +link patutils +link tables +link tieutils + +$include "weavdefs.icn" + +# PFL weaving parameters + +record PflParams(P, T) + +# Sequence-drafting database record + +record sdb(table, name) # specification database + +record ddb(table) # definition database +record edb(table) # expression database +record tdb(table) # tie-up database + +# Weaving specification + +record weaving( + name, + breadth, + length, + threading, + treadling, + shafts, + treadles, + palette, + colors, + warp_colors, + weft_colors, + tieup, + defns, + links, + comments + ) + +record draft( + name, + threading, + treadling, + warp_colors, + weft_colors, + shafts, + treadles, + palette, + colors, + tieup, + liftplan, + drawdown + ) + +procedure readpfd(input) # read PFD + local pfd + + pfd := draft() + + pfd.name := read(input) & + pfd.threading := read(input) & + pfd.treadling := read(input) & + pfd.warp_colors := read(input) & + pfd.weft_colors := read(input) & + pfd.palette := read(input) & + pfd.colors := read(input) & + pfd.shafts := read(input) & + pfd.treadles := read(input) & + pfd.tieup := read(input) | fail + pfd.liftplan := read(input) # may be missing + + return pfd + +end + +procedure writepfd(output, pfd) #: write PFD + + write(output, pfd.name) + write(output, pfd.threading) + write(output, pfd.treadling) + write(output, pfd.warp_colors) + write(output, pfd.weft_colors) + write(output, pfd.palette) + write(output, pfd.colors) + write(output, pfd.shafts) + write(output, pfd.treadles) + write(output, pfd.tieup) + if *\pfd.liftplan > 0 then write(pfd.liftplan) else write() + + return + +end + +procedure expandpfd(pfd) #: expand PFD + + pfd := copy(pfd) + + pfd.threading := pfl2str(pfd.threading) + pfd.treadling := pfl2str(pfd.treadling) + pfd.warp_colors := pfl2str(pfd.warp_colors) + pfd.weft_colors := pfl2str(pfd.weft_colors) + + pfd.warp_colors := Extend(pfd.warp_colors, *pfd.threading) + pfd.weft_colors := Extend(pfd.weft_colors, *pfd.treadling) + + return pfd + +end + +# Write include file for seqdraft + +procedure write_spec(name, spec, opt, sym) #: write weaving include file + local n, output + static bar + + initial bar := repl("#", 72) + + /opt := "w" + + output := open(name, opt) | fail + + write(output, "$define Reflect ", image(sym)) + + # Literals are output with image(). Other definitions are + # Icon experssions, enclosed in parentheses. + + write(output, "$define Comments ", image(spec.comments)) + write(output, "$define Name ", image(spec.name)) + write(output, "$define Palette ", image(spec.palette)) + write(output, "$define PDB ", image(spec.palette)) + write(output, "$define Colors (", spec.colors, ")") + write(output, "$define WarpColors (", check(spec.warp_colors), ")") + write(output, "$define WeftColors (", check(spec.weft_colors), ")") + write(output, "$define Breadth (", spec.breadth, ")") + write(output, "$define Length (", spec.length, ")") + write(output, "$define Threading (", check(spec.threading), ")") + write(output, "$define Treadling (", check(spec.treadling), ")") + write(output, "$define Shafts (", spec.shafts, ")") + write(output, "$define Treadles (", spec.treadles, ")") + write(output, "$define Tieup ", image(spec.tieup)) + + every n := !keylist(spec.defns) do + write(output, "$define ", n, " ", spec.defns[n]) + + write(output, bar) + + close(output) + + return + +end + +procedure check(s) #: check for pattern form + + if s[1] == "[" then s := "!pfl2str(" || image(s) || ")" + + return s + +end + +procedure display() + + write(&errout, "name=", name) + write(&errout, "threading=", threading) + write(&errout, "treadling=", treadling) + write(&errout, "warp colors=", warp_colors) + write(&errout, "weft colors=", weft_colors) + write(&errout, "tie up=", limage(tieup)) + write(&errout, "palette=", palette) + + return + +end + +procedure sympos(sym) #: position of symbol in symbol list + static mask + + initial mask := Mask + + return upto(sym, mask) # may fail + +end + +procedure possym(i) #: symbol in position i of symbol list + static mask + + initial mask := Mask + + return mask[i] # may fail + +end + +# Procedure to convert a tier to a list of productions + +$define Different 2 + +procedure tier2prodl(tier, name) + local rows, row, count, unique, prodl, prod + + unique := table() + rows := [] + count := 0 + + every row := !tier.matrix do { + if /unique[row] then unique[row] := (count +:= 1) + put(rows, unique[row]) + } + + prod := name || "->" + every prod ||:= possym(!rows + Different) + + prodl := [ + "name:" || "t-" || name, + "comment: ex pfd2wpg " || &dateline, + "axiom:2", + "gener:1", + prod + ] + unique := sort(unique, 4) + + while row := get(unique) do + put(prodl, possym(get(unique) + Different) || "->" || row) + + put(prodl, "end:") + + return prodl + +end diff --git a/ipl/gpacks/weaving/wif2pfd.icn b/ipl/gpacks/weaving/wif2pfd.icn new file mode 100644 index 0000000..7366944 --- /dev/null +++ b/ipl/gpacks/weaving/wif2pfd.icn @@ -0,0 +1,85 @@ +############################################################################ +# +# File: wif2pfd.icn +# +# Subject: Program to convert WIFs to PFDs +# +# Author: Ralph E. Griswold +# +# Date: June 13, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The following options are supported: +# +# -p s palette; default "c1" +# -n s name; default "untitled" +# +# Note: The output is a pattern-form draft with the following lines: +# +# name +# threading sequence +# treadling sequence +# warp color sequence +# weft color sequence +# shafts +# treadles +# palette +# colors +# tieup +# liftplan +# +# There is a problem where there is treadling with multiple treadles +# and no liftplan. *Presumably* that treadling can be used like a +# liftplan, but without, necessarily, a direct tie-up. This problem +# problem has not been addressed yet. +# +# If there is a liftplan, then a direct tie-up is implied by the +# wording in the WIF documentation. However, that's in the interpretation +# of the draft. The tie-up produced here is the one given in the +# +# If there is a liftplan and a treadling with multiple treadles, +# the treadling is ignored. +# +# Also not handled is the possibility of multiple shafts per thread. +# This could be dealt with as for the liftplan. The idea is that +# instead of a threading corresponding to a single shaft, there are +# some number of different shaft patterns, like there are liftplan +# patterns. +# +# The liftplan is represented as concatenated rows of shaft patterns in the +# irder they first appear. Thus, the symbols used for them can be +# reconstructed with the PFD is processed. +# +# This program does not attempt to detect or correct errors in WIFs, +# but it does try to work around some common problems. +# +############################################################################ +# +# Links: options, wifcvt +# +############################################################################ + +link options +link wifcvt + +global data_default +global data_entries +global sections +global wif + +procedure main(args) + local opts, title, palette + + opts := options(args, "n:p:") + + title := \opts["n"] | "untitled" + palette := \opts["p"] | "c1" + + writepfd(&output, wif2pfd(&input, title, palette)) + +end diff --git a/ipl/gpacks/weaving/wifcvt.icn b/ipl/gpacks/weaving/wifcvt.icn new file mode 100644 index 0000000..f42a15e --- /dev/null +++ b/ipl/gpacks/weaving/wifcvt.icn @@ -0,0 +1,408 @@ +############################################################################ +# +# File: wifcvt.icn +# +# Subject: Procedure to convert WIF to PDF record +# +# Author: Ralph E. Griswold +# +# Date: June 13, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program analyzes a Weaving Information File and returns a pattern- +# form draft record. +# +# Information in a WIF that is not necessary for a PFD is ignored. +# +# Since WIFs contain no pattern information, the expressions in the +# PFD are in raw form -- they contain no pattern-forms. +# +# Because of the way the PFD is constructed, the number of shafts is +# the number of different symbols in the threading sequence. +# +# From this, the dimensions of the tie-up, which consists of concatenated +# shaft rows, can be computed. +# +# If there is a liftplan, the symbols in the treadling sequence +# correspond to shaft patterns given in the liftplan. The symbols +# for these pattern shafts are implicit and occur in orde to the number +# of shaft patterns. +# +# There is a problem where there is treadling with multiple treadles +# and no liftplan. *Presumably* that treadling can be used like a +# liftplan, but without, necessarily, a direct tie-up. This problem +# problem has not been addressed yet. +# +# If there is a liftplan, then a direct tie-up is implied by the +# wording in the WIF documentation. However, that's in the interpretation +# of the draft. The tie-up produced here is the one given in the +# +# If there is a liftplan and a treadling with multiple treadles, +# the treadling is ignored. +# +# Also not handled is the possibility of multiple shafts per thread. +# This could be dealt with as for the liftplan. The idea is that +# instead of a threading corresponding to a single shaft, there are +# some number of different shaft patterns, like there are liftplan +# patterns. +# +# The liftplan is represented as concatenated rows of shaft patterns in the +# irder they first appear. Thus, the symbols used for them can be +# reconstructed with the PFD is processed. +# +# This program does not attempt to detect or correct errors in WIFs, +# but it does try to work around some common problems. +# +############################################################################ +# +# Links: tieutils, tables, weavutil +# +############################################################################ + +link tieutils +link tables +link weavutil + +global data_default +global data_entries +global sections +global wif + +procedure wif2pfd(file, title, palette) + local section, line, i, colors, information_sections, data_sections + local color_range, information, data, tieup, shafts + local lst, x, k, r, g, b, color, opts, j, threading, treadling, tie, lift + local warp_colors, weft_colors, threads, treadles, range, format + local color_set, color_tbl, symbols, pfl, maxi, colors_in, liftplan + local lift_set, lift_list, lifting, lift_table, pfd + + /title := "untitled" + /palette := "c1" + + maxi := 0 + + information_sections := [ + "wif", + "contents", + "translations", + "color palette", + "warp symbol palette", + "weft symbol palette", + "text", + "weaving", + "warp", + "weft", + "bitmap image", + "bitmap file" + ] + + data_sections := [ + "notes", + "tieup", + "liftplan", + "color table", + "warp symbol table", + "weft symbol table", + "threading", + "warp thickness", + "warp thickness zoom", + "warp spacing", + "warp spacing zoom", + "warp colors", + "warp symbols", + "treadling", + "weft thickness", + "weft thickness zoom", + "weft spacing", + "weft spacing zoom", + "weft colors", + "weft symbols", + "bitmap image data", + "private" + ] + + data_default := table() + data_entries := table() + + sections := table() + information := table() + data := table() + + wif := [] + + # Read WIF into list. + + while line := trim(read(file)) do + if *line > 0 then put(wif, line) + + # Locate sections. + + every i := 1 to *wif do { + wif[i] ? { + if ="[" then { + section := map(tab(upto(']'))) + sections[section] := i + } + } + } + + # Process information sections. + + every name := !information_sections do + information[name] := info(name) + + # Set up data information. + + data_entries["tieup"] := (\information["weaving"])["treadles"] + data_entries["liftplan"] := (\information["weft"])["threads"] + data_entries["color table"] := (\information["color palette"])["entries"] + data_entries["warp symbol table"] := + (\information["warp symbol palette"])["entries"] + data_entries["weft symbol table"] := + (\information["weft symbol palette"])["entries"] + data_entries["threading"] := (\information["warp"])["threads"] + data_entries["warp colors"] := (\information["warp"])["threads"] + data_entries["treadling"] := (\information["weft"])["threads"] + data_entries["weft colors"] := (\information["weft"])["threads"] + + data_default["tieup"] := "" + data_default["liftplan"] := "" + data_default["notes"] := "" + data_default["warp colors"] := (\information["warp"])["color"] + data_default["weft colors"] := (\information["weft"])["color"] + \data_default["warp colors"] ?:= { # We require index for now. + tab(upto(',')) + } + \data_default["weft colors"] ?:= { # We require index for now. + tab(upto(',')) + } + + + # Process data sections. + + every name := !data_sections do + data[name] := decode_data(name) + + # First get colors and encode them. + + if colors := \data["color table"] then { + range := (\information["color palette"])["range"] | abort(1) + range ?:= { + tab(upto(',')) + move(1) + tab(0) + 1 + } + if range < 2 ^ 16 then { # adjust color values + every i := 1 to *colors do { + color := colors[i] + color ?:= { + r := tab(upto(',')) + move(1) + g := tab(upto(',')) + move(1) + b := tab(0) + (r * range) || "," || (g * range) || "," || (b * range) + } + colors[i] := color + } + } + colors_in := "" + every colors_in ||:= upto(PaletteKey(palette, !colors), + PaletteChars(palette)) + } + + # Compose pfd() + + pfd := draft() + + pfd.name := title + pfd.shafts := shafts := (\information["weaving"])["shafts"] | abort(3) + pfd.treadles := treadles := (\information["weaving"])["treadles"] | abort(3) + pfd.palette := palette + pfd.colors := PaletteChars(palette) + + if warp_colors := \data["warp colors"] then { + pfl := "" + every color := !warp_colors do { + color ?:= tab(upto(',')) # possible obsolete RBG syntax + pfl ||:= colors_in[color] + } + pfd.warp_colors := pfl + } + + if weft_colors := \data["weft colors"] then { + pfl := "" + every color := !weft_colors do { + color ?:= tab(upto(',')) # possible obsolete RGB sybtax + pfl ||:= colors_in[color] + } + pfd.weft_colors := pfl + } + + # Need to get liftplan, if there is one, before processing treadling. + # Output is later. + # + # Note: If the treadling has multiple treadles, we need to handle it + # some other way than we now are. What we need to do is to create + # a treadling here. + + if liftplan := \data["liftplan"] then { + lifting := "" + lift_set := set() + lift_list := [] + lift_table := table() + k := 0 + threads := (\information["weft"])["threads"] | abort(3) + every i := 1 to threads do { + line := repl("0", treadles) + if \liftplan[i] then { + liftplan[i] ? { + while j := tab(upto(',') | 0) do { + if *j > 0 then line[j] := "1" + move(1) | break + } + } + } + if not member(lift_set, line) then { + insert(lift_set, line) + k +:= 1 + lift_table[line] := sympos(k) | stop("*** masking error") + } + put(lift_list, line) + lifting ||:= lift_table[line] + } + } + + if threading := \data["threading"] then { + pfl := "" + every line := !threading do { + if /line then next # Ignore empty threading + line ? { # Handles multiple threadings as first + i := integer(tab(upto(',') | 0)) | stop("*** invalid threading") + } + maxi <:= i + if i = 0 then next # Ignore bogus 0 + pfl ||:= sympos(\i) | stop("*** masking problem in threading, i=", i) + } + pfd.threading := pfl + } + + if \lifting then pfd.treadling := lifting else { + pfl := "" + if treadling := \data["treadling"] then { + every i := !treadling do { + if /i then next # IGNORE EMPTY TREADLING LINE??? + if not integer(i) then { + if /lift_list then + stop("*** multiple treadling without liftplan section") + else { # Produce empty treadling if there + pfl := "" # multiple treadling and a liftplan + break + } + } + maxi <:= i + if i = 0 then next # IGNORE BOGUS 0 + pfl ||:= sympos(\i) | stop("*** masking problem in treadling, i=", i) + } + pfd.treadling := pfl + } + } + + + if tieup := \data["tieup"] then { + tie := "" + every i := 1 to treadles do { + line := repl("0", shafts) + if \tieup[i] then { + tieup[i] ? { + while j := tab(upto(',') | 0) do { + if *j > 0 then line[j] := "1" + move(1) | break + } + } + } + tie ||:= line # MAY BE MIS-ORIENTED + } + pfd.tieup := tie2pat(pfd.shafts, pfd.shafts, tie) + } + + # Now, finally, the liftplan, if any. + # + # The lift lines are given in order of occurrence. The symbols + # used for them in the treadling can be reconstructed and are + # note included here. + + if \lift_list then { + pfd.liftplan := "" + every pfd.liftplan ||:= !lift_list + pfd.liftplan := tie2pat(pfd.shafts, *lift_list, pfd.liftplan) + } + + return pfd + +end + +procedure abort(i) + + stop("*** insufficient information to produce specifications: ", i) + +end + +procedure info(name) + local i, tbl, keyname, keyvalue, line + + tbl := table() + + i := \sections[name] | fail + + repeat { + i +:= 1 + line := wif[i] | return tbl + line ? { + { + keyname := map(tab(upto('='))) & + move(1) & + keyvalue := trim(tab(upto(';') | 0)) + } | return tbl + tbl[keyname] := keyvalue + } | return tbl + } + +end + +procedure decode_data(name) + local i, lst, keyname, keyvalue, line, size, value + + i := \sections[name] | fail + + value := \data_default[name] + + if size := \data_entries[name] then lst := list(size, value) + else lst := [] + + repeat { + i +:= 1 + line := wif[i] | return lst + line ? { + { + keyname := integer(tab(upto('='))) | return lst + move(1) + keyvalue := trim(tab(upto(';') | 0)) + if *keyvalue = 0 then { + keyvalue := value + if /keyvalue then { + write(&errout, "name=", name) + stop("*** no default where needed") + } + } + } + if /size then put(lst, keyvalue) else lst[keyname] := keyvalue + } + } + +end diff --git a/ipl/gpacks/weaving/woozles.icn b/ipl/gpacks/weaving/woozles.icn new file mode 100644 index 0000000..1dc3e37 --- /dev/null +++ b/ipl/gpacks/weaving/woozles.icn @@ -0,0 +1,77 @@ +############################################################################ +# +# File: woozles.icn +# +# Subject: Program to test search path idea +# +# Author: Ralph E. Griswold +# +# Date: March 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: turtle, wopen +# +############################################################################ + +link turtle +link wopen + +$define Limit 40 + +procedure main() + + TGoto(10, 10) + + traverse(0) + + WDone() + +end + +$define Length 10 +$define Delay 10 + +procedure traverse(i) + + if i > Limit then return + + TRight() + TDraw(Length) # segment 1 + WDelay(Delay) + TRight() + every 1 to i + 1 do # segment 2 + TDraw(Length) + WDelay(Delay) + TRight() # segment 3 + every 1 to i + 1 do + TDraw(Length) + WDelay(Delay) + TLeft() + TDraw(Length) # segment 4 + WDelay(Delay) + TLeft() + every 1 to i + 2 do # segment 5 + TDraw(Length) + WDelay(Delay) + TLeft() + every 1 to i + 2 do # segment 6 + TDraw(Length) + + WDelay(10 + Delay) + + traverse(i + 2) + +end diff --git a/ipl/gpacks/weaving/wvp2html.icn b/ipl/gpacks/weaving/wvp2html.icn new file mode 100644 index 0000000..4ce26ef --- /dev/null +++ b/ipl/gpacks/weaving/wvp2html.icn @@ -0,0 +1,60 @@ +############################################################################ +# +# File: wvp2html.icn +# +# Subject: Program to create web pages for WVP weaving images +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC. Skeleton was derived from a CyberStudio page. Images are +# assumed to be 128x128. +# +# The name of a directory, <d> is given on the command line. The .wvp +# files are expected in WVP/<d>/*.wvp and the image files in GIF/<d>/*.gif +# +# The pages are written to HTML/<d>/<name>.html. If this subdirectory +# does not exist, it is created. +# +############################################################################ +# +# Links: basename +# +############################################################################ + +link basename + +procedure main(args) + local page, i, directory, name, input, output, files + + $include "wvppage" + + directory := args[1] | stop("*** no directory given") + + files := open("ls WVP/" || directory || "/*.wvp", "p") + + system("mkdir HTML/" || directory || " 2>/dev/null") + + while name := read(files) do { + name := basename(name, ".wvp") + page[6] := name + page[30] := image(" ../../GIF/" || directory || "/" || name || ".gif") + output := open("HTML/" || directory || "/" || name || ".html", "w") | + stop("*** cannot open page for writing") + every write(output, page[1 to 33]) + input := open("WVP/" || directory || "/" || name || ".wvp") | + stop("*** cannot open .wvp file") + while write(output, read(input)) + every write(output, page[35 to *page]) + close(input) + close(output) + } + +end diff --git a/ipl/gpacks/weaving/wvp2pfd.icn b/ipl/gpacks/weaving/wvp2pfd.icn new file mode 100644 index 0000000..d48a684 --- /dev/null +++ b/ipl/gpacks/weaving/wvp2pfd.icn @@ -0,0 +1,136 @@ +############################################################################ +# +# File: wvp2pfd.icn +# +# Subject: Program to convert seqdraft include files to pfds +# +# Author: Ralph E. Griswold +# +# Date: June 19, 1999 +# +############################################################################ +# +# This program includes include.wvp from seqdraft and converts them +# to patter-form drafts. +# +# IMPORTANT: This program must be compiled and executed in a directory +# containing the file include.wvp for the desired weaving. +# +############################################################################ +# +# Requires: large integers +# +############################################################################ +# +# Links: expander, weaving, weavutil, lists, options +# +############################################################################ +# +# Note: The include file may contain link declarations. +# +############################################################################ + +link expander +link weaving +link weavutil +link lists +link options +link weaveseq + +$include "include.wvp" + +global canvas +global cmod +global colors +global height +global modulus +global width +global threading +global tieup +global tieups +global transcribe +global treadling +global warp_colors +global weft_colors +global shafts +global treadles + +procedure main() + +$ifdef Randomize + randomize() +$endif + +$ifndef Pattern_form + transcribe := 1 +$endif + +# The weaving-generation process is now done by two procedures, the first to +# initialize the edges and the second to actually create the weaving. This +# has been done to allow possible extensions. + + init() + + weave() + +end + +# Initialize the weaving. + +procedure init() + local m, n, v + + shafts := Shafts + treadles := Treadles + + colors := Colors + + width := Breadth + height := Length + + threading := "" + every threading ||:= |sconvert(Threading, shafts) \ width + + treadling := "" + every treadling ||:= |sconvert(Treadling, treadles) \ height + + warp_colors := "" + every warp_colors ||:= |sconvert(WarpColors, *colors) \ width + + weft_colors := "" + every weft_colors ||:= |sconvert(WeftColors, *colors) \ height + + tieup := pat2tier(Tieup).matrix + + return + +end + +# Create the weaving. + +procedure weave() + local k, tieup + + tieup := Tieup + + if not upto(';', tieup) then tieup := "8;8;" || tieup # OLD STYLE + + write(Name) + write(threading) + write(treadling) + write(warp_colors) + write(weft_colors) + write(Palette) + write(Colors) + write(Shafts) + write(Treadles) + write(Tieup) + return + +end + +procedure sconvert(s, n) + + return possym(abs(integer(s) % n) + 1) + +end diff --git a/ipl/gpacks/weaving/wvptempl.icn b/ipl/gpacks/weaving/wvptempl.icn new file mode 100644 index 0000000..f0d6e3a --- /dev/null +++ b/ipl/gpacks/weaving/wvptempl.icn @@ -0,0 +1,23 @@ +$define Repeat +$define Reflect +link seqfncs +link strings +$define Comments "Monday, October 26, 1998 2:12 pm" +$define Name "test37" +$define Palette "c1" +$define WarpColors (ExtendSeq{S,128}) +$define WeftColors (Reverse{!"WarpColors",}) +$define Tieup "1000000001000000001000000001000000001000000001000000001000000001" +$define Width (128) +$define Height (Width) +$define Modulus (8) +$define Threading (ExtendSeq{P | V | C,128}) +$define Treadling (ExtendSeq{M | P | M,128}) +$define C (repl(!chaosseq() \ 16, ?10)) +$define F (!fibseq() \ 16) +$define M (repl(!multiseq(1,3,1) \ 16, ?10)) +$define P (repl(!primeseq() \ 16, ?10)) +$define R (!meander("ABCD",3)) +$define S (repl(!meander("DHM", 2), ?7)) +$define V (repl(!versumseq() \ 16, ?4)) + diff --git a/ipl/gpacks/xtiles/Makefile b/ipl/gpacks/xtiles/Makefile new file mode 100644 index 0000000..538cd0e --- /dev/null +++ b/ipl/gpacks/xtiles/Makefile @@ -0,0 +1,10 @@ +SRC = xtiles.icn smiley1.icn smiley2.icn smiley3.icn + +xtiles: $(SRC) + icont -s xtiles.icn + +Iexe: xtiles + cp xtiles ../../iexe/ + +Clean: + rm -f xtiles *.u[12] diff --git a/ipl/gpacks/xtiles/README b/ipl/gpacks/xtiles/README new file mode 100644 index 0000000..c735eda --- /dev/null +++ b/ipl/gpacks/xtiles/README @@ -0,0 +1,37 @@ +Purpose + X-Tiles is a puzzle. You try to score a large number of points by removing + connected sets of same-colored tiles from a playfield (see manpage) + X-Tiles serves no purpose whatsoever. + +Installation + You need a working package of the Icon programming language installed + first. Confere ftp://ftp.cs.arizona.edu/pub/Icon for that. + Tiles should work as-is with Icon v9.0 and higher. + + Compile X-Tiles with either icont/iconc as you wish. + + Check that it works. + + Copy the executable and the man page where you want. + +Background pictures + X-Tiles can use background pictures. The precise formats it can load + will vary with your Icon installation. It tries to be reasonably smart, + but it needs at least 40 colormap entries to be usable in full color + mode. If it does not work, you may try the -reduced mode, or even + -bw. + + Another possibility is to reduce the picture colormap, to say 200 + colors. xpaint can do that, for instance (load your picture, and + use the Filter/Quantize colors menu. + +Legalese + X-Tiles is not public domain. It is freely distributable, except + for commercial purposes and distributions, in which case you must + contact the author about it. + +Author + Marc Espie (Marc.Espie@ens.fr) + 60 rue du 4 septembre + 87100 Limoges + France diff --git a/ipl/gpacks/xtiles/convert.icn b/ipl/gpacks/xtiles/convert.icn new file mode 100644 index 0000000..eb9c753 --- /dev/null +++ b/ipl/gpacks/xtiles/convert.icn @@ -0,0 +1,15 @@ +link graphics + +procedure nextpixel(w) + suspend PaletteKey(c1, Pixel(w)) +end + +procedure main(L) + WOpen("image="||L[1], "gamma=1.0") | die("no image ?") + writes("\"") + g := create nextpixel(&window) + every 1 to WAttrib("height") do + every (| writes(@g) \ WAttrib(&window, "width")) | write("_") + write("\"") +end + diff --git a/ipl/gpacks/xtiles/smiley1.icn b/ipl/gpacks/xtiles/smiley1.icn new file mode 100644 index 0000000..b33ad84 --- /dev/null +++ b/ipl/gpacks/xtiles/smiley1.icn @@ -0,0 +1,41 @@ +"6666666666666666666666666666666666666663_ +6666666666666666666666666666666666666633_ +6666666666666666666666666666666666666333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~00000000~~~~~~~~~~~~~333_ +666~~~~~~~~~~000DDDDDDDD000~~~~~~~~~~333_ +666~~~~~~~~00DDDDDDDDDDDDDD00~~~~~~~~333_ +666~~~~~~~0DDDDDDDDDDDDDDDDDD0~~~~~~~333_ +666~~~~~~0DDDDDDDDDDDDDDDDDDDD0~~~~~~333_ +666~~~~~0DDDDDDDDDDDDDDDDDDDDDD0~~~~~333_ +666~~~~0DDDDDDDDDDDDDDDDDDDDDDDD0~~~~333_ +666~~~~0DDDDDDDDDDDDDDDDDDDDDDDD0~~~~333_ +666~~~0DDDDDDD00DDDDDDDD00DDDDDDD0~~~333_ +666~~~0DDDDDD0000DDDDDD0000DDDDDD0~~~333_ +666~~~0DDDDDD0000DDDDDD0000DDDDDD0~~~333_ +666~~0DDDDDDDD00DDDDDDDD00DDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~~0DDDDDD0DDDDDDDDDDDD0DDDDDD0~~~333_ +666~~~0DDDDDDD0DDDDDDDDDD0DDDDDDD0~~~333_ +666~~~0DDDDDDDD0DDDDDDDD0DDDDDDDD0~~~333_ +666~~~~0DDDDDDDD00000000DDDDDDDD0~~~~333_ +666~~~~0DDDDDDDDDDDDDDDDDDDDDDDD0~~~~333_ +666~~~~~0DDDDDDDDDDDDDDDDDDDDDD0~~~~~333_ +666~~~~~~0DDDDDDDDDDDDDDDDDDDD0~~~~~~333_ +666~~~~~~~0DDDDDDDDDDDDDDDDDD0~~~~~~~333_ +666~~~~~~~~00DDDDDDDDDDDDDD00~~~~~~~~333_ +666~~~~~~~~~~000DDDDDDDD000~~~~~~~~~~333_ +666~~~~~~~~~~~~~00000000~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +6633333333333333333333333333333333333333_ +6333333333333333333333333333333333333333_ +3333333333333333333333333333333333333333_ +" diff --git a/ipl/gpacks/xtiles/smiley2.icn b/ipl/gpacks/xtiles/smiley2.icn new file mode 100644 index 0000000..7e54163 --- /dev/null +++ b/ipl/gpacks/xtiles/smiley2.icn @@ -0,0 +1,41 @@ +"6666666666666666666666666666666666666663_ +6666666666666666666666666666666666666633_ +6666666666666666666666666666666666666333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~00000000~~~~~~~~~~~~~333_ +666~~~~~~~~~~000DDDDDDDD000~~~~~~~~~~333_ +666~~~~~~~~00DDDDDDDDDDDDDD00~~~~~~~~333_ +666~~~~~~~0DDDDDDDDDDDDDDDDDD0~~~~~~~333_ +666~~~~~~0DDDDDDDDDDDDDDDDDDDD0~~~~~~333_ +666~~~~~0DDDDDDDDDDDDDDDDDDDDDD0~~~~~333_ +666~~~~0DDDDDDDDDDDDDDDDDDDDDDDD0~~~~333_ +666~~~~0DDDDDDDDDDDDDDDDDDDDDDDD0~~~~333_ +666~~~0DDDDDD0DD0DDDDDD0DD0DDDDDD0~~~333_ +666~~~0DDDDDDD00DDDDDDDD00DDDDDDD0~~~333_ +666~~~0DDDDDDD00DDDDDDDD00DDDDDDD0~~~333_ +666~~0DDDDDDD0DD0DDDDDD0DD0DDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~0DDDDDDDDDDDDDDDDDDDDDDDDDDDD0~~333_ +666~~~0DDDDDDDDD00000000DDDDDDDDD0~~~333_ +666~~~0DDDDDDDD0DDDDDDDD0DDDDDDDD0~~~333_ +666~~~0DDDDDDD0DDDDDDDDDD0DDDDDDD0~~~333_ +666~~~~0DDDDD0DDDDDDDDDDDD0DDDDD0~~~~333_ +666~~~~0DDDDDDDDDDDDDDDDDDDDDDDD0~~~~333_ +666~~~~~0DDDDDDDDDDDDDDDDDDDDDD0~~~~~333_ +666~~~~~~0DDDDDDDDDDDDDDDDDDDD0~~~~~~333_ +666~~~~~~~0DDDDDDDDDDDDDDDDDD0~~~~~~~333_ +666~~~~~~~~00DDDDDDDDDDDDDD00~~~~~~~~333_ +666~~~~~~~~~~000DDDDDDDD000~~~~~~~~~~333_ +666~~~~~~~~~~~~~00000000~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +666~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~333_ +6633333333333333333333333333333333333333_ +6333333333333333333333333333333333333333_ +3333333333333333333333333333333333333333_ +" diff --git a/ipl/gpacks/xtiles/smiley3.gif b/ipl/gpacks/xtiles/smiley3.gif Binary files differnew file mode 100644 index 0000000..8c8c7dc --- /dev/null +++ b/ipl/gpacks/xtiles/smiley3.gif diff --git a/ipl/gpacks/xtiles/smiley3.icn b/ipl/gpacks/xtiles/smiley3.icn new file mode 100644 index 0000000..5261434 --- /dev/null +++ b/ipl/gpacks/xtiles/smiley3.icn @@ -0,0 +1,41 @@ +"6666666666666666666666666666666666666663_ +6666666666666666666666666666666666666633_ +6666666666666666666666666666666666666333_ +6664444444444444444444444444444444444333_ +6664444444444444444444444444444444444333_ +6664444444444444000000004444444444444333_ +6664444444444000DDDDDDDD0004444444444333_ +6664444444400DDDDDDDDDDDDDD0044444444333_ +66644444440DDDDDDDDDDDDDDDDDD04444444333_ +6664444440DDDDDDDDDDDDDDDDDDDD0444444333_ +666444440DDDDDDDDDDDDDDDDDDDDDD044444333_ +66644440DDDDDDDDDDDDDDDDDDDDDDDD04444333_ +66644440DDDD0000000000000000DDDD04444333_ +6664440DDDD000000000000000000DDDD0444333_ +6664440DDD0D0000000000000000D0DDD0444333_ +6664440DD0DD0000000DD0000000DD0DD0444333_ +666440DD0DDD000000DDDD000000DDD0DD044333_ +666440D0DDDDD0000DDDDDD0000DDDDD0D044333_ +6664400DDDDDDD00DDDDDDDD00DDDDDDD0044333_ +666440DDDDDDDDDDDDDDDDDDDDDDDDDDDD044333_ +666440DDDDDDDDDDDDDDDDDDDDDDDDDDDD044333_ +666440DDDDDDDDDDDDDDDDDDDDDDDDDDDD044333_ +666440DDDDDDDDDDDDDDDDDDDDDDDDDDDD044333_ +666440DDDDDDDDDDDDDDDDDDDDDDDDDDDD044333_ +6664440DDDDDDDDDDDDDDDDDDDDDDDDDD0444333_ +6664440DDDDDDD0DDDDDDDDDD0DDDDDDD0444333_ +6664440DDDDDDDD0DDDDDDDD0DDDDDDDD0444333_ +66644440DDDDDDDD00000000DDDDDDDD04444333_ +66644440DDDDDDDDDDDDDDDDDDDDDDDD04444333_ +666444440DDDDDDDDDDDDDDDDDDDDDD044444333_ +6664444440DDDDDDDDDDDDDDDDDDDD0444444333_ +66644444440DDDDDDDDDDDDDDDDDD04444444333_ +6664444444400DDDDDDDDDDDDDD0044444444333_ +6664444444444000DDDDDDDD0004444444444333_ +6664444444444444000000004444444444444333_ +6664444444444444444444444444444444444333_ +6664444444444444444444444444444444444333_ +6633333333333333333333333333333333333333_ +6333333333333333333333333333333333333333_ +3333333333333333333333333333333333333333_ +" diff --git a/ipl/gpacks/xtiles/xtiles.6 b/ipl/gpacks/xtiles/xtiles.6 new file mode 100644 index 0000000..215328d --- /dev/null +++ b/ipl/gpacks/xtiles/xtiles.6 @@ -0,0 +1,89 @@ +.TH X-TILES 6 "16 February 97" +.SH NAME +X-Tiles - X windows game, remove connected tiles +.SH SYNOPSIS +.B X-Tiles +[\fB-v\fR] [\fB-help|-h\fR] +[\fB-bw\fR] [\fB-reduced\fR] [\fB-pastel\fR] +[\fB-darker\fR] [\fB-lighter\fR] +[\fIcolors\fR] [\fIcolumns\fR] [\fIlines\fR] [\fIseed\fR] +[\fIbackground\fR] +.SH DESCRIPTION +.SS GAME PRINCIPLE +\fIX-Tiles\fR is a time-waster disguised as a puzzle. When you start +\fIX-Tiles\fR, it displays a rectangular playfield filled with sets of colored +rectangles (tiles). The aim of \fIX-Tiles\fR is to zap all tiles. +You can only zap a 4-connected set of tiles of the same color. +When you click on such a set, it vanishes, and all tiles above fall down +to fill the gap. When this creates empty columns, other columns slide +leftward to fill the hole. \fIX-Tiles\fR ends when there is no set left that +you can zap, or in other words, when no two remaining adjacent tiles are of +the same color. +.SS SCORING AND WINNING +Each set you zap may reward you with some points. Take the number of +tiles of the set, subtract two, and square the result. Notice that a set of +2 tiles doesn't get you anything ! A sets of 3 tiles scores 1 point, +a set of 4 tiles scores 4 points, a set of 5 tiles scores 9 points, and so on. + +When the game ends, the score is adjusted as follows: subtract one point +for each remaining lonesome tile. If you managed to zap all tiles, add +1,000 points. +.SS GAME CONTROLS +During the game, moving the mouse pointer will highlight the corresponding +set of tiles. Any mouse click will zap that set. +The bottom line of the window displays your score, along with the point +value of the highlighted set. + +You can undo the last move by clicking on the smiley face or by +hitting \fIu\fR. + +At any point, hitting \fIq\fR will prompt you for quitting the game. +Hitting \fIc\fR will offer you another choice of colors. + +When the game ends, you may hit \fIq\fR to quit, +\fIn\fR to play a new game, or \fIr\fR to replay the current puzzle. +.SH OPTIONS +.IP "\fB-v\fR" +Displays the version number. +.IP "\fB-help|-h\fR" +Short help message +.IP "\fB-bw\fR" +Start the game in black and white mode, even on colors display. +.IP "\fB-reduced\fR" +Start the game using less colors. May help with background pictures with +lots of colors. +.IP "\fB-pastel\fR" +Uses less aggressive colors. +.IP "\fB-darker\fR" +Uses lighter colors. +.IP "\fB-lighter\fR" +Uses darker colors. +.IP "\fIcolors\fR" +Number of distinct colors. Should not be more than 12. Interesting games +usually involve 3 to 6 colors. Defaults to 4 when no parameters are given. +.IP "\fIcolumns\fR" +Number of columns. Defaults to 10, limited to range 4..40. +.IP "\fIlines\fR" +Number of lines. Defaults to the \fIcolumns\fR value, limited to range +4..40. +.IP "\fIseed\fR" +Random seed. Will be chosen randomly if you don't specify it. +This is the value displayed by the game on startup. Write it down if you +want to replay a given game later. +.IP "\fIbackground\fR" +File name of background image. Available formats depend on the actual Icon +implementation used. gif should work alright. This image should leave enough +entries in the colormap for \fIX-Tiles\fR's own use. +.SH BUGS AND FEATURES +The game is mostly unplayable on slow machines or at large sizes. Not +all combinations of board size/number of colors provide for an interesting +game. There is no provision for a high-score table. + +Some color backgrounds may leave you with white on white game play or +such non-sense. + +.SH AUTHOR +Marc Espie (Marc.Espie@ens.fr) + +Based on the Amiga puzzle game \fITile Fall\fR, originally written by +Adam Dawes (Adam@darkside.demon.co.uk) diff --git a/ipl/gpacks/xtiles/xtiles.icn b/ipl/gpacks/xtiles/xtiles.icn new file mode 100644 index 0000000..ed43b80 --- /dev/null +++ b/ipl/gpacks/xtiles/xtiles.icn @@ -0,0 +1,881 @@ +# tiles.icn + +# tiles puzzle + +# $Id: X-Tiles.icn,v 3.9 1997/02/21 11:35:38 espie Exp espie $ +# minor mods 2000/12/23 gmt + +link graphics + + +$define SMILEY_SIZE 40 + +$define DEFAULT_TSIZE 35 +$define MIN_TSIZE 10 +$define MAX_TSIZE 100 +$define MINSIZE 256 + +# we use globals as this is mostly a hack + + + +# individual tiles size (in pixels) + +global tile_width, tile_height + + + + +# total playfield size +global n, m + + + + + +global tiles_win, tiles_bw_win # graphics context used to draw tiles + + +# tiles can be shown as normal, highlighted or shadowed border, +# or even patterned b&w if /normal +record color_set(normal, highlight, shadow, pattern, name) + + + + +global colors # color array to map tiles colors +global black, white, bgcolor + + +global smiley1, smiley2, smiley3 # smiley images in the lower-right corner + +global bgimage # image to put in as background + + + + +################################################################# +# +# graphics rendering +# +################################################################# + +# replaces background with my own Image +procedure my_erase_area(win, x, y, w, h) + /x := 0 + /y := 0 + /w := WAttrib(win, "width") - x + /h := WAttrib(win, "height") - y + CopyArea(bgimage, win, x, y, w, h, x, y) +end + +procedure my_draw_string(win, x, y, s) + Fg(white) + DrawString(win, x+1, y+1, s) + Fg(black) + DrawString(win, x, y, s) +end + + +procedure write_score(score) + Fg(black) + # erase old score, that means the lower band of the window + # except the SMILEY_SIZE x SMILEY_SIZE lower-right smiley + EraseArea(&window, 0, m * tile_height, + n * tile_width-SMILEY_SIZE, SMILEY_SIZE) + my_draw_string(&window, 10, m * tile_height + 15, score) +end + + +procedure draw_smiley(image) + DrawImage(&window, n * tile_width-SMILEY_SIZE, m*tile_height, + SMILEY_SIZE||",c1,"||image) +end + + +# ask the user if he wants to replay, new, quit +procedure user_entry() + static buttons + initial + { + buttons := ["(r)eplay ", "(n)ew ", "(q)uit "] + } + + # write the button and record corresponding areas + leading := WAttrib("ascent") + 5 + s1 := TextWidth(buttons[1]) + s2 := TextWidth(buttons[2]) + s3 := TextWidth(buttons[3]) + my_draw_string(&window, 5, leading, buttons[1]||buttons[2]||buttons[3]) + repeat + { + e := Event() + case e of + { + &lrelease | &mrelease | &rrelease: + { + # hardcoded button area check + if 0 <= &y <= WAttrib("fheight") + 10 then + { + if (5 <= &x < 5 + s1) then return "r" + if (5 + s1 <= &x < 5 + s1 + s2) then return "n" + if (5 + s1 + s2 <= &x < 5 + s1 + s2 + s3) then return "q" + } + if (WAttrib("height")-SMILEY_SIZE < &y < WAttrib("height") & + WAttrib("width")-SMILEY_SIZE < &x < WAttrib("width")) then + return "u" + } + "q"|"n"|"r"|"u": + { + return e + } + } + } +end + + +# setup tiles color mapping +procedure setup_colors(color_mode) + + # setup color mode correctly + if WAttrib("depth") = 1 then + insert(color_mode, "bw") + every member(color_mode, "bw") & + member(color_mode, m <- "pastel"|"reduced"|"lighter"|"darker") do + write("Warning: "||m||" makes no sense in black and white mode") + if member(color_mode, "darker") & member(color_mode, "lighter") then + write("Warning: lighter and darker specified both, uses darker") + # establish possible set of colors/patterns + color_names := set([ + ["red", "darkgray"], + ["green", "gray"], + ["blue", "lightgray"], + ["yellow", "vertical"], + ["grey", "diagonal"], + ["purple", "horizontal"], + ["orange", "grid"], + ["magenta", "trellis"], + ["cyan", "checkers"], + ["blue-cyan", "grains"], + ["brown", "scales"], + ["bluish green", "waves"] + ]) + + colors := [] + # create randomized mapping + if member(color_mode, "pastel") then saturation := "moderate " + else saturation := "" + lightness := ["pale", "light ", "medium ", "dark ", "deep "] + if member(color_mode, "darker") then + correction := 1 + else if member(color_mode, "lighter") then + correction := -1 + else + correction := 0 + while c := ?color_names do + { + delete(color_names, c) + put(colors, color_set(&null, white, black, c[2], saturation||c[1]) ) + member(color_mode, "bw") | + { + colors[-1].normal := + ColorValue(lightness[3+correction]||colors[-1].name) + } + } + member(color_mode, "bw" | "reduced") | + every c := !colors do + { + c.highlight := \ColorValue(lightness[2+correction]||\c.name) | white + c.shadow := \ColorValue(lightness[4+correction]||\c.name) | black + } + return ColorValue(lightness[3+correction]||"gray") +end + +procedure setup_graphics(color_mode) + + if /bgimage then dummy := WOpen("canvas=hidden", "width=1", "height=1") + # assume the background image first pixel is background + if /&window then + stop("Error: could not open window. Check your display/xauth.") + bgcolor := ColorValue(Pixel(\bgimage)) + black := ColorValue("black") | stop() + white := ColorValue("white") | stop() + if \bgcolor == black then black :=: white + # These sizes MUST be real to match the background image size + tile_width := (MINSIZE < WAttrib(\bgimage, "width"))/real(n) | + DEFAULT_TSIZE + tile_height := + ((MINSIZE < WAttrib(\bgimage, "height"))+SMILEY_SIZE)/real(m) | + DEFAULT_TSIZE + tile_width >:= MAX_TSIZE + tile_height >:= MAX_TSIZE + + # compute and adjust window width/tiles width + dwidth := WAttrib(&window, "displaywidth") + if dwidth < n * tile_width then + # leave one tile margin + tile_width := dwidth / (n+1) + + # compute and adjust window height/tiles height + dheight := WAttrib(&window, "displayheight") + if dheight < m * tile_height + SMILEY_SIZE then + # leave one tile margin + tile_height := (dheight - SMILEY_SIZE) / (m+1) + + tile_width <:= MIN_TSIZE + tile_height <:= MIN_TSIZE + + width := n * tile_width + height := m * tile_height + SMILEY_SIZE + + tile_width := integer(tile_width) + tile_height := integer(tile_height) + + &window := WOpen("label=the X-Tiles", + "bg="||(\bgcolor|white), + "font=sans,bold,proportional", + "width="||width, "height="||height) + + WClose(\dummy) + if bsize := MINSIZE > WAttrib(\bgimage, "width") then + { + WAttrib(bgimage, "width="||width) + every dest := bsize to width by bsize do + CopyArea(bgimage, bgimage, 0, 0, bsize, &null, dest, 0) + } + if bsize := MINSIZE > WAttrib(\bgimage, "height") then + { + WAttrib(bgimage, "height="||height - SMILEY_SIZE) + every dest := bsize to height by bsize do + CopyArea(bgimage, bgimage, 0, 0, &null, bsize, 0, dest) + } + + tiles_bw_win := Clone(&window, "fillstyle=textured", + "fg="||white,"bg="||black) + newbg := setup_colors(color_mode) + /bgcolor := newbg + Bg(bgcolor) + EraseArea(&window) + tiles_win := Clone(&window) + + smiley1 := +$include "smiley1.icn" + smiley2 := +$include "smiley2.icn" + smiley3 := +$include "smiley3.icn" +end + + +################################################################# +# +# tiles and tiles rendering +# +################################################################# + + + +# Tiles are saved in a 2-dimensional array +# Each tile is a unique individual (useful for set entries) +# that records its own position column/line as well as color +# /color for empty tiles + + +record tile_square(column, line, color, connect) + +procedure t(i, j) + static h, empty + initial + { + h := list(n) + every h[1 to n] := list(m) + every a := 1 to n do + every b := 1 to m do + h[a][b] := tile_square(a, b, &null) + empty := tile_square() + } + if (1 <= i <= n) & (1 <= j <= m) then + return h[i][j] + else + return empty +end + + +# compute the connectivity of a given tile (north, south, east, west) +# suspends with neighboring tiles whose connectivity may have changed +# PLEASE NOTE: compute_connectivity is definitily NOT purely functional +# For the computation to be correct, the generator MUST suspends ALL its +# results +procedure compute_connectivity(p) + /p.connect := '' + "ewsn" ? + { + every q := neighbor(p) do + { + if \p.color = \q.color | (/p.color & /q.color) then + { + if not any(p.connect) then + { + p.connect ++:= move(1) + suspend q + } + else + move(1) + } + else + { + if any(p.connect) then + { + p.connect --:= move(1) + suspend q + } + else + move(1) + } + } + } +end + + +# draw bevel around a tile, recessed if /bevel +procedure draw_bevel(tile, bevel) + if /tile.color then fail + x := (tile.column - 1) * tile_width + y := (m - tile.line) * tile_height + x1 := x + tile_width - 1 + y1 := y + tile_height - 1 + c1 := colors[tile.color].highlight + c2 := colors[tile.color].shadow + if \bevel then + c1 :=: c2 + + # draw bevel areas only if the corresponding connectivity does + # NOT exist + Fg(c1) + "n" ? any(tile.connect) | + DrawRectangle(x, y, tile_width-1, 1) + "e" ? any(tile.connect) | + DrawRectangle(x, y, 1, tile_height-1) + Fg(c2) + "s" ? any(tile.connect) | + DrawRectangle(x, y1-1, tile_width-1, 1) + "w" ? any(tile.connect) | + DrawRectangle(x1-1, y, 1, tile_height-1) +end + + +# draw tile itself, including bevel +procedure draw_tile(tile, bevel) + x := (\tile.column - 1) * tile_width | fail + y := (m - tile.line) * tile_height + if /tile.color then + { + EraseArea(&window, x, y, tile_width, tile_height) + } + else + { + if Fg(tiles_win, \colors[tile.color].normal) then + FillRectangle(tiles_win, x, y, tile_width, tile_height) + else + { + WAttrib(tiles_bw_win, + "pattern="||colors[tile.color].pattern)|stop(colors[tile.color].pattern) + FillRectangle(tiles_bw_win, x, y, tile_width, tile_height) + } + draw_bevel(tile, bevel) + } + return +end + + +procedure draw_bevel_set(s, bevel) + if *s <= 1 then fail + every draw_bevel(!s, bevel) +end + +################################################################# +# +# the game +# +################################################################# + + +# suspend a tile's neighbors + +procedure neighbor(p) + suspend t(\p.column - 1 | \p.column + 1, p.line) | + t(\p.column, p.line - 1 | p.line + 1) +end + +# suspend a tile's upwards neighbors, enough for checking that moves remain +procedure up_neighbor(p) + suspend t(p.column + 1, p.line) | t(p.column, p.line + 1) +end + + + +# Ye old connected component algorithm +# start at t(i, j) and maps connected component. +# return &null if set is empty, +# and the old set if it is the same set + +procedure connected_set(old, i, j) + p := t(i, j) + if member(\old, p) then return old + c := \p.color | return &null + s := set() + l := [p] + while p := pop(l) do + if not member(s, p) then + { + insert(s, p) + every q := neighbor(p) & \q.color = c do + put(l, q) + } + return s +end + + +# suspends all current columns. Assumes a stable game, stops +# at first empty column +procedure columns() + every i := seq() do + { + if /t(i, 1).color then fail + suspend i + } +end + +# suspend all current lines for column c. Stops at first empty line +# Note that the game is always stable: the first empty tile means the +# top of the column +procedure lines(c) + every j := seq() do + { + if /t(c, j).color then fail + suspend j + } +end + +procedure used_tiles() + suspend t(c := columns(), lines(c)) +end + +# check whether you can still play +procedure remains_move() + every p := used_tiles() do + if \p.color = \up_neighbor(p).color then return + fail +end + + +# compute the interval of columns spanned by a set +# Note that all columns must be present as the set if 4-connected +procedure columns_of_set(s) + local cmin, cmax + + # you can check that the following test does indeed set up cmin + # and cmax correctly + every c := (!s).column do + (/cmin := c & /cmax := c) | (cmin >:= c) | (cmax <:= c) + return [cmin, cmax] +end + + +# make tiles fall down in individual columns +procedure remove_individual_tiles(remember, saved, to_draw, s, cmin, cmax) + # for each involved column + every col := cmin to cmax do + { + # j: tile line # to replace, k: tile line # to replace it with + # find the lowest removable tile + if member(s, t(col, j := lines(col))) then + { + k := j + # as long as we did not get outside + while \t(col, j).color do + { + # find non erased tile + k +:= 1 + while member(s, t(col, k)) do + k +:= 1 + + # and replace it + p := t(col, j) + put(remember, copy(p)) + insert(saved, p) + put(to_draw, p) + p.color := t(col, k).color + j +:= 1 + } + } + } +end + +# remove empty columns +procedure remove_columns(remember, saved, to_draw, cmin, cmax) + # now check for empty columns in known range + if /t(col := cmin to cmax, 1).color then + { + # if we did find one, we have to check all columns + colp := col + while col <= n do + { + colp +:= 1 + # skip over empty columns... well stop when you get outside + while /t(colp, 1).color & colp <= cmax do + colp +:= 1 + + # copy one column: do every line + every j := seq() do + { + p := t(col, j) + q := t(colp, j) + # stop when BOTH columns (src and dest) are empty + if /p.color & /q.color then break + member(saved, p) | + { + put(remember, copy(p)) + insert(saved, p) + put(to_draw, p) + } + p.color := q.color + } + col +:= 1 + } + } + +end + +procedure remove_tiles(s) + cols := columns_of_set(s) + + # first we move tiles around + backtrack := [] # copy of tiles that where changed + to_draw := [] # list of tiles to draw + saved := set() # tiles that changed + # note that to_draw and saved hold the same tiles. + # saved is used for membership, and to_draw to display tiles + # in linear order, which is less confusing + remove_individual_tiles(backtrack, saved, to_draw, s, cols[1], cols[2]) + remove_columns(backtrack, saved, to_draw, cols[1], cols[2]) + + # then we update needed connectivities + other := rebuild_connectivity(saved) + # and finally we redraw tiles + redraw_tiles(to_draw, other) + return backtrack +end + + +# redraw the list in order, followed by the set. +procedure redraw_tiles(l, s) + every p := !l do + { + # there may be duplicates + delete(s, p) + draw_tile(p) + } + every draw_tile(!s) +end + + +# rebuild the connectivity of the whole game, knowing the set of tiles +# that changed colors +procedure rebuild_connectivity(s) + changed := set() + neigh := set() + + # for each tile of the set + every p := !s do + { + q := &null + # recompute its connectivity and mark its neighbors that have + # changed + every q := compute_connectivity(p) do + member(s, q) | insert(neigh, q) + + # connectivity changed iff there was such a neighbor ! + if \q then + insert(changed, p) + } + + # neighbors are simpler, as we just have to update their connectivity + # watch out ! we have to use ALL the results of the generator + # compute_connectivity for the computation to be correct + every compute_connectivity(!neigh) + changed ++:= neigh + return changed +end + +procedure undo(changes) + c := set() + l := [] + + # backtrack changes, remember what to draw + every p := !changes do + { + q := t(p.column, p.line) + q.color := p.color + # easier to build BOTH the list (for non confusing redraw) + # and the set (needed by rebuild_connectivity) + insert(c, q) + put(l, q) + } + other := rebuild_connectivity(c) + redraw_tiles(l, other) +end + +procedure usage() + return "Usage: X-Tiles [-v] [-h] _ +[-bw] [-pastel] [-reduced] [-darker] [-lighter] _ +[colors] [columns] [lines] [seed] [bg]" +end + + +procedure whoami() +# $Id: X-Tiles.icn,v 3.9 1997/02/21 11:35:38 espie Exp espie $ + name := "" + "$Id: X-Tiles.icn,v 3.9 1997/02/21 11:35:38 espie Exp espie $" ? + { + ="$Id: " + name ||:= tab(find(".icn,v")) + =".icn,v " + name ||:= " version "||tab(upto(' '))||move(1)||tab(upto(' ')) + } + return name||" by Marc Espie (Marc.Espie@ens.fr)" +end + + +procedure new_game(r) + + # build a playable game + repeat + { + every t(1 to n, 1 to m).color := ?r + if remains_move() then + break + } + + every compute_connectivity(t(1 to n, 1 to m)) + + # draw initial setup + EraseArea(&window) + draw_smiley(smiley1) + every draw_tile(used_tiles()) + + + # remove left over events from last game + while *Pending() > 0 do + Event() +end + + +procedure adjust_end_score() + # adjust end score + count := 0 + every used_tiles() do + count +:= 1 + if count > 0 then + { + draw_smiley(smiley2) + return -count + } + else + { + draw_smiley(smiley3) + return 1000 + } +end + + + +procedure main(L) + parms := [] + color_mode := set() + + # process all options + every p := !L do + map(p) ? + { + {=("-bw"|"-reduced"|"-pastel"|"-lighter"|"-darker") & pos(0) & insert(color_mode, tab(2)) }| + {=("-help"|"-h") & pos(0) & stop(usage())} | + {=("-v"|"-version") & pos(0) & stop(whoami())} | + {i := integer(tab(0)) & put(parms, i)} | + {any('-') & stop("Unknown option "||tab(0)||"\n"||usage())} | + # if we have a background image + {bgimage := WOpen("canvas=hidden", "image="||p, "gamma=1.0") & + # use our own flavour of EraseArea + EraseArea := my_erase_area} | + {stop("Can't load background image "||tab(0))} + + } + + + r := get(parms) | 4 + n := get(parms) | 10 + m := get(parms) | n + last_random := get(parms) | map(&clock, ':', '9') + r <:= 2 + n <:= 4 + n >:= 40 + m <:= 4 + m >:= 40 + &random := map(&clock, ':', '9') + + # we have the game size and the background image, + # so we can open the window + setup_graphics(color_mode) + r >:= *colors + &random := last_random + + while not (\last == "q") do + { + # setup for new game or replay + if \last == "r" then + { + /best_score := \score + &random := last_random + } + else + { + last_random := &random + best_score := &null + } + writes("Playing tiles ", r, " ", n, " ", m, " ", + left(&random, 12)) + + new_game(r) + lasti := &null + s := &null + changes := [] + log := [] + score := 0 + write_score(score) + + repeat + { + # either get pending event, or busy-peek the mouse pointer position + if *Pending() > 0 then + { + e := Event() + i := &x/tile_width+1 + j := m - &y/tile_height + } + else + { + e := &null + i := WAttrib("pointerx")/tile_width+1 + j := m - WAttrib("pointery")/tile_height + } + + # check whether tile position changed + if (i = \lasti) & (j = \lastj) then + { + # if busy-peeking, add suitable delay + if /e then delay(50) + } + else + { + lasti := i + lastj := j + # build new connected set + sp := connected_set(s, i, j) + + # if a new set + if sp ~=== s then + { + # un highlight old set (if needed) + draw_bevel_set(\s) + s := sp + # highlight new set + draw_bevel_set(\s, 1) + if *\s > 2 then + write_score(score||" (+"||(*s-2)*(*s-2)||")") + else + write_score(score) + } + } + + if e === "c" then + { + setup_colors(color_mode) + if *\s < 2 then s := &null + every p := used_tiles() do + draw_tile(p, member(\s, p) | &null) + } + + # check whether actually zapping + if e === (&lrelease | &mrelease | &rrelease) & *\s >= 2 then + { + push(changes, [score, remove_tiles(s)]) + put(log, [i, j]) + # adjust score + score +:= (*s-2)*(*s-2) + write_score(score) + + # setup `virgin' highlighted set/position + lasti := &null + s := &null + e := &null + + # check for end + if not remains_move() then + { + score +:= adjust_end_score() + if \best_score <:= score then + { + prompt := "Best " + best_log := log + } + else + prompt := "End " + + write_score(prompt||score) + write(" Final score ", score) + last := user_entry() + if last == "u" then + { + EraseArea(0, 0, &null, WAttrib("leading")+10) + to_undo := pop(changes) + score := to_undo[1] + write_score(score) + draw_smiley(smiley1) + undo(to_undo[2]) + } + else + break + } + } + if ( + (e === (&lrelease | &mrelease | &rrelease) & + WAttrib("height")-SMILEY_SIZE < &y < WAttrib("height") & + WAttrib("width")-SMILEY_SIZE < &x < WAttrib("width")) | + e === "u" + ) & *changes > 0 then + { + draw_bevel_set(\s) + s := &null + lasti := &null + to_undo := pop(changes) + score := to_undo[1] + write_score(score) + undo(to_undo[2]) + } + # check if user wants to quit prematurely + if e === "q" then + { + write_score("Sure ?") + e := Event() + if (e == ("o" | "y" | "q")) then + { + last := "q" + write() + break + } + else + write_score(score) + } + } + } +end |
