diff options
Diffstat (limited to 'ipl/gpacks/carpets')
| -rw-r--r-- | ipl/gpacks/carpets/Makefile | 14 | ||||
| -rw-r--r-- | ipl/gpacks/carpets/README | 2 | ||||
| -rw-r--r-- | ipl/gpacks/carpets/carplay.icn | 283 | ||||
| -rw-r--r-- | ipl/gpacks/carpets/carport.icn | 1156 | ||||
| -rw-r--r-- | ipl/gpacks/carpets/carprec.icn | 13 | ||||
| -rw-r--r-- | ipl/gpacks/carpets/carputil.icn | 269 |
6 files changed, 1737 insertions, 0 deletions
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 |