OS/2 Shareware BBS: 10 Tools/10-Tools.zip/ICONPL8.ZIP/PROCS.PAK

Text File | 1990-03-23 | 136KB | 5,068 lines

##########
allof.icn
############################################################################
#
#    Name:    allof.icn
#
#    Title:    Iterative Conjunction Control Operation
#
#    Author:    Robert J. Alexander
#
#    Date:    November 3, 1989
#
############################################################################
#
#  allof{expr1,expr2} -- Control operation that performs iterative
#             conjunction.
#
#     Expr1 works like the control expression of "every-do"; it controls
#  iteration by being resumed to produce all of its possible results.
#  The allof{} expression produces the outcome of conjunction of all
#  of the resulting expr2s, one instance of expr2 created for each
#  iteration.
#
#     For example:
#
#    global c
#    ...
#    pattern := "ab*"
#    "abcdef" ? {
#       allof { c := !pattern ,
#          if c == "*" then move(0 to *&subject - &pos + 1) else =c
#          } & pos(0)
#       }
#
#  This example will perform a wild card match on "abcdef" against
#  pattern "ab*", where "*" in a pattern matches 0 or more characters.
#  Since pos(0) will fail the first time it is evaluated, the allof{}
#  expression will be resumed just as a conjunction expression would,
#  and backtracking will propagate through all of the expr2s; the
#  expression will ultimately succeed (as its conjunctive equivalent
#  would).
#
#     Note that, due to the scope of variables in co-expressions,
#  communication between expr1 and expr2 must be via global variables,
#  hence c in the above example must be global.
#
#     The allof{} procedure models Icon's expression evaluation
#  mechanism in that it explicitly performs backtracking.  The author of
#  this procedure knows of no way to use Icon's built-in goal directed
#  evaluation to perform conjunction of a arbitrary number of computed
#  expressions (suggestions welcome).
#

procedure allof(expr)
   local elist,i,x,v
   #
   #  Initialize
   #
   elist := []    # expression list
   i := 1    # expression list pointer
   #
   #  Loop until backtracking over all expr[2]s has failed.
   #
   while i > 0 do {
      if not (x := elist[i]) then
     #
     #  If we're at the end of the list of expressions, attempt an
     #  iteration to produce another expression.
     #
         if @expr[1] then
        put(elist,x := ^expr[2])
     else {
        #
        #  If no further iterations, suspend a result.
        #
        suspend v
        #
        #  We've been backed into -- back up to last expr[2].
        #
        i -:= 1
        }
      #
      #  Evaluate the expression.
      #
      if v := @x then {
     #
     #  If success, move on to the refreshed next expression.
     #
         i +:= 1
     elist[i] := ^elist[i]
     }
      else
     #
     #  If failure, back up.
     #
         i -:= 1
      }
end
##########
bincvt.icn
############################################################################
#
#    Name:    bincvt.icn
#
#    Title:    Convert binary data
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  unsigned() -- Converts binary byte string into unsigned integer.
#  Detects overflow if number is too large.
#
#  This procedure is normally used for processing of binary data
#  read from a file.
#
procedure unsigned(s)
   local i
   i := 0
   every i := ord(!s) + i * 256
   return i
end

#
#  raw() -- Puts raw bits of characters of string s into an integer.  If
#  the size of s is less than the size of an integer, the bytes are put
#  into the low order part of the integer, with the remaining high order
#  bytes filled with zero.  If the string is too large, the most
#  significant bytes will be lost -- no overflow detection.
#
#  This procedure is normally used for processing of binary data
#  read from a file.
#

procedure raw(s)
   local i
   i := 0
   every i := ior(ord(!s),ishift(i,8))
   return i
end

#
#  rawstring() -- Creates a string consisting of the raw bits in the low
#  order "size" bytes of integer i.
#
#  This procedure is normally used for processing of binary data
#  to be written to a file.
#

procedure rawstring(i,size)
   local s
   s := ""
   every 1 to size do {
      s := char(iand(i,16rFF)) || s
      i := ishift(i,-8)
      }
   return s
end
##########
bold.icn
############################################################################
#
#    Name:    bold.icn
#
#    Title:    Procedures for enboldening and underscoring test
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  These procedures produce text with interspersed characters suit-
#  able for printing to produce the effect of boldface (by over-
#  striking) and underscoring (using backspaces).
#
#       bold(s)        bold version of s
#
#       uscore(s)      underscored version of s
#
############################################################################

procedure bold(s)
   local c
   static labels, trans, max
   initial {
      labels := "1"
      trans := repl("1\b",4) || "1"
      max := *labels
      trans := bold(string(&lcase))
      labels := string(&lcase)
      max := *labels
      }
   if *s <= max then
      return map(left(trans,9 * *s),left(labels,*s),s)
   else return bold(left(s,*s - max)) ||
      map(trans,labels,right(s,max))
end

procedure uscore(s)
   static labels, trans, max
   initial {
      labels := "1"
      trans := "_\b1"
      max := *labels
      trans := uscore(string(&lcase))
      labels := string(&lcase)
      max := *labels
      }
   if *s <= max then
      return map(left(trans,3 * *s),left(labels,*s),s)
   else return uscore(left(s,*s - max)) ||
      map(trans,labels,right(s,max))
end
##########
codeobj.icn
############################################################################
#
#    Name:    codeobj.icn
#
#    Title:    Procedures to encode and decode Icon data
#
#    Author:    Ralph E. Griswold
#
#    Date:    November 16, 1988
#
############################################################################
#
#     These procedures provide a way of storing Icon values as strings and
#  retrieving them.  The procedure encode(x) converts x to a string s that
#  can be converted back to x by decode(s). These procedures handle all
#  kinds of values, including structures of arbitrary complexity and even
#  loops.  For "scalar" types -- null, integer, real, cset, and string --
#
#    decode(encode(x)) === x
#
#     For structures types -- list, set, table, and record types --
#  decode(encode(x)) is, for course, not identical to x, but it has the
#  same "shape" and its elements bear the same relation to the original
#  as if they were encoded and decode individually.
#
#     No much can be done with files, functions and procedures, and
#  co-expressions except to preserve type and identification.
#
#     The encoding of strings and csets handles all characters in a way
#  that it is safe to write the encoding to a file and read it back.
#
#     No particular effort was made to use an encoding of value that
#  minimizes the length of the resulting string. Note, however, that
#  as of Version 7 of Icon, there are no limits on the length of strings
#  that can be written out or read in.
#
############################################################################
#
#     The encoding of a value consists of four parts:  a tag, a length,
#  a type code, and a string of the specified length that encodes the value
#  itself.
#
#     The tag is omitted for scalar values that are self-defining.
#  For other values, the tag serves as a unique identification. If such a
#  value appears more than once, only its tag appears after the first encoding.
#  There is, therefore, a type code that distinguishes a label for a previously
#  encoded value from other encodings. Tags are strings of lowercase
#  letters. Since the tag is followed by a digit that starts the length, the
#  two can be distinguished.
#
#     The length is simply the length of the encoded value that follows.
#
#     The type codes consist of single letters taken from the first character
#  of the type name, with lower- and uppercase used to avoid ambiguities.
#
#     Where a structure contains several elements, the encodings of the
#  elements are concatenated. Note that the form of the encoding contains
#  the information needed to separate consecutive elements.
#
#     Here are some examples of values and their encodings:
#
#    x                     encode(x)
#  -------------------------------------------------------
#
#    1                     "1i1"
#    2.0                   "3r2.0"
#    &null                 "0n"
#    "\377"                "4s\\377"
#    '\376\377'            "8c\\376\\377"
#    procedure main        "a4pmain"
#    co-expression #1 (0)  "b0C"
#    []                    "c0L"
#    set()                 "d0S"
#    table("a")            "e3T1sa"
#    L1 := ["hi","there"]  "f11L2shi5sthere"
#
#  A loop is illsutrated by
#
#    L2 := []
#    put(L2,L2)
#
#  for which
#
#    x                     encode(x)
#  -------------------------------------------------------
#
#    L2                    "g3L1lg"
#
#     Of course, you don't have to know all this to use encode and decode.
#
############################################################################
#
#  Links: escape, gener
#
#  Requires:  co-expressions
#
#  See also: object.icn
#
############################################################################

link escape, gener

global outlab, inlab

record triple(type,value,tag)

#  Encode an arbitary value as a string.
#
procedure encode(x,level)
   local str, tag, Type
   static label
   initial label := create star(string(&lcase))
   if /level then outlab := table()    # table is global, but reset at
                    # each root call.
   tag := ""
   Type := typecode(x)
   if Type == !"ri" then str := string(x)    # first the scalars
   else if Type == !"cs" then str := image(string(x))[2:-1]    # remove quotes
   else if Type == "n" then str := ""
   else if Type == !"LSRTfpC" then    # next the structures and other types
      if str := \outlab[x] then        # if the object has been processed,
         Type := "l"            # use its label and type it as label.
      else {
         tag := outlab[x] := @label    # else make a label for it.
         str := ""
         if Type == !"LSRT" then {    # structures
            every str ||:= encode(    # generate, recurse, and concatenate
               case Type of {
                  !"LS":   !x        # elements
                  "T":    x[[]] | !sort(x,3)    # default, then elements
                  "R":    type(x) | !x        # type then elements
                  }
               ,1)            # indicate internal call
            }
            else str ||:= case Type of {    # other things
               "f":   image(x)
               "C":   ""
               "p":   image(x) ? {    # watch out for record constructors
                  tab(find("record constructor ") + *"record constructor ") |
                  tab(upto(' ') + 1)
                  tab(0)
                  }
               }
         }
   else stop("unsupported type in encode: ",image(x))
   return tag || *str || Type || str
end

#  Produce a one-letter code for the type.
#
procedure typecode(x)
   local code
                # be careful of records and their constructors
   if image(x) ? ="record constructor " then return "p"
   if image(x) ? ="record" then return "R"
   code := type(x)
   if code == ("list" | "set" | "table" | "co-expression") then
      code := map(code,&lcase,&ucase)
   return code[1]
end

#  Generate decoded results.  At the top level, there is only one,
#  but for structures, it is called recursively and generates the
#  the decoded elements.
#
procedure decode(s,level)
   local p
   if /level then inlab := table()    # global but reset
   every p := separ(s) do {
      suspend case p.type of {
         "l":  inlab[p.value]        # label for an object
         "i":  integer(p.value)
         "s":  escape(p.value)
         "c":  cset(escape(p.value))
         "r":  real(p.value)
         "n":  &null
         "L":  delist(p.value,p.tag)
         "R":  derecord(p.value,p.tag)
         "S":  deset(p.value,p.tag)
         "T":  detable(p.value,p.tag)
         "f":  defile(p.value)
         "C":  create &fail    # can't hurt much to fail
         "p":  (proc(p.value) | stop("encoded procedure not found")) \ 1
         default:  stop("unexpected type in decode: ",p.type)
         }
      }
end

#  Generate triples for the encoded values in concatenation.
#
procedure separ(s)
   local p, size

   while *s ~= 0 do {
      p := triple()
      s ?:= {
         p.tag := tab(many(&lcase))
         size := tab(many(&digits)) | break
         p.type := move(1)
         p.value := move(size)
         tab(0)
         }
      suspend p
      }
end

#  Decode a list. The newly constructed list is added to the table that
#  relates tags to structure values.
#
procedure delist(s,tag)
   local a
   inlab[tag] := a := []    # insert object for label
   every put(a,decode(s,1))
   return a
end

#  Decode a set. Compare to delist above.
#
procedure deset(s,tag)
   local S
   inlab[tag] := S := set()
   every insert(S,decode(s,1))
   return S
end

#  Decode a record.
#
procedure derecord(s,tag)
   local R, e
   e := create decode(s,1)    # note use of co-expressions to control
                # generation, since record must be constructed
                # before fields are produced.
   inlab[tag] := R := proc(@e)() | stop("error in decoding record")
   every !R := @e
   return R
end

#  Decode  a table.
#
procedure detable(s,tag)
   local t, e
   e := create decode(s,1)    # see derecord above; here it's the default
                # value that motivates co-expressions.
   inlab[tag] := t := table(@e)
   while t[@e] := @e
   return t
end

#  Decode a file.
#
procedure defile(s)
   s := decode(s,1)        # the result is an image of the original file.
   return case s of {        # files aren't so simple ...
      "&input":  &input
      "&output": &output
      "&errout": &errout
      default: s ? {
            ="file("        # open for reading to play it safe
            open(tab(upto(')'))) | stop("cannot open encoded file")
            }
       }
end
##########
collate.icn
############################################################################
#
#    Name:    collate.icn
#
#    Title:    Collate and decollate strings
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  These procedures collate (interleave) respective characters of
#  two strings and decollate such strings by selecting every other
#  character of a string.  produce a string consisting of inter-
#  leaved characters of s1 and s2.
#
#       collate(s1,s2) collate the characters of s1 and s2.  For
#                      example,
#
#                           collate("abc","def")
#
#                      produces "adbecf".
#
#       decollate(s,i) produce a string consisting of every other
#                      character of s. If i is odd, the odd-numbered
#                      characters are selected, while if i is even,
#                      the even-numbered characters are selected.
#
############################################################################

procedure collate(s1,s2)
   local length, ltemp, rtemp
   static llabels, rlabels, clabels, blabels, half
   initial {
      llabels := "ab"
      rlabels := "cd"
      blabels := llabels || rlabels
      clabels := "acbd"
      half := 2
      ltemp := left(&cset,*&cset / 2)
      rtemp := right(&cset,*&cset / 2)
      clabels := collate(ltemp,rtemp)
      llabels := ltemp
      rlabels := rtemp
      blabels := string(&cset)
      half := *llabels
      }
   length := *s1
   if length <= half then
      return map(left(clabels,2 * length),left(llabels,length) ||
         left(rlabels,length),s1 || s2)
   else return map(clabels,blabels,left(s1,half) || left(s2,half)) ||
      collate(right(s1,length - half),right(s2,length - half))
end

#  decollate s according to even or odd i
#
procedure decollate(s,i)
   static dsize, image, object
   local ssize
   initial {
      image := collate(left(&cset,*&cset / 2),left(&cset,*&cset / 2))
      object := left(&cset,*&cset / 2)
      dsize := *image
      }
   i %:= 2
   ssize := *s
   if ssize + i <= dsize then
      return map(object[1+:(ssize + i) / 2],image[(i + 1)+:ssize],s)
   else return map(object[1+:(dsize - 2) / 2],image[(i + 1)+:dsize - 2],
      s[1+:(dsize - 2)]) || decollate(s[dsize - 1:0],i)
end

##########
colmize.icn
############################################################################
#
#    Name:    colmize.icn
#
#    Title:    Arrange data into columns
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  colmize() -- Arrange data into columns.
#
#  Procedure to arrange a number of data items into multiple columns.
#  Items are arranged in column-wise order, that is, the sequence runs
#  down the first column, then down the second, etc.
#
#  This procedure goes to great lengths to print the items in as few
#  vertical lines as possible.
#

procedure colmize(entries,maxcols,space,minwidth,rowwise,distribute)
   local mean,cols,lines,width,i,x,wid,extra,t,j
   #
   #  Process arguments -- provide defaults.
   #
   # entries: a list of items to be columnized
   /maxcols := 80                        # max width of output lines
   /space := 2                           # min nbr of spaces between columns
   /minwidth := 0                        # min column width
   # rowwise: if nonnull, entries are listed in rowwise order rather than
   # columnwise
   #
   #  Starting with a trial number-of-columns that is guaranteed
   #  to be too wide, successively reduce the number until the
   #  items can be packed into the allotted width.
   #
   mean := 0
   every mean +:= *!entries
   mean := mean / (0 ~= *entries) | 1
   every cols := (maxcols + space) * 2 / (mean + space) to 1 by -1 do {
      lines := (*entries + cols - 1) / cols
      width := list(cols,minwidth)
      i := 0
      if /rowwise then {                  # if column-wise
     every x := !entries do {
        width[i / lines + 1] <:= *x + space
        i +:= 1
        }
     }
      else {                              # else row-wise
     every x := !entries do {
        width[i % cols + 1] <:= *x + space
        i +:= 1
        }
     }
      wid := 0
      every x := !width do wid +:= x
      if wid <= maxcols + space then break
      }
   #
   #  Now output the data in columns.
   #
   extra := (\distribute & (maxcols - wid) / (0 < cols - 1)) | 0
   if /rowwise then {            # if column-wise
      every i := 1 to lines do {
     t := ""
     every j := 0 to cols - 1 do
           t ||:= left(entries[i + j * lines],width[j + 1] + extra)
     suspend trim(t)
     }
      }
   else {                                # else row-wise
      every i := 0 to lines - 1 do {
     t := ""
     every j := 1 to cols do
           t ||:= left(entries[j + i * cols],width[j] + extra)
     suspend trim(t)
     }
      }
end
##########
complex.icn
############################################################################
#
#    Name:    complex.icn
#
#    Title:    Perform complex arithmetic
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  The following procedures perform operations on complex numbers.
#
#       complex(r,i)   create complex number with real part r and
#                      imaginary part i
#
#       cpxadd(x1,x2)  add complex numbers x1 and x2
#
#       cpxdiv(x1,x2)  divide complex number x1 by complex number x2
#
#       cpxmul(x1,x2)  multiply complex number x1 by complex number
#                      x2
#
#       cpxsub(x1,x2)  subtract complex number x2 from complex
#                      number x1
#
#       cpxstr(x)      convert complex number x to string represen-
#                      tation
#
#       strcpx(s)      convert string representation s of complex
#                      number to complex number
#
############################################################################

record complex(rpart,ipart)

procedure strcpx(s)
   local i

   i := upto('+-',s,2)
   return complex(+s[1:i],+s[i:-1])
end

procedure cpxstr(x)
   if x.ipart < 0 then return x.rpart || x.ipart || "i"
   else return x.rpart || "+" || x.ipart || "i"
end

procedure cpxadd(x1,x2)
   return complex(x1.rpart + x2.rpart,x1.ipart + x2.ipart)
end

procedure cpxsub(x1,x2)
   return complex(x1.rpart - x2.rpart,x1.ipart - x2.ipart)
end

procedure cpxmul(x1,x2)
   return complex(x1.rpart * x2.rpart - x1.ipart * x2.ipart,
      x1.rpart * x2.ipart + x1.ipart * x2.rpart)
end

procedure cpxdiv(x1,x2)
   local denom

   denom := x2.rpart ^ 2 + x2.ipart ^ 2
   return complex((x1.rpart * x2.rpart + x1.ipart * x2.ipart) /
      denom,(x1.ipart * x2.rpart - x1.rpart * x2.ipart) /
      denom)
end
##########
compress.icn
############################################################################
#
#    Name:    compress.icn
#
#    Title:    LZW compression procedure
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  compress() -- LZW compression
#
#  Arguments:
#
#    inproc    a procedure that returns a single character from
#        the input stream.
#
#    outproc    a procedure that writes a single character (its
#        argument) to the output stream.
#
#    maxTableSize    the maximum size to which the string table
#        is allowed to grow before something is done about it.
#        If the size is positive, the table is discarded and
#        a new one started.  If negative, it is retained, but
#        no new entries are added.
#

procedure compress(inproc,outproc,maxTableSize)
   local EOF,c,charTable,junk1,junk2,outcode,s,t,
     tossTable,x
   #
   #  Initialize.
   #
   /maxTableSize := 1024    # 10 "bits"
   every outproc(!string(maxTableSize))
   outproc("\n")
   tossTable := maxTableSize
   /lzw_recycles := 0
   if maxTableSize < 0 then maxTableSize := -maxTableSize
   charTable := table()
   every c := !&cset do charTable[c] := ord(c)
   EOF := charTable[*charTable] := *charTable    # reserve code=256 for EOF
   lzw_stringTable := copy(charTable)
   #
   #  Compress the input stream.
   #
   s := inproc() | return maxTableSize
   if \lzw_trace then {
      wr(&errout,"\nInput string\tOutput code\tNew table entry")
      wrs(&errout,"\"",image(s)[2:-1])
      }
   while c := inproc() do {
   if \lzw_trace then
     wrs(&errout,image(c)[2:-1])
      if \lzw_stringTable[t := s || c] then s := t
      else {
     compress_output(outproc,junk2 := lzw_stringTable[s],junk1 := *lzw_stringTable)
     if *lzw_stringTable < maxTableSize then
           lzw_stringTable[t] := *lzw_stringTable
     else if tossTable >= 0 then {
           lzw_stringTable := copy(charTable)
           lzw_recycles +:= 1
        }
     if \lzw_trace then
           wrs(&errout,"\"\t\t",
             image(char(*&cset > junk2) | junk2),
             "(",junk1,")\t\t",lzw_stringTable[t]," = ",image(t),"\n\"")
     s := c
     }
      }
   compress_output(outproc,lzw_stringTable[s],*lzw_stringTable)
   if \lzw_trace then
     wr(&errout,"\"\t\t",
           image(char(*&cset > (x := \lzw_stringTable[s] | 0)) | x))
   compress_output(outproc,EOF,*lzw_stringTable)
   compress_output(outproc)
   return maxTableSize
end


procedure compress_output(outproc,code,stringTableSize)
   static max,bits,buffer,bufferbits,lastSize
   #
   #  Initialize.
   #
   initial {
      lastSize := 1000000
      buffer := bufferbits := 0
      }
   #
   #  If this is "close" call, flush buffer and reinitialize.
   #
   if /code then {
      outcode := &null
      if bufferbits > 0 then
        outproc(char(outcode := ishift(buffer,8 - bufferbits)))
      lastSize := 1000000
      buffer := bufferbits := 0
      return outcode
      }
   #
   #  Expand output code size if necessary.
   #
   if stringTableSize < lastSize then {
      max := 1
      bits := 0
      }
   while stringTableSize > max do {
      max *:= 2
      bits +:= 1
      }
   lastSize := stringTableSize
   #
   #  Merge new code into buffer.
   #
   buffer := ior(ishift(buffer,bits),code)
   bufferbits +:= bits
   #
   #  Output bits.
   #
   while bufferbits >= 8 do {
      outproc(char(outcode := ishift(buffer,8 - bufferbits)))
      buffer := ixor(buffer,ishift(outcode,bufferbits - 8))
      bufferbits -:= 8
      }
   return outcode
end
##########
currency.icn
############################################################################
#
#    Name:    currency.icn
#
#    Title:    Currency formatting procedure
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  currency() -- Formats "amount" in standard American currency format.
#  "amount" can be a real, integer, or numeric string.  "width" is the
#  output field width, in which the amount is right adjusted.  The
#  returned string will be longer than "width" if necessary to preserve
#  significance.  "minus" is the character string to be used for
#  negative amounts (default "-"), and is placed to the right of the
#  amount.
#

procedure currency(amount,width,minus)
   local sign,p
   /width := 0
   /minus := "-"
   amount := real(amount) | fail
   if amount < 0 then {
      sign := minus
      amount := -amount
      }
   else sign := repl(" ",*minus)
   amount := string(amount)
   amount := if p := find(".",amount) then left(amount,p + 2,"0") else
     amount || ".00"
   if match("0.",amount) then amount[1:3] := "0."
   amount := "$" || amount || sign
   return if *amount >= width then amount else right(amount,width)
end
##########
decompr.icn
############################################################################
#
#    Name:    decompr.icn
#
#    Title:    LZW decompression of compressed stream created
#                  by compress()
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  decompress() -- LZW decompression of compressed stream created
#                  by compress()
#
#  Arguments:
#
#    inproc    a procedure that returns a single character from
#        the input stream.
#
#    outproc    a procedure that writes a single character (its
#        argument) to the output stream.
#

procedure decompress(inproc,outproc)
   local EOF,c,charSize,code,i,maxTableSize,new_code,old_strg,
     strg,tossTable
   #
   #  Initialize.
   #
   maxTableSize := ""
   while (c := inproc()) ~== "\n" do maxTableSize ||:= c
   maxTableSize := integer(maxTableSize) |
     stop("Invalid file format -- max table size missing")
   tossTable := maxTableSize
   /lzw_recycles := 0
   if maxTableSize < 0 then maxTableSize := -maxTableSize
   maxTableSize -:= 1
   lzw_stringTable := list(*&cset)
   every i := 1 to *lzw_stringTable do lzw_stringTable[i] := char(i - 1)
   put(lzw_stringTable,EOF := *lzw_stringTable)  # reserve code=256 for EOF
   charSize := *lzw_stringTable
   if \lzw_trace then
     wr(&errout,"\nInput code\tOutput string\tNew table entry")
   #
   #  Decompress the input stream.
   #
   while old_strg :=
     lzw_stringTable[decompress_read_code(inproc,*lzw_stringTable,EOF) + 1] do {
      if \lzw_trace then
        wr(&errout,image(old_strg),"(",*lzw_stringTable,")",
          "\t",image(old_strg))
      outproc(old_strg)
      c := old_strg[1]
      (while new_code := decompress_read_code(inproc,*lzw_stringTable + 1,EOF) do {
     strg := lzw_stringTable[new_code + 1] | old_strg || c
     outproc(strg)
     c := strg[1]
     if \lzw_trace then
           wr(&errout,image(char(*&cset > new_code) \ 1 | new_code),
             "(",*lzw_stringTable + 1,")","\t",
             image(strg),"\t\t",
             *lzw_stringTable," = ",image(old_strg || c))
     if *lzw_stringTable < maxTableSize then
           put(lzw_stringTable,old_strg || c)
     else if tossTable >= 0 then {
        lzw_stringTable := lzw_stringTable[1:charSize + 1]
        lzw_recycles +:= 1
        break
        }
     old_strg := strg
     }) | break  # exit outer loop if this loop completed
      }
   decompress_read_code()
   return maxTableSize
end


procedure decompress_read_code(inproc,stringTableSize,EOF)
   static max,bits,buffer,bufferbits,lastSize
   #
   #  Initialize.
   #
   initial {
      lastSize := 1000000
      buffer := bufferbits := 0
      }
   #
   #  Reinitialize if called with no arguments.
   #
   if /inproc then {
      lastSize := 1000000
      buffer := bufferbits := 0
      return
      }
   #
   #  Expand code size if necessary.
   #
   if stringTableSize < lastSize then {
      max := 1
      bits := 0
      }
   while stringTableSize > max do {
      max *:= 2
      bits +:= 1
      }
   #
   #  Read in more data if necessary.
   #
   while bufferbits < bits do {
      buffer := ior(ishift(buffer,8),ord(inproc())) |
        stop("Premature end of file")
      bufferbits +:= 8
      }
   #
   #  Extract code from buffer and return.
   #
   code := ishift(buffer,bits - bufferbits)
   buffer := ixor(buffer,ishift(code,bufferbits - bits))
   bufferbits -:= bits
   return EOF ~= code
end
##########
dif.icn
############################################################################
#
#    Name:    dif.icn
#
#    Title:    Diff engine
#
#    Author:    Robert J. Alexander
#
#    Date:    May 15, 1989
#
############################################################################
#
#  The procedure dif() is a generator that produces a sequence of
#  differences between an arbitrary number of input streams.  Each result
#  is returned as a list of diff_recs, one for each input stream, with
#  each diff_rec containing a list of items that differ and their position
#  in the input stream.  The diff_rec type is declared as:
#
#        record diff_rec(pos,diffs)
#
#  Dif fails if there are no differences, i.e. it produces an empty
#  result sequence.
#
#  For example, if two input streams are:
#
#    a b c d e f g h
#    a b d e f i j
#
#  the output sequence would be:
#
#    [diff_rec(3,[c]),diff_rec(3,[])]
#    [diff_rec(7,[gh]),diff_rec(6,[i,j])
#
#  The arguments to dif() are:
#
#    stream        A list of data objects that represent input streams
#            from which dif will extract its input "records".
#            The elements can be of several different types which
#            result in different actions, as follows:
#
#               Type               Action
#            ===========    =============================
#            file        file is "read" to get records
#
#            co-expression    co-expression is activated to
#                    get records
#
#            list        records are "gotten" (get()) from
#                    the list
#
#            diff_proc    a record type defined in "dif" to
#                    allow a procedure (or procedures)
#                    suppled by dif's caller to be called
#                    to get records.  Diff_proc has two
#                    fields, the procedure to call and the
#                    argument to call it with.  Its
#                    definition looks like this:
#
#                       record diff_proc(proc,arg)
#
#
#  Optional arguments:
#
#    compare        Item comparison procedure -- succeeds if
#            "equal", otherwise fails (default is the
#            identity "===" comparison).  The comparison
#            must allow for the fact that the eof object
#            (see next) might be an argument, and a pair of
#            eofs must compare equal.
#    eof        An object that is distinguishable from other
#            objects in the stream.  Default is &null.
#    group        A procedure that is called with the current number
#            of unmatched items as its argument.  It must
#            return the number of matching items required
#            for file synchronization to occur.  Default is
#            the formula Trunc((2.0 * Log(M)) + 2.0) where
#            M is the number of unmatched items.
#
############################################################################

record diff_rec(pos,diffs)
record diff_proc(proc,arg)
record diff_file(stream,queue)

procedure dif(stream,compare,eof,group)
  local f,linenbr,line,difflist,gf,i,j,k,l,m,n,x,test,
    result,synclist,nsyncs,syncpoint
  /compare := proc("===",2); /group := groupfactor
  f := []; every put(f,diff_file(!stream,[]))
  linenbr := list(*stream,0); line := list(*stream); test := list(*stream)
  difflist := list(*stream); every !difflist := []
  repeat {
    repeat {
      every i := 1 to *stream do line[i] := diffread(f[i]) | eof
      if not (every x := !line do (x === eof) | break) then break break
      every !linenbr +:= 1
      if (every x := !line[2:0] do compare(x,line[1]) | break) then break
    }
    every i := 1 to *stream do difflist[i] := [line[i]]
    repeat {
      every i := 1 to *stream do put(difflist[i],diffread(f[i]) | eof)
      gf := group(*difflist[1])
      every i := 1 to *stream do test[i] := difflist[i][-gf:0]
      j := *difflist[1] - gf + 1
      synclist := list(*stream); every !synclist := list(*stream)
      every k := 1 to *stream do synclist[k][k] := j
      nsyncs := list(*stream,1)
      every i := 1 to j do {        # position to look at
        every k := 1 to *stream do {    # stream whose new stuff to compare
      every l := 1 to *stream do {    # streams comparing to at pos i
        if /synclist[k][l] then {
          m := i - 1
          if not every n := 1 to gf do {
            if not compare(test[k][n],difflist[l][m +:= 1]) then break
          } then {
            synclist[k][l] := i
            if (nsyncs[k] +:= 1) = *stream then break break break break
          }
        }
      }
    }
      }
    }
    synclist := synclist[k]; result := list(*stream)
    every i := 1 to *stream do {
      j := synclist[i]; while difflist[i][j -:= 1] === eof
      result[i] := diff_rec(linenbr[i],difflist[i][1:j + 1])
      f[i].queue := difflist[i][synclist[i] + gf:0] ||| f[i].queue
      linenbr[i] +:= synclist[i] + gf - 2
      difflist[i] := []
    }
    suspend result
  }
end

procedure diffread(f)
  local x
  return get(f.queue) | case type(x := f.stream) of {
    "file": read(x)
    "co-expression": @x
    "diff_proc": x.proc(x.arg)
    "list": get(x)
  }
end

procedure groupfactor(m)  # Compute: Trunc((2.0 * Log(m)) + 2.0)
  m := string(m)
  return 2 * *m + if m <<= "316227766"[1+:*m] then 0 else 1
end
##########
escape.icn
############################################################################
#
#    Name:    escape.icn
#
#    Title:    Interpret Icon literal escapes
#
#    Author:    William H. Mitchell, modified by Ralph E. Griswold
#
#    Date:    November 21, 1988
#
############################################################################
#
#  The procedure escape(s) produces a string in which Icon quoted
#  literal escape conventions in s are replaced by the corresponding
#  characters.  For example, escape("\\143\\141\\164") produces the
#  string "cat".
#
############################################################################

procedure escape(s)
   local ns, c

   ns := ""
   s ? {
      while ns ||:= tab(upto('\\')) do {
         move(1)
         ns ||:= case c := move(1 | 0) of {
            "b":  "\b"
            "d":  "\d"
            "e":  "\e"
            "f":  "\f"
            "l":  "\n"
            "n":  "\n"
            "r":  "\r"
            "t":  "\t"
            "v":  "\v"
            "'":  "'"
            "\"":  "\""
            "x":  hexcode()
            "^":  ctrlcode()
            !"01234567":  octcode()
            default:  c
            }
         }
      ns ||:= tab(0)
      }
   return ns
end

procedure hexcode()
   local i, s
   static cdigs
   initial cdigs := ~'0123456789ABCDEFabcdef'

   move(i := 2 | 1) ? s := tab(upto(cdigs) | 0)
   move(*s - i)
   return char("16r" || s)
end

procedure octcode()
   local i, s
   static cdigs
   initial cdigs := ~'01234567'

   move(-1)
   move(i := 3 | 2 | 1) ? s := tab(upto(cdigs) | 0)
   move(*s - i)
   return char("8r" || s)
end

procedure ctrlcode(s)
   return char(upto(map(move(1)),&lcase))
end

##########
filename.icn
############################################################################
#
#    Name:    filename.icn
#
#    Title:    Parse file names
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  suffix() -- Parses a hierarchical file name, returning a 2-element
#  list:  [prefix,suffix].  E.g. suffix("/a/b/c.d") -> ["/a/b/c","d"]
#

procedure suffix(s,separator)
   local i
   /separator := "."
   i := *s + 1
   every i := find(separator,s)
   return [s[1:i],s[(*s >= i) + 1:0] | &null]
end

#
#  tail() -- Parses a hierarchical file name, returning a 2-element
#  list:  [head,tail].  E.g. tail("/a/b/c.d") -> ["/a/b","c.d"].
#

procedure tail(s,separator)
   local i
   /separator := "/"
   i := 0
   every i := find(separator,s)
   return [s[1:i + (i <= 1 | 0)],"" ~== s[i + 1:0] | &null]
end

#  components() -- Parses a hierarchical file name, returning a list of
#  all directory names in the file path, with the file name (tail) as
#  the last element.
#  E.g.  components("/a/b/c.d") -> ["/","a","b","c.d"].
#

procedure components(s,separator)
   local x,head
   /separator := "/"
   x := tail(s,separator)
   return case head := x[1] of {
      separator: [separator]
      "": []
      default: components(head)
      } ||| ([&null ~=== x[2]] | [])
end
##########
fullimag.icn
############################################################################
#
#    Name:    fullimage.icn
#
#    Title:    Produces complete image of structured data
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  fullimage() -- enhanced image()-type procedure that outputs all data
#  contained in structured types.  The "level" argument tells it how far
#  to descend into nested structures (defaults to unlimited).
#

global fullimage_level,fullimage_maxlevel,fullimage_done,fullimage_used,
      fullimage_indent


procedure fullimage(x,indent,maxlevel)
   local tr,s,t
   #
   #  Initialize
   #
   tr := &trace ; &trace := 0    # turn off trace till we're done
   fullimage_level := 1
   fullimage_indent := indent
   fullimage_maxlevel := \maxlevel | 0
   fullimage_done := table()
   fullimage_used := set()
   #
   #  Call fullimage_() to do the work.
   #
   s := fullimage_(x)
   #
   #  Remove unreferenced tags from the result string, and even
   #  renumber them.
   #
   fullimage_done := table()
   s ? {
      s := ""
      while s ||:= tab(upto('\'"<')) do {
     case t := move(1) of {
        "\"" | "'": {
           s ||:= t
           while (s ||:= tab(find(t) + 1)) \ 1 & s[-2] ~== "\\"
           }
        "<": {
           t := +tab(find(">")) & move(1)
           if member(fullimage_used,t) then {
          /fullimage_done[t] := *fullimage_done + 1
          s ||:= "<" || fullimage_done[t] || ">"
          }
           }
        }
     }
      s ||:= tab(0)
      }
   #
   #  Clean up and return.
   #
   fullimage_done := fullimage_used := &null     # remove structures
   &trace := tr                  # restore &trace
   return s
end


procedure fullimage_(x,noindent)
   local s,t,tr
   t := type(x)
   s := case t of {
      "null" | "string" | "integer" | "real" | "co-expression" | "cset" |
      "file" | "procedure" | "external": image(x)
      default: fullimage_structure(x)
      }
   #
   #  Return the result.
   #
   return (
      if \fullimage_indent & not \noindent then
     "\n" || repl(fullimage_indent,fullimage_level - 1) || s
      else
        s
   )
end

procedure fullimage_structure(x)
   local sep,s,t,tag,y
   #
   #  If this structure has already been output, just output its tag.
   #
   if \(tag := fullimage_done[x]) then {
      insert(fullimage_used,tag)
      return "<" || tag || ">"
      }
   #
   #  If we've reached the max level, just output a normal image
   #  enclosed in braces to indicate end of the line.
   #
   if fullimage_level = fullimage_maxlevel then
     return "{" || image(x) || "}"
   #
   #  Output the structure in a style indicative of its type.
   #
   fullimage_level +:= 1
   fullimage_done[x] := tag := *fullimage_done + 1
   if (t := type(x)) == ("table" | "set") then x := sort(x)
   s := "<" || tag || ">" || if t == "list" then "[" else t || "("
   sep := ""
   if t == "table" then every y := !x do {
      s ||:= sep || fullimage_(y[1]) || "->" || fullimage_(y[2],"noindent")
      sep := ","
      }
   else every s ||:= sep || fullimage_(!x) do sep := ","
   fullimage_level -:= 1
   return s || if t == "list" then "]" else ")"
end
##########
gcd.icn
############################################################################
#
#    Name:    gcd.icn
#
#    Title:    Compute greatest cmmon denominator
#
#    Author:    Ralph E. Griswold
#
#    Date:    May 11, 1989
#
############################################################################
#
#     This procedure computes the greatest common denominator of two
#  integers. If both are zero, it fails.
#
############################################################################

procedure gcd(i,j)
   local r

   if i = j = 0 then fail
   if i = 0 then return j
   if j = 0 then return i
   i := abs(i)
   j := abs(j)
   repeat {
      r := i % j
      if r = 0 then return j
      i := j
      j := r
      }
end
##########
gener.icn
############################################################################
#
#    Name:    gener.icn
#
#    Title:    Generate miscellaneous sequences
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  These procedures generate sequences of results.
#
#       hex()          sequence of hexadecimal codes for numbers
#                      from 0 to 255
#
#       label(s,i)     sequence of labels with prefix s starting at
#                      i
#
#       octal()        sequence of octal codes for numbers from 0 to
#                      255
#
#       star(s)        sequence consisting of the closure of s
#                      starting with the empty string and continuing
#                      in lexical order as given in s
#
############################################################################

procedure hex()
   suspend !"0123456789abcdef" || !"0123456789abcdef"
end

procedure label(s,i)
   suspend s || (i | (i +:= |1))
end

procedure octal()
   suspend (0 to 3) || (0 to 7) || (0 to 7)
end

procedure star(s)
   suspend "" | (star(s) || !s)
end
##########
getopt.icn
############################################################################
#
#    Name:    getopt.icn
#
#    Title:    Get command-line options
#
#    Author:    Robert J. Alexander
#
#    Date:    June 10, 1988
#
############################################################################
#
#     getopt(arg,optstring) -- Get command line options.
#
#     This procedure analyzes the -options on the command line
#  invoking an Icon program. Its inputs are:
#
#       arg         the argument list as passed to the main pro-
#                   cedure.
#
#       optstring   a string of allowable option letters. If a
#                   letter is followed by ":" the corresponding
#                   option is assumed to be followed by a string of
#                   data, optionally separated from the letter by
#                   space. If instead of ":" the letter is followed
#                   by a "+", the parameter will converted to an
#                   integer; if a ".", converted to a real.  If opt-
#                   string is omitted any letter is assumed to be
#                   valid and require no data.
#
#     It returns a list consisting of two items:
#
#       [1]  a table of options specified. The entry values are the
#            specified option letters. The assigned values are the
#            data words following the options, if any, or 1 if the
#            option has no data. The table's default value is &null.
#
#       [2]  a list of remaining parameters on the command line
#            (usually file names). A "-" which is not followed by a
#            letter is taken as a file name rather than an option.
#
#     If an error is detected, stop() is called with an appropriate
#  error message. After calling getopt() the original argument list,
#  arg, is empty.
#
############################################################################

procedure getopt(arg,optstring)
   local x,i,c,otab,flist,o,p
   /optstring := string(&lcase ++ &ucase)
   otab := table()
   flist := []
   while x := get(arg) do
      x ? {
     if ="-"  & not pos(0) then
        while c := move(1) do
           if i := find(c,optstring) + 1 then
          otab[c] :=
             if any(':+.',o := optstring[i]) then {
            p := "" ~== tab(0) | get(arg) |
                  stop("No parameter following ",x)
            case o of {
               ":": p
               "+": integer(p) |
                     stop("-",c," needs numeric parameter")
               ".": real(p) |
                     stop("-",c," needs numeric parameter")
               }
            }
             else 1
           else stop("Unrecognized option: ",x)
     else put(flist,x)
      }
   return [otab,flist]
end

##########
hexcvt.icn
############################################################################
#
#    Name:    hexcvt.icn
#
#    Title:    Hexadecimal conversion
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  hex() -- Converts string of hex digits into an integer.
#

procedure hex(s)
   local a,c
   a := 0
   every c := !map(s) do
     a := ior(find(c,"0123456789abcdef") - 1,ishift(a,4)) | fail
   return a
end

#
#  hexstring() -- Returns a string that is the hexadecimal
#  representation of the argument.
#

procedure hexstring(i,n)
   local s
   i := integer(i) | fail
   if i = 0 then s := "0"
   else {
      s := ""
      while i ~= 0 do {
     s := "0123456789ABCDEF"[iand(i,15) + 1] || s
           i := ishift(i,-4)
     }
      }
   s := right(s,\n,"0")
   return s
end


##########
image.icn
############################################################################
#
#    Name:    image.icn
#
#    Title:    Produce generalized image of Icon value
#
#    Author:    Michael Glass, Ralph E. Griswold, and David Yost
#
#    Date:    June 10, 1988
#
############################################################################
#
#  The procedure Image(x,style) produces a string image of the value x.
#  The value produced is a generalization of the value produced by
#  the Icon function image(x), providing detailed information about
#  structures. The value of style determines the formatting and
#  order of processing:
#
#     1   indented, with ] and ) at end of last item (default)
#     2   indented, with ] and ) on new line
#     3   puts the whole image on one line
#     4   as 3, but with structures expanded breadth-first instead of
#         depth-first as for other styles.
#
############################################################################
#
#     Tags are used to uniquely identify structures. A tag consists
#  of a letter identifying the type followed by an integer. The tag
#  letters are L for lists, R for records, S for sets, and T for
#  tables. The first time a structure is encountered, it is imaged
#  as the tag followed by a colon, followed by a representation of
#  the structure. If the same structure is encountered again, only
#  the tag is given.
#
#     An example is
#
#     a := ["x"]
#     push(a,a)
#     t := table()
#     push(a,t)
#     t[a] := t
#     t["x"] := []
#     t[t] := a
#     write(Image(t))
#
#  which produces
#
#  T1:[
#    "x"->L1:[],
#    L2:[
#      T1,
#      L2,
#      "x"]->T1,
#    T1->L2]
#
#  On the other hand, Image(t,3) produces
#
#     T1:["x"->L1:[],L2:[T1,L2,"x"]->T1,T1->L2]
#
#  Note that a table is represented as a list of entry and assigned
#  values separated by ->.
#
############################################################################
#
#  Problem:
#
#     The procedure here really is a combination of an earlier version and
#  two modifications to it.  It should be re-organized to combine the
#  presentation style and order of expansion.
#
#  Bug:
#
#     Since the table of structures used in a call to Image is local to
#  that call, but the numbers used to generate unique tags are static to
#  the procedures that generate tags, the same structure gets different
#  tags in different calls of Image.
#
############################################################################

procedure Image(x,style,done,depth,nonewline)
   local retval

   if style === 4 then return Imageb(x)    # breadth-first style

   /style := 1
   /done := table()
   if /depth then depth := 0
   else depth +:= 2
   if (style ~= 3 & depth > 0 & /nonewline) then
      retval := "\n" || repl(" ",depth)
   else retval := ""
   if match("record ",image(x)) then retval ||:= rimage(x,done,depth,style)
   else {
      retval ||:=
      case type(x) of {
     "list":  limage(x,done,depth,style)
     "table": timage(x,done,depth,style)
     "set":   simage(x,done,depth,style)
     default: image(x)
     }
   }
   depth -:= 2
   return retval
end

#  list image
#
procedure limage(a,done,depth,style)
   static i
   local s, tag
   initial i := 0
   if \done[a] then return done[a]
   done[a] := tag := "L" || (i +:= 1)
   if *a = 0 then s := tag || ":[]" else {
      s := tag || ":["
      every s ||:= Image(!a,style,done,depth) || ","
      s[-1] := endof("]",depth,style)
      }
   return s
end

#  record image
#
procedure rimage(x,done,depth,style)
   static i
   local s, tag
   initial i := 0
   s := image(x)
                    #  might be record constructor
   if match("record constructor ",s) then return s
   if \done[x] then return done[x]
   done[x] := tag := "R" || (i +:= 1)
   s ?:=  (="record " & (":" || (tab(upto('(') + 1))))
   if *x = 0 then s := tag || s || ")" else {
      s := tag || s
      every s ||:= Image(!x,style,done,depth) || ","
      s[-1] := endof(")",depth,style)
      }
   return s
end

# set image
#
procedure simage(S,done,depth,style)
   static i
   local s, tag
   initial i := 0
   if \done[S] then return done[S]
   done[S] := tag := "S" || (i +:= 1)
   if *S = 0 then s := tag || ":[]" else {
      s := tag || ":["
      every s ||:= Image(!S,style,done,depth) || ","
      s[-1] := endof("]",depth,style)
      }
   return s
end

#  table image
#
procedure timage(t,done,depth,style)
   static i
   local s, tag, a, a1
   initial i := 0
   if \done[t] then return done[t]
   done[t] := tag := "T" || (i +:= 1)
   if *t = 0 then s := tag || ":[]" else {
      a := sort(t,3)
      s := tag || ":["
      while s ||:= Image(get(a),style,done,depth) || "->" ||
           Image(get(a),style,done,depth,1) || ","
      s[-1] := endof("]",depth,style)
      }
   return s
end

procedure endof (s,depth,style)
   if style = 2 then return "\n" || repl(" ",depth) || "]"
   else return "]"
end

############################################################################
#
#  What follows is the breadth-first expansion style
#

procedure Imageb(x, done, tags)
   local t

   if /done then {
      done := [set([])]  # done[1] actually done; done[2:0] pseudo-done
      tags := table()    # unique label for each structure
      }

   if member(!done, x) then return tags[x]

   t := tagit(x, tags)     # The tag for x if structure; image(x) if not

   if /tags[x] then
      return t                       # Wasn't a structure
   else {
      insert(done[1], x)             # Mark x as actually done
      return case t[1] of {
         "R":  rimageb(x, done, tags)     # record
         "L":  limageb(x, done, tags)     # list
         "T":  timageb(x, done, tags)     # table
         "S":  simageb(x, done, tags)     # set
         }
      }
end


#  Create and return a tag for a structure, and save it in tags[x].
#  Otherwise, if x is not a structure, return image(x).
#
procedure tagit(x, tags)
   local ximage, t, prefix
   static serial
   initial serial := table(0)

   if \tags[x] then return tags[x]

   if match("record constructor ", ximage := image(x)) then
      return ximage                # record constructor

   if match("record ", t := ximage) |
      ((t := type(x)) == ("list" | "table" | "set")) then {
         prefix := map(t[1], "rlts", "RLTS")
         return tags[x] := prefix || (serial[prefix] +:=1)
         }                        # structure

   else return ximage             # anything else
end


#  Every component sub-structure of the current structure gets tagged
#  and added to a pseudo-done set.
#
procedure defer_image(a, done, tags)
   local x, t
   t := set([])
   every x := !a do {
      tagit(x, tags)
      if \tags[x] then insert(t, x)  # if x actually is a sub-structure
      }
   put(done, t)
   return
end


#  Create the image of every component of the current structure.
#  Sub-structures get deleted from the local pseudo-done set before
#  we actually create their image.
#
procedure do_image(a, done, tags)
   local x, t
   t := done[-1]
   suspend (delete(t, x := !a), Imageb(x, done, tags))
end


#  list image
#
procedure limageb(a, done, tags)
   local s
   if *a = 0 then s := tags[a] || ":[]" else {
      defer_image(a, done, tags)
      s := tags[a] || ":["
      every s ||:= do_image(a, done, tags) || ","
      s[-1] := "]"
      pull(done)
      }
   return s
end

#  record image
#
procedure rimageb(x, done, tags)
   local s
   s := image(x)
   s ?:=  (="record " & (":" || (tab(upto('(') + 1))))
   if *x = 0 then s := tags[x] || s || ")" else {
      defer_image(x, done, tags)
      s := tags[x] || s
      every s ||:= do_image(x, done, tags) || ","
      s[-1] := ")"
      pull(done)
      }
   return s
end

# set image
#
procedure simageb(S, done, tags)
   local s
   if *S = 0 then s := tags[S] || ":[]" else {
      defer_image(S, done, tags)
      s := tags[S] || ":["
      every s ||:= do_image(S, done, tags) || ","
      s[-1] := "]"
      pull(done)
      }
   return s
end

#  table image
#
procedure timageb(t, done, tags)
   local s, a
   if *t = 0 then s := tags[t] || ":[]" else {
      a := sort(t,3)
      defer_image(a, done, tags)
      s := tags[t] || ":["
      while s ||:= do_image([get(a)], done, tags) || "->" ||
                   do_image([get(a)], done, tags) || ","
      s[-1] := "]"
      pull(done)
      }
   return s
end
##########
largint.icn
############################################################################
#
#    Name:    largint.icn
#
#    Title:    Large integer arithmetic
#
#    Author:    Paul Abrahams and Ralph E. Griswold
#
#    Date:    May 11, 1989
#
############################################################################
#
#     These procedures perform addition, multiplication, and exponentiation
#  On integers given as strings of numerals:
#
#        add(i,j)      sum of i and j
#
#        mpy(i,j)      product of i and j
#
#        raise(i,j)    i to the power j
#
#  Note:
#
#     The techniques used by add and mpy are different from those used by
#  raise.  These procedures are combined here for organizational reasons.
#  The procedures add and mpy are adapted from the Icon language book.
#  The procedure raise was written by Paul Abrahams.
#
############################################################################

record largint(coeff,nextl)

global base, segsize

# Add i and j
#
procedure add(i,j)

   return lstring(addl(large(i),large(j)))

end

# Multiply i and j
#
procedure mpy(i,j)

   return lstring(mpyl(large(i),large(j)))

end

# Raise i to power j
#
procedure raise(i,j)

     return rstring(ipower(i,binrep(j)))

end

procedure addl(g1,g2,carry)
   local sum
   /carry := largint(0)    # default carry
   if /g1 & /g2 then return if carry.coeff ~= 0 then carry
   else &null
   if /g1 then return addl(carry,g2)
   if /g2 then return addl(g1,carry)
   sum := g1.coeff + g2.coeff + carry.coeff
   carry := largint(sum / base)
   return largint(sum % base,addl(g1.nextl,g2.nextl,carry))
end

procedure large(s)
   initial {
      base := 10000
      segsize := *base - 1
      }

   if *s <= segsize then return largint(integer(s))
   else return largint(right(s,segsize),
      large(left(s,*s - segsize)))
end

procedure lstring(g)
   local s

   if /g.nextl then s := g.coeff
   else s := lstring(g.nextl) || right(g.coeff,segsize,"0")
   s ?:= (tab(upto(~'0') | -1) & tab(0))
   return s
end

procedure mpyl(g1,g2)
   local prod
   if /(g1 | g2) then return &null    # zero product
   prod := g1.coeff * g2.coeff
   return largint(prod % base,
      addl(mpyl(largint(g1.coeff),g2.nextl),mpyl(g1.nextl,g2),
      largint(prod / base)))
end

# Compute the binary representation of n (as a string)
#
procedure binrep(n)
    local retval
    retval := ""
    while n > 0 do {
        retval := n % 2 || retval
        n /:= 2
        }
    return retval
end

# Compute a to the ipower bbits, where bbits is a bit string.
# The result is a list of coefficients for the polynomial a(i)*k^i,
# least significant values first, with k=10000 and zero trailing coefficient
# deleted.
#
procedure ipower(a, bbits)
    local b, m1, retval
    m1 := (if a >= 10000 then [a % 10000, a / 10000] else [a])
    retval := [1]
    every b := !bbits do {
        (retval := product(retval, retval)) | fail
        if b == "1" then
            (retval := product(retval, m1)) | fail
        }
    return retval
end

# Compute a*b as a polynomial in the same form as for ipower.
# a and b are also polynomials in this form.
#
procedure product(a,b)
    local i, j, k, retval, x
    if *a + *b > 5001 then
        fail
    retval := list(*a + *b, 0)
    every i := 1 to *a do
        every j := 1 to *b do {
            k := i + j - 1
            retval[k] +:= a[i] * b[j]
            while (x := retval[k]) >= 10000 do {
                retval[k + 1] +:= x / 10000
                retval[k] %:= 10000
                k +:= 1
            }   }
    every i := *retval to 1 by -1 do
        if retval[i] > 0 then
            return retval[1+:i]
    return retval[1+:i]
end

procedure rstring(n)
    local ds, i, j, k, result

    ds := ""
    every k := *n to 1 by -1 do
        ds ||:= right(n[k], 4, "0")
    ds ?:= (tab(many("0")), tab(0))
    ds := repl("0", 4 - (*ds - 1) % 5) || ds

    result := ""
    every i := 1 to *ds by 50 do {
        k := *ds > i + 45 | *ds
        every j := i to k by 5 do {
       ds
           result ||:= ds[j+:5]
       }
        }
   result ? {
      tab(many('0'))
      return tab(0)
      }
end
##########
lmap.icn
############################################################################
#
#    Name:    lmap.icn
#
#    Title:    Map list elements
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  The procedure lmap(a1,a2,a3) maps elements of a1 according to a2
#  and a3.  This procedure is the analog for lists of the built-in
#  string-mapping function map(s1,s2,s3). Elements in a1 that are
#  the same as elements in a2 are mapped into the corresponding ele-
#  ments of a3. For example, given the lists
#
#     a1 := [1,2,3,4]
#     a2 := [4,3,2,1]
#     a3 := ["a","b","c","d"]
#
#  then
#
#     lmap(a1,a2,a3)
#
#  produces a new list
#
#     ["d","c","b","a"]
#
#     Lists that are mapped can have any kinds of elements. The
#  operation
#
#     x === y
#
#  is used to determine if elements x and y are equivalent.
#
#     All cases in lmap are handled as they are in map, except that
#  no defaults are provided for omitted arguments. As with map, lmap
#  can be used for transposition as well as substitution.
#
#  Warning:
#
#     If lmap is called with the same lists a2 and a3 as in
#  the immediately preceding call, the same mapping is performed,
#  even if the values in a2 and a3 have been changed. This improves
#  performance, but it may cause unexpected effects.
#
#     This ``caching'' of the mapping table based on a2 and a3
#  can be easily removed to avoid this potential problem.
#
############################################################################

procedure lmap(a1,a2,a3)
   static lmem2, lmem3, lmaptbl, tdefault
   local i, a

   initial tdefault := []

   if type(a := a1 | a2 | a3) ~== "list" then runerr(108,a)
   if *a2 ~= *a3 then runerr(208,a2)

   a1 := copy(a1)

   if not(lmem2 === a2 & lmem3 === a3) then {    # if an argument is new, rebuild
      lmem2 := a2                # save for future reference
      lmem3 := a3
      lmaptbl := table(tdefault)        # new mapping table
      every i := 1 to *a2 do            # build the map
         lmaptbl[a2[i]] := a3[i]
      }
   every i := 1 to *a1 do            # map the values
      a1[i] := (tdefault ~=== lmaptbl[a1[i]])
   return a1
end
##########
math.icn
############################################################################
#
#    Name:    math.icn
#
#    Title:    Perform mathematical computations
#
#    Author:    George D. Yee
#
#    Date:    June 10, 1988
#
############################################################################
#
#  The following procedures compute standard trigonometric func-
#  tions.  The arguments are in radians.
#
#       sin(x)      sine of x
#
#       cos(x)      cosine of x
#
#       tan(x)      tangent of x
#
#       asin(x)     arc sine of x in the range -pi/2 to pi/2
#
#       acos(x)     arc cosine of x in the range 0 to pi
#
#       atan(x)     arc tangent of x in the range -pi/2 to pi/2
#
#       atan2(y,x)  arc tangent of x/y in the range -pi to pi
#
#  The following procedures convert from degrees to radians and con-
#  versely:
#
#       dtor(d)     radian equivalent of d
#
#       rtod(r)     degree equivalent of r
#
#  The following additional procedures are available:
#
#       sqrt(x)     square root of x
#
#       exp(x)      exponential function of x
#
#       log(x)      natural logarithm of x
#
#       log10(x)    base-10 logarithm of x
#
#       floor(x)    largest integer not greater than x
#
#       ceil(x)     smallest integer nor less than x
#
#  Failure Conditions: asin(x) and acos(x) fail if the absolute
#  value of x is greater than one. sqrt(x), log(x), and log10(x)
#  fail if x is less than zero.
#
############################################################################

procedure sin(x)
   return _sinus(numeric(x),0)
end

procedure cos(x)
   return _sinus(abs(numeric(x)),1)
end

procedure tan(x)
   return sin(x) / (0.0 ~= cos(x))
end

# atan returns the value of the arctangent of its
# argument in the range [-pi/2,pi/2].
procedure atan(x)
   if numeric(x) then
      return if x > 0.0 then _satan(x) else -_satan(-x)
end

# atan2 returns the arctangent of y/x
# in the range [-pi,pi].
procedure atan2(y,x)
   local r
   static pi
   initial pi := 3.141592653589793238462643
   return if numeric(y) & numeric(x) then {
      if x > 0.0 then
         atan(y/x)
      else if x < 0.0 then {
         r := pi - atan(abs(y/x))
         if y >= 0.0 then r else -r
         }
      else if x = y = 0.0 then
         0.0         # special value if both x and y are zero
      else
         if y >= 0.0 then pi/2.0 else -pi/2.0
      }
end

procedure asin(x)
   if abs(numeric(x)) <= 1.0 then
      return atan2(x, (1.0-(x^2))^0.5)
end

procedure acos(x)
   return 1.570796326794896619231e0 - asin(x)
end

procedure dtor(deg)
   return numeric(deg)/57.29577951308232
end

procedure rtod(rad)
   return numeric(rad)*57.29577951308232
end

procedure sqrt(x)
    return (0.0 <= numeric(x)) ^ 0.5
end

procedure floor(x)
   return if numeric(x) then
      if x>=0.0 | real(x)=integer(x) then integer(x) else -integer(-x+1)
end

procedure ceil(x)
   return -floor(-numeric(x))
end

procedure log(x)
   local z, zsq, ex
   static log2, sqrto2, p0, p1, p2, p3, q0, q1, q2
   initial {
      # The coefficients are #2705 from Hart & Cheney. (19.38D)
      log2   :=  0.693147180559945309e0
      sqrto2 :=  0.707106781186547524e0
      p0     := -0.240139179559210510e2
      p1     :=  0.309572928215376501e2
      p2     := -0.963769093368686593e1
      p3     :=  0.421087371217979714e0
      q0     := -0.120069589779605255e2
      q1     :=  0.194809660700889731e2
      q2     := -0.891110902798312337e1
      }
   if numeric(x) > 0.0 then {
      ex := 0
      while x >= 1.0 do {
         x /:= 2.0
         ex +:= 1
         }
      while x < 0.5 do {
         x *:= 2.0
         ex -:= 1
         }
      if x < sqrto2 then {
         x *:= 2.0
         ex -:= 1
         }
      return ((((p3*(zsq:=(z:=(x-1.0)/(x+1.0))^2)+p2)*zsq+p1)*zsq+p0)/
             (((1.0*zsq+q2)*zsq+q1)*zsq+q0))*z+ex*log2
      }
end

procedure exp(x)
   return 2.718281828459045235360287 ^ numeric(x)
end

procedure log10(x)
   return log(x)/2.30258509299404568402
end

procedure _sinus(x,quad)
   local ysq, y, k
   static twoopi, p0, p1, p2, p3, p4, q0, q1, q2, q3
   initial {
      # Coefficients are #3370 from Hart & Cheney (18.80D).
      twoopi :=  0.63661977236758134308
      p0     :=  0.1357884097877375669092680e8
      p1     := -0.4942908100902844161158627e7
      p2     :=  0.4401030535375266501944918e6
      p3     := -0.1384727249982452873054457e5
      p4     :=  0.1459688406665768722226959e3
      q0     :=  0.8644558652922534429915149e7
      q1     :=  0.4081792252343299749395779e6
      q2     :=  0.9463096101538208180571257e4
      q3     :=  0.1326534908786136358911494e3
      }
   if x < 0.0 then {
      x := -x
      quad +:= 2
      }
   y := (x *:= twoopi) - (k := integer(x))
   if (quad := (quad + k) % 4) = (1|3) then
      y := 1.0 - y
   if quad > 1 then
      y := -y
   return (((((p4*(ysq:=y^2)+p3)*ysq+p2)*ysq+p1)*ysq+p0)*y) /
           ((((ysq+q3)*ysq+q2)*ysq+q1)*ysq+q0)
end

procedure _satan(x)
   static sq2p1,sq2m1,pio2,pio4
   initial {
      sq2p1 := 2.414213562373095048802e0
      sq2m1 := 0.414213562373095048802e0
      pio2  := 1.570796326794896619231e0
      pio4  := 0.785398163397448309615e0
      }
   return if x < sq2m1 then
             _xatan(x)
          else if x > sq2p1 then
             pio2 - _xatan(1.0/x)
          else
             pio4 + _xatan((x-1.0)/(x+1.0))
end

procedure _xatan(x)
   local xsq
   static p4,p3,p2,p1,p0,q4,q3,q2,q1,q0
   initial {
      # coefficients are #5077 from Hart & Cheney. (19.56D)
      p4    := 0.161536412982230228262e2
      p3    := 0.26842548195503973794141e3
      p2    := 0.11530293515404850115428136e4
      p1    := 0.178040631643319697105464587e4
      p0    := 0.89678597403663861959987488e3
      q4    := 0.5895697050844462222791e2
      q3    := 0.536265374031215315104235e3
      q2    := 0.16667838148816337184521798e4
      q1    := 0.207933497444540981287275926e4
      q0    := 0.89678597403663861962481162e3
      }
   return x * ((((p4*(xsq:=x^2)+p3)*xsq+p2)*xsq+p1)*xsq+p0) /
          (((((xsq+q4)*xsq+q3)*xsq+q2)*xsq+q1)*xsq+q0)
end
##########
morse.icn
############################################################################
#
#    Name:    morse.icn
#
#    Title:    Convert string to Morse code
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#     This procedure converts the string s to its Morse code equivalent.
#
############################################################################

procedure morse(s)
   local i, t, c, x
   static morsemeander, morseindex

   initial {
      morsemeander := "....------.----..---.-.---...--.--._
         -..--..-.--....-.-.-...-..-....."
      morseindex :=   "TMOT09TTT1T8TT2GQTTTJTZ7T3NKYTTCTTT_
         TDXTTWPTB64EARTTLTVTIUFTSH5"
      }

   x := ""
   every c := !map(s,&lcase,&ucase) do
      if not(i := upto(c,morseindex)) then x := x || "    "
         else {
            t := morsemeander[i+:6]
            x := x || t[upto("-",t)+1:0] || " "
            }
   return x
end
##########
ngrams.icn
############################################################################
#
#    Name:    ngrams.icn
#
#    Title:    Generate n-grams
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#     The procedure ngrams(file,n,c,t) generates a tabulation of the n-grams
#  in the specified file.  If c is non-null, it is used as the set of
#  characters from which n-grams are taken (other characters break n-grams).
#  The default for c is the upper- and lowercase letters.  If t is non-null,
#  the tabulation is given in order of frequency; otherwise in alphabetical
#  order of n-grams.
#
#  Note:
#
#     The n-grams are kept in a table within the procedure and all n-grams
#  are processed before the tabulation is generated. Consequently, this
#  procedure is unsuitable if there are very many different n-grams.
#
############################################################################

procedure ngrams(f,i,c,t)
   local line, grams, a, count

   if not (integer(i) > 0) then stop("invalid ngrams specification")
   if type(f) ~== "file" then stop("invalid file specification")
   /c := &lcase || &ucase
   if not (c := cset(c)) then stop("invalid cset specification")
   grams := table(0)
   line := ""
   while line ||:= reads(f,1000) do
      line ? while tab(upto(c)) do
         (tab(many(c)) \ 1) ? while grams[move(i)] +:= 1 do
            move(-i + 1)
   if /t then {
      a := sort(grams,4)
      while count := pull(a) do
         suspend pull(a) || right(count,8)
         }
   else {
      a := sort(grams,3)
      suspend |(get(a) || right(get(a),8))
      }
end
##########
numbers.icn
############################################################################
#
#    Name:    numbers.icn
#
#    Title:    Format and convert numbers
#
#    Author:    Ralph E. Griswold and Tim Korb
#
#    Date:    June 10, 1988
#
############################################################################
#
#     These procedures format numbers in various ways:
#
#     commas(s)          inserts commas in s to separate digits into groups of
#                        three.
#
#     roman(i)           converts s to Roman numerals.
#
#     spell(i)           spells out i in English.
#
#     fpform(i,j,m,l,d)  formats i / j as a real (floating-point) number.
#                        If m is non-null, the result is multiplied by m. The
#                        default for m is 100 (giving a percentage). If l
#                        is non-null, the resulting string is l characters
#                        long (minimum 6); otherwise is is 7 characters long.
#                        If d is non-null, d digits to the right of the
#                        decimal point are produced; otherwise 3.
#
############################################################################
#
#  Bug:
#
#     The procedure fpform() is not well conceived. It produces bogus
#  results in some cases if the formatting specifications are not
#  appropriate.
#
############################################################################

procedure commas(n)
   if *n < 4 then return n
   else return commas(left(n,*n - 3)) || map(",123","123",right(n,3))
end

#  This procedure is based on a SNOBOL4 function written by Jim Gimpel.
#
procedure roman(n)
   local arabic, result
   static equiv
   initial equiv := ["","I","II","III","IV","V","VI","VII","VIII","IX"]
   integer(n) > 0 | fail
   result := ""
   every arabic := !n do
      result := map(result,"IVXLCDM","XLCDM**") || equiv[arabic + 1]
   if find("*",result) then fail else return result
end

procedure spell(n)
   local m
   n := integer(n) | stop(image(n)," is not an integer")
   if n <= 12 then return {
      "0zero,1one,2two,3three,4four,5five,6six,7seven,8eight,_
         9nine,10ten,11eleven,12twelve," ? {
            tab(find(n))
            move(*n)
            tab(upto(","))
            }
      }
   else if n <= 19 then return {
      spell(n[2] || "0") ?
         (if ="for" then "four" else tab(find("ty"))) || "teen"
      }
   else if n <= 99 then return {
      "2twen,3thir,4for,5fif,6six,7seven,8eigh,9nine," ? {
         tab(upto(n[1]))
         move(1)
         tab(upto(",")) || "ty" ||
            if n[2] ~= 0 then "-" || spell(n[2])
         }
      }
   else if n <= 999 then return {
      spell(n[1]) || " hundred" ||
         (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "")
      }
   else if n <= 999999 then return {
      spell(n[1:-3]) || " thousand" ||
         (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "")
      }
   else if n <= 999999999 then return {
      spell(n[1:-6]) || " million" ||
         (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "")
      }
   else fail
end

procedure fpform(i,j,m,l,d)
   local r, int, dec

   /l := 7
   /d := 3

   if (l < 6) | ((l - d) < 3) then
      stop("cannot format according to specifications")
   r := real(i) / j
   r *:= (\m | 100)
   if r < 0.001 then return repl(" ",l - 5) || "0.000"
   string(r) ? {
      int := tab(upto('.'))
      move(1)
      dec := tab(0)
      }
   return right(int,l - d - 1) || "." || left(dec,d,"0")
end
##########
object.icn
############################################################################
#
#    Name:    object.icn
#
#    Title:    Encode and decode Icon values
#
#    Author:    Kurt A. Welgehausen
#
#    Date:    June 10, 1988
#
############################################################################
#
#     These procedures provide a way of storing Icon values as strings in
#  files and reconstructing them.
#
#     putobj(obj, f) stores the Icon data object obj in the file f; it returns
#  the object stored.  The returned value is usually not of interest, so a
#  typical call is putobj(x, f).
#
#     The file f must be open for writing; if f is null, it defaults to &output.
#
#     Strings are stored as single lines in the file, with unprintable
#  characters stored as the escape sequences produced by image().
#
#  Integers, reals, and csets are writen to the file as single lines of the
#  form "%"type(obj)string(obj), for example
#
#      123 is stored as "%integer123"
#      123.4 is stored as "%real123.4"
#      '123' is stored as "%cset123"
#
#     As in strings, unprintable characters in csets are stored as the escape
#  sequences produced by image().
#
#     Procedures, functions,and record constructors are stored as strings of the
#  form #  "%proc"procedure-name.  For example, the function write() is stored
#  as "%procwrite".
#
#     Files are stored as strings of the form "#file("file-name")".  For
#  example, if f is a file variable connected to the disk file example.fil,
#  then f is stored by putobj() as "#file(example.fil)".
#
#     Co-expressions are stored as the string "#co-expr".
#
#     Null objects are stored as lines containing only "%".
#
#     Structured objects are stored as single lines of the form
#  "%"type(obj)"("n")", where n is the size of obj, followed by the n
#  components of obj (tables are stored as their default assigned values
#  followed by sorted lists of index and #  assigned values).  putobj() calls
#  itself recursively to store the components.  For example,
#
#        ["aaa", ["bbb", 'edc'], 16rfff, open("somefile"), create write(1 to 3)]
#
#  is stored as
#
#          %list(5)
#          aaa
#          %list(2)
#          bbb
#          %csetcde
#          %integer4095
#          #file(somefile)
#          #co-expr
#
#
#     getobj(f) retrieves an Icon data object from the file f; it returns the
#  object.  A typical call is "x := getobj(f)".
#
#     The file f must be open for reading; if f is null, it defaults to &input.
#
#     The object to be retrieved must have been stored in the format used by
#  putobj().
#
#     No attempt is made to reconstruct file variables or co-expressions; only
#  the descriptive string is returned.  It is up to the programmer to open the
#  file or recreate the co-expression.  For all other types, the actual Icon
#  object is returned.
#
############################################################################
#
#  Warning:
#
#     putobj(x) calls itself to process structures in x.  If there is a
#  loop in the structure, putobj(x) gets stack overflow due to excessive
#  recursion.
#
#     Objects stored with putobj() and then retrieved with getobj() may
#  not be identical to the original objects.  For example, if x is an Icon
#  structure and y := [x, x], then y[1] and y[2] are identical; but
#  after storing and retrieving y, y[1] and y[2] will be copies of each
#  other but will not be the same object.
#
#     To  avoid these problems, use codeobj.icn instead of object.icn.
#
############################################################################
#
#  Links: escape
#
#  See also: codeobj.icn
#
############################################################################

link  escape

global  HDRSYM, ESCSYM

procedure getobj(f)
    local  line, buf, otype, size
    initial  { /HDRSYM:= "%"; /ESCSYM:= "@" }   # these defs must be the same as
                                                # those in putobj()
    /f:= &input
    (line:= (read(f) | fail)) ? {
        case move(1) | "" of {
            ESCSYM: buf:= escape(tab(0))
            HDRSYM: {
             (otype:= tab(upto('(')), move(1), size:= integer(tab(upto(')')))) |
               (buf:=
                  (=("integer" | "real" | "cset" | "proc"))(escape(tab(0)))) |
                 &null    # must succeed
            }
            "&": buf:= case tab(0) of {
                    "input": &input ;  "output": &output ;  "errout": &errout
                    "cset": &cset ;  "ascii": &ascii
                    "lcase": &lcase ;  "ucase": &ucase
                 }
            default: buf:= escape(line)
        }
    }
    \size & {       # not-null size means a structured type
        ((otype == "table") & (buf:= getobj(f))) |
            ((otype == "set") & (buf:= []))
        buf:= otype(buf)
        case otype of {
            "list": every 1 to size do put(buf, getobj(f))
            "table": every 1 to size do buf[getobj(f)]:= getobj(f)
            "set": every 1 to size do insert(buf, getobj(f))
            default: every buf[1 to size]:= getobj(f)
        }
    }
    return  buf
end
# Put object <obj> on file <f>; <f> must be open for writing.
# If <f> is not specified, output goes to &output.

global  HDRSYM, ESCSYM

procedure putobj(obj, f)
    local  t, buf
    initial  { /HDRSYM:= "%"; /ESCSYM:= "@" }  # these defs must be the same as
                                               # those in getobj()
    /f:= &output
    case t:= type(obj) of {
        "string": {
            match(ESCSYM | HDRSYM | "&", obj) & (obj:= ESCSYM || obj)
            write(f, image(obj)[2:-1])
        }
        "integer" | "real": write(f, HDRSYM, t, obj)
        "cset": {
            buf:= image(obj)
            (match("&", buf) & write(f, buf)) | write(f, HDRSYM, t, buf[2:-1])
        }
        "null": write(f, HDRSYM)
        "procedure": image(obj) ? {
            =("procedure " | "function " | "record constructor ")
            write(f, HDRSYM, "proc", tab(0))
        }
        "file": image(obj) ? write(f, (="&" | "#") || tab(0))
        "co-expression": write(f, "#", t[1:8])
        default: {
            write(f, HDRSYM, t, "(", *obj, ")")
            (t == "table", putobj(obj[[]], f), buf:= sort(obj, 3)) | (buf:= obj)
            (*buf > 0) & every putobj(!buf, f)
        }
    }
    return  obj
end
##########
options.icn
############################################################################
#
#    Name:        options.icn
#
#    Title:        Get command-line options
#
#    Authors:    Robert J. Alexander, June 10, 1988
#            Gregg M. Townsend, November 9, 1989
#
############################################################################
#
#     options(arg,optstring) -- Get command line options.
#
#     This procedure analyzes the -options on the command line
#  invoking an Icon program.  The inputs are:
#
#       arg         the argument list as passed to the main procedure.
#
#       optstring   a string of allowable option letters. If a
#                   letter is followed by ":" the corresponding
#                   option is assumed to be followed by a string of
#                   data, optionally separated from the letter by
#                   space. If instead of ":" the letter is followed
#                   by a "+", the parameter will converted to an
#                   integer; if a ".", converted to a real.  If opt-
#                   string is omitted any letter is assumed to be
#                   valid and require no data.
#
#     It returns a table containing the options that were specified.
#  The keys are the specified option letters. The assigned values are
#  the data words following the options, if any, or 1 if the option
#  has no data. The table's default value is &null.
#
#     If an error is detected, stop() is called with an appropriate
#  error message.
#
#     Options may be freely interspersed with non-option arguments.
#  An argument of "-" is treated as a non-option.  The special argument
#  "--" terminates option processing.  Non-option arguments are returned
#  in the original argument list for interpretation by the caller.
#
############################################################################

procedure options(arg,optstring)
   local x,i,c,otab,flist,o,p
   /optstring := string(&lcase ++ &ucase)
   otab := table()
   flist := []
   while x := get(arg) do
      x ? {
         if ="-" & not pos(0) then {
            if ="-" & pos(0) then break
            while c := move(1) do
               if i := find(c,optstring) + 1 then
                  otab[c] :=
                     if any(':+.',o := optstring[i]) then {
                        p := "" ~== tab(0) | get(arg) |
                              stop("No parameter following -",c)
                        case o of {
                           ":": p
                           "+": integer(p) |
                                 stop("-",c," needs numeric parameter")
                           ".": real(p) |
                                 stop("-",c," needs numeric parameter")
                           }
                        }
                     else 1
               else stop("Unrecognized option: -",c)
         }
         else put(flist,x)
      }
   while push(arg,pull(flist))
   return otab
end
##########
patterns.icn
############################################################################
#
#    Name:    patterns.icn
#
#    Title:    Pattern matching in the style of SNOBOL4
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  These procedures provide procedural equivalents for most SNOBOL4
#  patterns and some extensions.
#
#  Procedures and their pattern equivalents are:
#
#       Any(s)         ANY(S)
#
#       Arb()          ARB
#
#       Arbno(p)       ARBNO(P)
#
#       Arbx(i)        ARB(I)
#
#       Bal()          BAL
#
#       Break(s)       BREAK(S)
#
#       Breakx(s)      BREAKX(S)
#
#       Cat(p1,p2)     P1 P2
#
#       Discard(p)     /P
#
#       Exog(s)        \S
#
#       Find(s)        FIND(S)
#
#       Len(i)         LEN(I)
#
#       Limit(p,i)     P \ i
#
#       Locate(p)      LOCATE(P)
#
#       Marb()         longest-first ARB
#
#       Notany(s)      NOTANY(S)
#
#       Pos(i)         POS(I)
#
#       Replace(p,s)   P   S
#
#       Rpos(i)        RPOS(I)
#
#       Rtab(i)        RTAB(I)
#
#       Span(s)        SPAN(S)
#
#       String(s)      S
#
#       Succeed()      SUCCEED
#
#       Tab(i)         TAB(I)
#
#       Xform(f,p)     F(P)
#
#     The following procedures relate to the application and control
#  of pattern matching:
#
#       Apply(s,p)     S ? P
#
#       Mode()         anchored or unanchored matching (see Anchor
#                      and Float)
#
#       Anchor()       &ANCHOR = 1  if Mode := Anchor
#
#       Float()        &ANCHOR = 0  if Mode := Float
#
#  In addition to the procedures above, the following expressions
#  can be used:
#
#       p1() | p2()    P1 | P2
#
#       v <- p()       P . V  (approximate)
#
#       v := p()       P $ V  (approximate)
#
#       fail           FAIL
#
#       =s             S  (in place of String(s))
#
#       p1() || p2()   P1 P2  (in place of Cat(p1,p2))
#
#  Using this system, most SNOBOL4 patterns can be satisfactorily
#  transliterated into Icon procedures and expressions. For example,
#  the pattern
#
#          SPAN("0123456789") $ N "H" LEN(*N) $ LIT
#
#  can be transliterated into
#
#          (n <- Span('0123456789')) || ="H" ||
#             (lit <- Len(n))
#
#  Concatenation of components is necessary to preserve the
#  pattern-matching properties of SNOBOL4.
#
#  Caveats: Simulating SNOBOL4 pattern matching using the procedures
#  above is inefficient.
#
############################################################################

global Mode, Float

procedure Anchor()            #  &ANCHOR = 1
   suspend ""
end

procedure Any(s)            #  ANY(S)
   suspend tab(any(s))
end

procedure Apply(s,p)            #  S ? P
   local tsubject, tpos, value
   initial {
      Float := Arb
      /Mode := Float            #  &ANCHOR = 0 if not already set
      }
   suspend (
      (tsubject := &subject) &
      (tpos := &pos) &
      (&subject <- s) &
      (&pos <- 1) &
      (Mode() & (value := p())) &
      (&pos <- tpos) &            # to restore on backtracking
      (&subject <- tsubject) &        # note this sets &pos
      (&pos <- tpos) &            # to restore on evaluation
      value
      )
end

procedure Arb()                #  ARB
   suspend tab(&pos to *&subject + 1)
end

procedure Arbno(p)            #  ARBNO(P)
   suspend "" | (p() || Arbno(p))
end

procedure Arbx(i)            #  ARB(I)
   suspend tab(&pos to *&subject + 1 by i)
end

procedure Bal()                #  BAL
   suspend Bbal() || Arbno(Bbal)
end

procedure Bbal()            #  used by Bal()
   suspend (="(" || Arbno(Bbal) || =")") | Notany("()")
end

procedure Break(s)            #  BREAK(S)
   suspend tab(upto(s) \ 1)
end

procedure Breakx(s)            #  BREAKX(S)
   suspend tab(upto(s))
end

procedure Cat(p1,p2)            #  P1 P2
   suspend p1() || p2()
end

procedure Discard(p)            #  /P
   suspend p() & ""
end

procedure Exog(s)            #  \S
   suspend s
end

procedure Find(s)            #  FIND(S)
   suspend tab(find(s) + 1)
end

procedure Len(i)            #  LEN(I)
   suspend move(i)
end

procedure Limit(p,i)            #  P \ i
   local j
   j := &pos
   suspend p() \ i
   &pos := j
end

procedure Locate(p)            #  LOCATE(P)
   suspend tab(&pos to *&subject + 1) & p()
end

procedure Marb()            # max-first ARB
   suspend tab(*&subject + 1 to &pos by -1)
end

procedure Notany(s)            #  NOTANY(S)
   suspend tab(any(~s))
end

procedure Pos(i)            #  POS(I)
   suspend pos(i + 1) & ""
end

procedure Replace(p,s)            #  P = S
   suspend p() & s
end

procedure Rpos(i)            #  RPOS(I)
   suspend pos(-i) & ""
end

procedure Rtab(i)            #  RTAB(I)
   suspend tab(-i)
end

procedure Span(s)            #  SPAN(S)
   suspend tab(many(s))
end

procedure String(s)            #  S
   suspend =s
end

procedure Succeed()            #  SUCCEED
   suspend |""
end

procedure Tab(i)            #  TAB(I)
   suspend tab(i + 1)
end

procedure Xform(f,p)            #  F(P)
   suspend f(p())
end
##########
patword.icn
############################################################################
#
#    Name:    patword.icn
#
#    Title:    Letter patterns in words
#
#    Author:    Kenneth Walker
#
#    Date:    June 10, 1988
#
############################################################################
#
#     The procedure patword(s) returns a letter pattern in which each
#  different character in s is assigned a letter.  For example,
#  patword("structural") returns "abcdedbcfg".
#
############################################################################

procedure patword(s)
    local numbering, orderS, orderset, patlbls
    static labels, revnum

    initial {
    labels := &lcase || &lcase
    revnum := reverse(&cset)
    }

# First map each character of s into another character, such that the
# the new characters are in increasing order left to right (note that
# the map function chooses the rightmost character of its second
# argument, so things must be reversed.
#
# Next map each of these new characters into contiguous letters.

    numbering := revnum[1 : *s + 1] | stop("word too long")
    orderS := map(s, reverse(s), numbering)
    orderset := string(cset(orderS))
    patlbls := labels[1 : *orderset + 1] | stop("too many characters")
    return map(orderS, orderset, patlbls)
end
##########
pdae.icn
############################################################################
#
#    Name:    pdae.icn
#
#    Title:    Programmer-defined argument evaluation
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  These procedures use co-expressions to model the built-in argu-
#  ment evaluation regime of Icon and also provide new ones.
#
#       Allpar{e1,e2, ...}   parallel evaluation with last result
#                            used for short sequences
#
#       Extract{e1,e2, ...}  extract results of even-numbered argu-
#                            ments according to odd-numbered values
#
#       Lifo{e1,e2, ...}     models standard Icon ``lifo'' evalua-
#                            tion
#
#       Parallel{e1,e2, ...} parallel evaluation terminating on
#                            shortest sequence
#
#       Reverse{e1,e2, ...}  left-to-right reversal of lifo evalua-
#                            tion
#
#       Rotate{e1,e2, ...}   parallel evaluation with shorter
#                            sequences re-evaluated
#
#       Simple{e1,e2, ...}   simple evaluation with only success or
#                            failure
#
#  Comments:
#
#     Because of the handling of the scope of local identif-
#  iers in co-expressions, expressions in programmer-defined argu-
#  ment evaluation regimes cannot communicate through local identif-
#  iers.  Some constructions, such as break and return, cannot be
#  used in arguments to programmer-defined argument evaluation
#  regimes.
#
#     At most 10 arguments can be used in the invocation of a
#  programmer-defined argument evaluation regime. This limit can be
#  increased by modifying Call, a utility procedure that is
#  included. (The variable-argument facility in Version 7 of Icon should
#  be used to overcome this restriction.)
#
############################################################################

procedure Allpar(a)
   local i, x, done
   x := list(*a)
   done := list(*a,1)
   every i := 1 to *a do x[i] := @a[i] | fail
   repeat {
      suspend Call(x)
      every i := 1 to *a do
         if done[i] = 1 then ((x[i] := @a[i]) | (done[i] := 0))
      if not(!done = 1) then fail
       }
end

procedure Call(a)
   suspend case *a of {
      1 : a[1]()
      2 : a[1](a[2])
      3 : a[1](a[2],a[3])
      4 : a[1](a[2],a[3],a[4])
      5 : a[1](a[2],a[3],a[4],a[5])
      6 : a[1](a[2],a[3],a[4],a[5],a[6])
      7 : a[1](a[2],a[3],a[4],a[5],a[6],a[7])
      8 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8])
      9 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9])
      10 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],a[10])
      default :  stop("Call : too many args.")
      }
end

procedure Extract(a)
   local i, j, n, x
   x := list(*a/2)
   repeat {
      i := 1
      while i < *a do {
         n := @a[i] | fail
         every 1 to n do
            x[(i + 1)/2] := @a[i + 1] | fail
         a[i + 1] := ^a[i + 1]
         i +:= 2
         }
      suspend Call(x)
      }
end

procedure Lifo(a)
   local i, x, ptr
   x := list(*a)
   ptr := 1
   repeat {
      repeat
         if x[ptr] := @a[ptr]
         then {
            ptr +:= 1
            (a[ptr] := ^a[ptr]) |
            break
            }
         else if (ptr -:=  1) = 0
              then fail
      suspend Call(x)
      ptr := *a
      }
end

procedure Parallel(a)
   local i, x
   x := list(*a)
   repeat {
      every i := 1 to *a do
         x[i] := @a[i] | fail
      suspend Call(x)
      }
end

procedure Reverse(a)
   local i, x, ptr
   x := list(*a)
   ptr := *a
   repeat {
      repeat
         if x[ptr] := @a[ptr]
         then {
            ptr -:= 1
            (a[ptr] := ^a[ptr]) |
            break
            }
         else if (ptr +:= 1) > *a
              then fail
      suspend Call(x)
      ptr := 1
      }
end

procedure Rotate(a)
   local i, x, done
   x := list(*a)
   done := list(*a,1)
   every i := 1 to *a do x[i] := @a[i] | fail
   repeat {
      suspend Call(x)
      every i := 1 to *a do
         if not(x[i] := @a[i]) then {
            done[i] := 0
            if !done = 1 then {
               a[i] := ^a[i]
               x[i] := @a[i] | fail
               }
            else fail
            }
        }
end

procedure Simple(a)
   local i, x
   x := list(*a)
   every i := 1 to *a do
      x[i] := @a[i] | fail
   return Call(x)
end

##########
pdco.icn
############################################################################
#
#    Name:    pdco.icn
#
#    Title:    Programm-defined control operations
#
#    Author:    Ralph E. Griswold
#
#    Date:    November 16, 1989
#
############################################################################
#
#  These procedures use co-expressions to used to model the built-in
#  control structures of Icon and also provide new ones.
#
#       Alt{e1,e2}         models e1 | e2
#
#       Colseq{e1,e2, ...} produces results of e1, e2, ... alter-
#                          nately
#
#       Comseq{e1,e2}      compares result sequences of e1 and e2
#
#       Cond{e1,e2, ...}   models the generalized Lisp conditional
#
#       Every{e1,e2}       models every e1 do e2
#
#       Galt{e1,e2, ...}   models generalized alternation: e1 | e2 |
#                          ...
#
#       Lcond{e1,e2, ...}  models the Lisp conditional
#
#       Limit{e1,e2}       models e1 \ e2
#
#       Ranseq{e1,e2, ...} produces results of e1, e2, ... at random
#
#       Repalt{e}          models |e
#
#       Resume{e1,e2,e3}   models every e1 \ e2 do e3
#
#       Select{e1,e2}      produces results from e1 by position
#                          according to e2
#
#  Comments:
#
#     Because of the handling of the scope of local identif-
#  iers in co-expressions, expressions in programmer-defined control
#  operations cannot communicate through local identifiers.  Some
#  constructions, such as break and return, cannot be used in argu-
#  ments to programmer-defined control operations.
#
############################################################################

procedure Alt(L)
   local x
   while x := @L[1] do suspend x
   while x := @L[2] do suspend x
end

procedure Colseq(L)
   suspend |@!L
end

procedure Comseq(L)
   local x1, x2
   while x1 := @L[1] do
      (x1 === @L[2]) | fail
   if @L[2] then fail else return *L[1]
end

procedure Cond(L)
   local i, x
   every i := 1 to *l do
      if x := @L[i] then {
         suspend x
         suspend |@L[i]
         fail
         }
end

procedure Every(L)
   while @L[1] do @^L[2]
end

procedure Galt(L)
   local C
   every C := !L do suspend |@C
end

procedure Lcond(L)
   local i
   every i := 1 to *L by 2 do
      if @L[i] then {
         suspend |@L[i + 1]
         fail
         }
end

procedure Limit(L)
   local i, x
   while i := @L[2] do {
      every 1 to i do
         if x := @L[1] then suspend x
         else break
      L[1] := ^L[1]
      }
end

procedure Ranseq(L)
   local x
   while x := @?L do suspend x
end

procedure Repalt(L)
   local x
   repeat {
      while x := @L[1] do suspend x
      if *L[1] = 0 then fail
      else L[1] := ^L[1]
      }
end

procedure Resume(L)
   local i
   while i := @L[2] do {
      L[1] := ^L[1]
      every 1 to i do if @L[1] then @^L[3] else break
      }
end

procedure Select(L)
   local i, j, x
   j := 0
   while i := @L[2] do {
      while j < i do
         if x := @L[1] then j +:= 1
         else fail
      if i = j then suspend x
      else stop("selection sequence error")
      }
end
##########
permute.icn
############################################################################
#
#    Name:    permute.icn
#
#    Title:    Permutations, combinations, and such
#
#    Author:    Ralph E. Griswold and Kurt A. Welgehausen
#
#    Date:    May 9, 1989
#
############################################################################
#
#     These procedures produce various rearrangements of strings of
#  characters:
#
#     comb(s,i)       generates the combinations characters from s taken
#                     i at a time.
#
#     permute(s)      generates all the permutations of the string s.
#
#     menader(s,n)    produces a "meandering" string which contains all
#                     n-tuples of characters of s.
#
#     csort(s)        produces the characters of s in lexical order.
#
#     ochars(s)       produces the unique characters of s in the order they
#                     first appear in s.
#
#     schars(s)       produces the unique characters of s in lexical order.
#
############################################################################

procedure comb(s,i)
   local j

   if i < 1 then fail
   suspend if i = 1 then !s
      else s[j := 1 to *s - i + 1] || comb(s[j + 1:0],i - 1)
end

procedure permute(s)
   local i

   if *s = 0 then return ""
   suspend s[i := 1 to *s] || permute(s[1:i] || s[i+1:0])
end

procedure meander(alpha,n)
   local result, t, i, c, k

   i := k := *alpha
   t := n - 1
   result := repl(alpha[1],t)
   while c := alpha[i] do {
      if find(result[-t:0] || c,result)
      then i -:= 1
      else {
         result ||:= c
         i := k
         }
      }
   return result
end

procedure csort(s)
   local c, s1

   s1 := ""
   every c := !cset(s) do
      every find(c,s) do
         s1 ||:= c
   return s1
end

procedure schars(s)
   return string(cset(s))
end

procedure ochars(w)
   local out, c

   out := ""
   every c := !w do
    if not find(c,out) then
        out ||:= c

   return out

end
##########
phoname.icn
############################################################################
#
#    Name:    phoname.icn
#
#    Title:    Generate letter combinations for phone numbers
#
#    Author:    Unknown
#
#    Date:    June 10, 1988
#
############################################################################
#
#     This procedure generates the letter combinations corresponding to the
#  digits in a telephone number.
#
#  Warning:
#
#     The number of possibilities is very large. This procedure should be
#  used in a context that limits or filters its output.
#
############################################################################

procedure phoname(number)

    local buttons, nondigits, pstr, t, x


    buttons := ["000","111","abc","def","ghi","jkl","mno", "prs","tuv","wxy"]
    nondigits := ~&digits

    pstr := stripstr(number,nondigits)

    if 7 ~= *pstr then fail
    t := []
    every x := !pstr do
    put(t,buttons[x+1])

    suspend !t[1] || !t[2] || !t[3] || !t[4] || !t[5] || !t[6] || !t[7]

end

procedure stripstr(str,delchs)

    local i

    i := 1
    while i <= *str do
    {
    if any(delchs,str,i) then
        str[i] := ""
    else
        i +:= 1
    }

    return str

end # stripstr
##########
printcol.icn
############################################################################
#
#    Name:    printcol.icn
#
#    Title:    Format columnar data
#
#    Author:    Robert J. Alexander
#
#    Date:    June 10, 1988
#
############################################################################
#
#     This procedure deals with with the problem of printing tabular
#  data where the total width of items to be printed is wider than
#  the page.  Simply allowing the data to wrap to additional lines
#  often produces marginally readable output.  This procedure facil-
#  itates printing such groups of data as vertical columns down the
#  page length, instead of as horizontal rows across the page.  That
#  way many, many fields can be printed neatly.  The programming of
#  such a transformation can be a nuisance.  This procedure does
#  much of the work for you, like deciding how many items can fit
#  across the page width and ensuring that entire items will be
#  printed on the same page without page breaks (if that service is
#  requested).
#
#     For example, suppose we have a list of records we would like
#  to print.  The record is defined as:
#
#          record rec(item1,item2,item3,...)
#
#  Also suppose that lines such as
#
#          Field 1   Field 2   Field 3     ...
#          -------   -------   -------     ---
#          Record 1    item1     item2     item3      ...
#          Record 2    item1     item2     item3      ...
#
#  are too long to print across the page.  This procedure will print
#  them as:
#
#          TITLE
#          =====
#          Record 1   Record 2     ...
#          --------   --------     ---
#          Field 1   item1      item1       ...
#          Field 2   item2      item2       ...
#          Field 3   item3      item3       ...
#
#  The arguments are:
#
#       items:       a co-expression that produces a sequence of
#                    items (usually structured data objects, but not
#                    necessarily) for which data is to be printed.
#
#       fields:      a list of procedures to produce the field's
#                    data.  Each procedure takes two arguments.  The
#                    procedure's action depends upon what is passed
#                    in the first argument:
#
#            header      Produces the row heading string to be used
#                        for that field (the field name).
#
#            width       Produces the maximum field width that can
#                        be produced (including the column header).
#
#            Other      Produces the field value string for the
#                        item passed as the argument.
#
#          The second argument is arbitrary data from the procedures
#       with each invocation.  The data returned by the first func-
#       tion on the list is used as a column heading string (the
#       item name).
#
#       title:       optional.
#
#
#       pagelength:  if null (omitted) page breaks are ignored.
#
#       linelength:  default 80.
#
#       auxdata:     auxiliary arbitrary data to be passed to the field
#                    procedures -- see `fields', above.
#
############################################################################

procedure printcol(items,fields,title,pagelength,linelength,auxdata)
  local maxwidth,maxhead,groups,columns,itemlist,cont,f,p,underline,
    hfield
  /linelength := 80
  /pagelength := 30000
  /title := ""
#
#  Compute the maximum field width (so we know the column spacing) and
#  the maximum header width (so we know how much space to leave on the
#  left for headings.
#
  maxwidth := maxhead := -1
  cont := ""
  every maxwidth <:= (!fields)("width",auxdata)
  hfield := get(fields)
  every maxhead <:= *(!fields)("header",auxdata)
  columns := (linelength - maxhead) / (maxwidth + 1)
  groups := pagelength / (6 + *fields)
#
#  Loop to print groups of data.
#
  repeat {
    if pagelength < 30000 then writes("\f")
#
#  Loop to print data of a group (a page's worth).
#
    every 1 to groups do {
#
#  Collect the items to be output in this group.  A group is the number
#  of columns that can fit across the page.
#
      itemlist := []
      every 1 to columns do put(itemlist,@items) | break
      if *itemlist = 0 then break break
#
#  Print a title and the column headings.
#
      write(repl("=",*write("\n",title || cont)))
      cont := " (continued)"
      writes(underline := left("",maxhead))
      every f := hfield(!itemlist,auxdata) do {
    p := if *f < maxwidth then center else left
    writes(" ",p(f,maxwidth))
    underline ||:= " " || p(repl("-",*f),maxwidth)
      }
      write("\n",underline)
#
#  Print the fields.
#
      every f := !fields do {
    writes(right(f("header",auxdata),maxhead))
    every writes(" ",center(f(!itemlist,auxdata),maxwidth))
    write()
      }
    }    # End of loop to print groups.
  }    # End of loop to print all items.
  return
end
##########
printf.icn
############################################################################
#
#    Name:    printf.icn
#
#    Title:    Printf-style formatting
#
#    Author:    William H. Mitchell
#
#    Date:    June 10, 1988
#
############################################################################
#
#     This procedure behaves somewhat like the standard printf.
#  Supports d, s, o, and x formats like printf.  An "r" format
#  prints real numbers in a manner similar to that of printf's "f",
#  but will produce a result in an exponential format if the number
#  is larger than the largest integer plus one.
#
#     Left or right justification and field width control are pro-
#  vided as in printf.  %s and %r handle precision specifications.
#
#     The %r format is quite a bit of a hack, but it meets the
#  author's requirements for accuracy and speed.  Code contributions
#  for %f, %e, and %g formats that work like printf are welcome.
#
#     Possible new formats:
#
#          %t -- print a real number as a time in hh:mm
#          %R -- roman numerals
#          %w -- integers in english
#          %b -- binary
#
#
############################################################################

procedure sprintf(format, a, b, c, d, e, f, g, h)
   local args

    args := [a,b,c,d,e,f,g,h]
    return _doprnt(format, args)
end

procedure fprintf(file, format, a, b, c, d, e, f, g, h)
   local args

    args := [a,b,c,d,e,f,g,h]
    writes(file, _doprnt(format, args))
    return
end

procedure printf(format, a, b, c, d, e, f, g, h)
   local args

    args := [a,b,c,d,e,f,g,h]
    writes(&output, _doprnt(format, args))
    return
end

procedure _doprnt(format, args)
   local out, v, just, width, conv, prec, pad

    out := ""
    format ? repeat {
        (out ||:= tab(upto('%'))) | (out ||:= tab(0) & break)
        v := get(args)
        move(1)
        just := right
        width := conv := prec := pad := &null
        ="-" & just := left
        width := tab(many(&digits))
        (\width)[1] == "0" & pad := "0"
        ="." & prec := tab(many(&digits))
        conv := move(1)
        #write("just: ",image(just),", width: ", width, ", prec: ",
        # prec, ", conv: ", conv)
        case conv of {
            "d": {
                v := string(v)
            }
            "s": {
                v := string(v[1:(\prec+1)|0])
            }
            "x": v := hexstr(v)
            "o": v := octstr(v)
            "i": v := image(v)
            "r": v := fixnum(v,prec)
            default: {
                push(args, v)
                v := conv
            }
            }
        if \width & *v < width then {
            v := just(v, width, pad)
            }
        out ||:= v
        }

    return out
end

procedure hexstr(n)
   local h, neg
   static BigNeg, hexdigs, hexfix

    initial {
        BigNeg := -2147483647-1
        hexdigs := "0123456789abcdef"
        hexfix := "89abcdef"
        }

    n := integer(n)
    if n = BigNeg then
        return "80000000"
    h := ""
    if n < 0 then {
        n := -(BigNeg - n)
        neg := 1
        }
    repeat {
        h := hexdigs[n%16+1]||h
        if (n /:= 16) = 0 then
            break
        }
    if \neg then {
        h := right(h,8,"0")
        h[1] := hexfix[h[1]+1]
        }
    return h
end
procedure octstr(n)
   local h, neg
   static BigNeg, octdigs, octfix

    initial {
        BigNeg := -2147483647-1
        octdigs := "01234567"
        octfix := "23"
        }

    n := integer(n)
    if n = BigNeg then
        return "20000000000"
    h := ""
    if n < 0 then {
        n := -(BigNeg - n)
        neg := 1
        }
    repeat {
        h := octdigs[n%8+1]||h
        if (n /:= 8) = 0 then
            break
        }
    if \neg then {
        h := right(h,11,"0")
        h[1] := octfix[h[1]+1]
        }
    return h
end

procedure fixnum(x, prec)
   local int, frac, f1, f2, p10

    /prec := 6
    int := integer(x) | return image(x)
    frac := image(x - int)
    if find("e", frac) then {
        frac ?:= {
            f1 := tab(upto('.')) &
            move(1) &
            f2 := tab(upto('e')) &
            move(1) &
            p10 := -integer(tab(0)) &
            repl("0",p10-1) || f1 || f2
            }
        }
    else
        frac ?:= (tab(upto('.')) & move(1) & tab(0))
    frac := left(frac, prec, "0")
    return int || "." || frac
end
##########
radcon.icn
############################################################################
#
#    Name:    radcon.icn
#
#    Title:    Radix conversion
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#  The following procedures convert numbers from one radix to
#  another. The letters from a to z are used for ``digits'' greater
#  than 9. All the conversion procedures fail if the conversion can-
#  not be made.
#
#       exbase10(i,j)  convert base-10 integer i to base j
#
#       inbase10(s,i)  convert base-i integer s to base 10
#
#       radcon(s,i,j)  convert base-i integer s to base j
#
#  Limitation:
#
#     The maximum base allowed is 36.
#
############################################################################

procedure exbase10(i,j)
   static digits
   local s, d, sign
   initial digits := &digits || &lcase
   if i = 0 then return 0
   if i < 0 then {
      sign := "-"
      i := -i
      }
   else sign := ""
   s := ""
   while i > 0 do {
      d := i % j
      if d > 9 then d := digits[d + 1]
      s := d || s
      i /:= j
      }
   return sign || s
end

procedure inbase10(s,i)
   if s[1] == "-" then return "-" || integer(i || "r" || s[2:0])
   else return integer(i || "r" || s)
end

procedure radcon(s,i,j)
   return exbase10(inbase10(s,i),j)
end
##########
rational.icn
############################################################################
#
#    Name:    rational.icn
#
#    Title:    Perform arithmetic on rational numbers
#
#    Author:    Ralph E. Griswold
#
#    Date:    May 11, 1989
#
############################################################################
#
#     These procedures perform arithmetic on rational numbers (fractions):
#
#     str2rst(s)    Convert the string representation of a rational number
#                   (such as "3/2") to a rational number.
#
#     rat2str(r)    Convert the rational number r to its string
#                   representation.
#
#     addrat(r1,r2) Add rational numbers r1 and r2.
#
#     subrat(r1,r2) Subtract rational numbers r1 and r2.
#
#     mpyrat(r1,r2) Multiply rational numbers r1 and r2.
#
#     divrat(r1,r2) Divide rational numbers r1 and r2.
#
#     negrat(r)     Produce negative of rational number r.
#
#     reciprat(r)   Produce the reciprocal of rational number r.
#
############################################################################
#
#  Links: gcd
#
############################################################################

link gcd

record rational(numer,denom,sign)

procedure str2rat(s)
   local div, numer, denom, sign

   s ? {
      ="[" &
      numer := integer(tab(upto('/'))) &
      move(1) &
      denom := integer(tab(upto(']'))) &
      pos(-1)
      } | fail
   div := gcd(numer,denom) | fail
   numer /:= div
   denom /:= div
   if numer * denom >= 0 then sign := 1    # dangerous -- potential overflow
      else sign := -1
   return rational(abs(numer),abs(denom),sign)
end

procedure rat2str(r)
   return "[" || r.numer * r.sign || "/" || r.denom || "]"
end

procedure mpyrat(r1,r2)
   local numer, denom, div

   numer := r1.numer * r2.numer
   denom := r1.denom * r2.denom
   div := gcd(numer,denom) | fail    # shouldn't fail
   return rational(numer / div,denom / div, r1.sign * r2.sign)
end

procedure divrat(r1,r2)
   return mpyrat(r1,reciprat(r2))    # may fail
end

procedure reciprat(r)
   if r.numer = 0 then fail
   else return rational(r.denom,r.numer,r.sign)
end

procedure negrat(r)
   return rational(r.numer,r.denom,-r.sign)
end

procedure addrat(r1,r2)
   local denom, numer, div, sign

   denom := r1.denom * r2.denom
   numer := r1.sign * r1.numer * r2.denom +
      r2.sign * r2.numer * r1.denom
   if numer >= 0 then sign := 1
      else sign := -1
   div := gcd(numer,denom) | fail
   return rational(abs(numer / div),abs(denom / div),sign)
end

procedure subrat(r1,r2)
   return addrat(r1,negrat(r2))
end
##########
segment.icn
############################################################################
#
#    Name:    segment.icn
#
#    Title:    Segment string
#
#    Author:    William H. Mitchell
#
#    Date:    June 10, 1988
#
############################################################################
#
#     These procedures segment a string s into consecutive substrings
#  consisting of characters that respectively do/do not occur in c.
#  segment(s,c) generates the substrings, while seglist produces a list
#  of the segments.  For example,
#
#          segment("Not a sentence.",&lcase ++ &ucase)
#
#  generates
#
#          "Not"
#          " "
#          "a"
#          " "
#          "sentence"
#          "."
#  while
#          seglist("Not a sentence.",&lcase ++ &ucase)
#
#  produces
#
#          ["Not"," ","a","sentence","."]
#
############################################################################

procedure segment(line,dlms)
   local ndlms

   dlms := (any(dlms,line[1]) & ~dlms)
   ndlms := ~dlms
   line ? repeat {
      suspend tab(many(ndlms)) \ 1
      suspend tab(many(dlms)) \ 1
      pos(0) & break
      }
end

procedure seglist(s,c)
   local a

   a := []
   c := (any(c,s[1]) & ~c)
   s ? while put(a,tab(many(c := ~c)))
   return a
end
##########
seqimage.icn
############################################################################
#
#    Name:    seqimage.icn
#
#    Title:    Produce string image of Icon result sequence
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#     The procedure Seqimage{e,i,j} produces a string image of the
#  result sequence for the expression e. The first i results are
#  printed. If i is omitted, there is no limit. If there are more
#  than i results for e, ellipses are provided in the image after
#  the first i.  If j is specified, at most j results from the end
#  of the sequence are printed after the ellipses.  If j is omitted,
#  only the first i results are produced.
#
#     For example, the expressions
#
#     Seqimage{1 to 12}
#     Seqimage{1 to 12,10}
#     Seqimage{1 to 12,6,3}
#
#  produce, respectively,
#
#     {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}
#     {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, ...}
#     {1, 2, 3, 4, 5, 6, ..., 10, 11, 12}
#
#
#  Warning:
#
#     If j is not omitted and e has a infinite result
#  sequence, Seqimage does not terminate.
#
############################################################################

procedure Seqimage(a)
   local seq, result, i, j, resid

   seq := ""
   i := @a[2]
   j := @a[3]
   while result := image(@a[1]) do
      if *a[1] > \i then {
         if /j then {
            seq ||:= ", ..."
            break
            }
         else {
            resid := [", " || result]
            every put(resid,", " || image(|@a[1]))
            if *resid > j then seq ||:= ", ..."
            every seq ||:= resid[*resid -j + 1 to *resid]
            }
         }
      else seq ||:= ", " || result
   return "{" || seq[3:0] || "}" | "{}"
end
##########
shquote.icn
############################################################################
#
#    Name:    shquote.icn
#
#    Title:    Quote word for shells
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  cshquote(s) -- Produces a version of s which is properly quoted
#  for the c-shell (csh).
#

procedure cshquote(s)
   local quotechar,q
   quotechar := '\t\n $"#&\'()*;<>?[\\`|~'
   if not upto(quotechar,s) then return s
   q := ""
   s ? {
      while q ||:= tab(upto('\'\n')) ||
        case move(1) of {
           "'": "'\\''"
           "\n": "\\\n"
           }
      q ||:= tab(0)
      }
   return "'" || q || "'"
end

#
#  shquote(s) -- Produces a version of s which is properly quoted
#  for the Bourne shell (sh).
#

procedure shquote(s)
   local quotechar,q
   quotechar := '\t\n\r $"#&\'()*;<>?\\^`|'
   if not upto(quotechar,s) then return s
   q := ""
   s ? {
      while q ||:= tab(upto('\'')) ||
        case move(1) of {
           "'": "'\\''"
           }
      q ||:= tab(0)
      }
   return "'" || q || "'"
end

#
#  mpwquote(s) -- Produces a version of s which is properly quoted
#  for the Macintosh Programmer's Workshop shell (MPW Shell).
#

procedure mpwquote(s)
   local quotechar,q
   quotechar := ' \t\n\r\0#;&|()k\'"/\\{}`?w[]+*./r<>r.d'
   if not upto(quotechar,s) then return s
   q := ""
   s ? {
      while (q ||:= tab(upto('\'')) || "'k''") & move(1)
      q ||:= tab(0)
      }
   return "'" || q || "'"
end
##########
shuffle.icn
############################################################################
#
#    Name:    shuffle.icn
#
#    Title:    Shuffle values
#
#    Author:    Ward Cunningham
#
#    Date:    June 10, 1988
#
############################################################################
#
#     The procedure shuffle(x) shuffles a string or list. In the case
#  that x is a string, a corresponding string with the characters
#  randomly rearranged is produced. In the case that x is a list,
#  the values in the list are randomly rearranged.
#
############################################################################

procedure shuffle(x)
   x := string(x)
   every !x :=: ?x
   return x
end
##########
snapshot.icn
############################################################################
#
#    Name:    snapshot.icn
#
#    Title:    Show snapshot of Icon string scanning
#
#    Author:    Ralph E. Griswold and Randal L. Schwartz
#
#    Date:    June 10, 1988
#
############################################################################
#
#     The procedure snapshot() writes a snapshot of the state of string
#  scanning, showing the value of &subject and &pos. For example,
#
#     "((a+b)-delta)/(c*d))" ? {
#        tab(bal('+-/*'))
#        snapshot()
#        }
#
#  produces
#
#       -------------------------------------
#       |                                   |
#       | &subject = "((a+b)-delta)/(c*d))" |
#       |                          |        |
#       -------------------------------------
#
#     Note that the bar showing the &pos is positioned under the &posth
#  character (actual positions are between characters).  If &pos is
#  at the end of &subject, the bar is positioned under the quotation
#  mark delimiting the subject. For example,
#
#     "abcdefgh" ? (tab(0) & snapshot())
#
#  produces
#
#       -------------------------
#       |                       |
#       | &subject = "abcdefgh" |
#       |                     | |
#       -------------------------
#
#     Escape sequences are handled properly. For example,
#
#     "abc\tdef\nghi" ? (tab(upto('\n')) & snapshot())
#
#  produces
#
#       ------------------------------
#       |                            |
#       | &subject = "abc\tdef\nghi" |
#       |                     |      |
#       ------------------------------
#
############################################################################

procedure snapshot()
   local bar, bar2, is, is0, prefix

   prefix := "&subject = "
   is := image(&subject)
   is0 := *image(&subject[1:&pos]) | fail # quick exit if bogus

   write(bar := repl("-", *is + *prefix + 4)) # 4 = two vbars/two spaces
   write(bar2 := ("|" || repl(" ", *is + *prefix + 2) || "|"))
   write("| ", prefix, is, " |")
   bar2[*prefix + is0 + 2] := "|" # 2 = "| " prefix
   write(bar2)
   write(bar)
   return ""
end
##########
strings.icn
############################################################################
#
#    Name:    strings.icn
#
#    Title:    String utilities
#
#    Author:    Ralph E. Griswold
#
#    Date:    May 26, 1989
#
############################################################################
#
#  These procedures perform simple operations on strings.
#
#       compress(s,c)      Compress consecutive occurrences of charac-
#                          ters in c that occur in s.
#
#       omit(s,c)          Omit all occurrences of characters in c
#                          that occur in s.
#
#       replace(s1,s2,s3)  In s1, replace all occurrences of s2 by s3.
#
#       rotate(s,i)        Rotate s i characters to the left (negative i
#                          produces rotation to the right); the default
#                          value of i is 1.
#
############################################################################

procedure compress(s,c)
   local result, s1

   result := ""

   s ? {
      while result ||:= tab(upto(c)) do {
         result ||:= (s1 := move(1))
         tab(many(s1))
         }
      return result || tab(0)
      }
end

#  omit characters
#
procedure omit(s,c)
   local result, s1

   result := ""

   s ? {
      while result ||:= tab(upto(c)) do {
         s1 := move(1)
         tab(many(s1))
         }
      return result || tab(0)
      }
end

#  replace string
#
procedure replace(s1,s2,s3)
   local result, i

   result := ""
   i := *s2

   s1 ? {
      while result ||:= tab(find(s2)) do {
         result ||:= s3
         move(i)
         }
      return result || tab(0)
      }
end

#  rotate string
#
procedure rotate(s,i)
   /i := 1
   if i <= 0 then i +:= *s
   i %:= *s
   return s[i + 1:0] || s[1:i + 1]
end
##########
structs.icn
############################################################################
#
#    Name:    structs.icn
#
#    Title:    Structure operations
#
#    Author:    Ralph E. Griswold
#
#    Date:    June 10, 1988
#
############################################################################
#
#     These procedures manipulate structures.
#
#       depth(t)    compute maximum depth of tree t
#
#       eq(x,y)     compare list structures x and y
#
#       teq(t1,t2)  compare trees t1 and t2
#
#       equiv(s,y)  compare arbitrary structures x and y
#
#       ldag(s)     construct a dag from the string s
#
#       ltree(s)    construct a tree from the string s
#
#       stree(t)    construct a string from the tree t
#
#       tcopy(t)    copy tree t
#
#       visit(t)  visit, in preorder, the nodes of the tree t
#
#     The procedure equiv() tests for the "equivalence" of two values. For types
#  other than structures, it does the same thing as x1 === x2.  For structures,
#  the test is for "shape".  For example,
#
#    equiv([],[])
#
#  succeeds.
#
#     It handles loops, but does not recognize them as such.  For example,
#  given
#
#    L1 := []
#    L2 := []
#    put(L1,L1)
#    put(L2,L1)
#
#    equiv(L1,L2)
#
#  succeeds.
#
#     The concept of equivalence for tables and sets is not quite right
#  if their elements are themselves structures.  The problem is that there
#  is no concept of order for tables and sets, yet it is impractical to
#  test for equivalence of their elements without imposing an order.  Since
#  structures sort by "age", there may be a mismatch between equivalent
#  structures in two tables or sets.
#
#  Note:
#     The procedures equiv and ldag have a trailing argument that is used on
#  internal recursive calls; a second argument must not be supplied
#  by the user.
#
############################################################################

procedure eq(x,y)
   local i
   if x === y then return y
   if type(x) == type(y) == "list" then {
      if *x ~= *y then fail
      every i := 1 to *x do
         if not eq(x[i],y[i]) then fail
      return y
     }
end

procedure depth(ltree)
   local count
   count := 0
   every count <:= 1 + depth(ltree[2 to *ltree])
   return count
end

procedure ldag(stree,done)
   local a
   /done := table()
   if a := \done[stree] then return a
   stree ?
      if a := [tab(upto('('))] then {
         move(1)
         while put(a,ldag(tab(bal(',)')),done)) do
            move(1)
         }
      else a := [tab(0)]
   return done[stree] := a
end

procedure ltree(stree)
   local a
   stree ?
      if a := [tab(upto('('))] then {
         move(1)
         while put(a,ltree(tab(bal(',)')))) do
            move(1)
         }
      else a := [tab(0)]
   return a
end

procedure stree(ltree)
   local s
   if *ltree = 1 then return ltree[1]
   s := ltree[1] || "("
   every s ||:= stree(ltree[2 to *ltree]) || ","
   return s[1:-1] || ")"
end

procedure tcopy(ltree)
   local a
   a := [ltree[1]]
   every put(a,tcopy(ltree[2 to *ltree]))
   return a
end

procedure teq(a1,a2)
   local i
   if *a1 ~= *a2 then fail
   if a1[1] ~== a2[1] then fail
   every i := 2 to *a1 do
      if not teq(a1[i],a2[i]) then fail
   return a2
end

procedure visit(ltree)
   suspend ltree | visit(ltree[2 to *ltree])
end

#

procedure equiv(x1,x2,done)
   local code, i

   if x1 === x2 then return x2        # Covers everything but structures.

   if type(x1) ~== type(x2) then fail    # Must be same type.

   if type(x1) == ("procedure" | "file")
      then fail                # Leave only those with sizes (null
                    # taken care of by first two tests).

   if *x1 ~= *x2 then fail        # Skip a lot of possibly useless work.

                    # Structures (and others) remain.

   /done := table()            # Basic call.

   (/done[x1] := set()) |        # Make set of equivalences if new.
      (if member(done[x1],x2) then return x2)

                    # Records complicate things.
   image(x1) ? (code := (="record" | type(x1)))

   case code of {
      "list" | "record":
         every i := 1 to *x1 do
            if not equiv(x1[i],x2[i],done) then fail
      "table": if not equiv(sort(x1,3),sort(x2,3),done) then fail
      "set":   if not equiv(sort(x1),sort(x2),done) then fail
      default: fail            # Vaues of other types are different.
      }

   insert(done[x1],x2)            # Equivalent; add to set.
   return x2

end
##########
usage.icn
############################################################################
#
#    Name:    usage.icn
#
#    Title:    Service procedures
#
#    Author:    Ralph E. Griswold
#
#    Date:    May 11, 1989
#
############################################################################
#
#     These procedures provide various common services:
#
#     Usage(s)          stops executions with a message concerning the
#                       expected form of usage of a program.
#
#     ErrorCheck(l,f)    reports an error that has been converted to
#                       failure.
#
#     Feature(s)        succeeds if feature s is available in the running
#                       implementation of Icon.
#
#     Requires(s)    terminates execution is feature s is not available.
#
#     Signature()    writes the version, host, and features support in
#                       the running implementation of Icon.
#
############################################################################

procedure Usage(s)
   stop("Usage: ",s)
end

procedure ErrorCheck(line,file)
   if &errortext == "" then fail    # No converted error
   write("\nError ",&errornumber," at line ",line, " in file ",file)
   write(&errortext)
   write("offending value: ",image(&errorvalue))
   return
end

procedure Feature(s)
   if s == &features then return else fail
end

procedure Requires(s)
   if not(Feature(s)) then stop(s," required")
end

procedure Signature()
   write(&version)
   write(&host)
   every write(&features)
end
##########
wildcard.icn
############################################################################
#
#    Name:    wildcard.icn
#
#    Title:    UNIX-like Wild Card Pattern Matching Function
#
#    Author:    Robert J. Alexander
#
#    Date:    November 27, 1989
#
############################################################################
#
#  wildcard(s1,s2,i,j) -- Generates the sequence of integer positions in
#  string s2 after strings which satisfy pattern s1 in s2[i:j], but fails
#  if there is no such position.  s1 is a UNIX-like wild-card pattern
#  containing *, ?, and [...].
#

link allof

global wild_element

procedure wildcard(p,s,i,j)
   local plist,c,e,complement,chars
   if /s := &subject then /i := &pos else /i := 1 ; /j := 0
   #
   #  Create a list of pattern elements.  The list looks like:
   #
   #     * --> "*"
   #     ? --> "?"
   #     [abc] --> 'abc'
   #     abc --> "abc"
   #
   plist := []
   p ? {
      while not pos(0) do {
     c := &null
     #
     #  Put pattern element character(s) on list.
     #
     e := =("*" | "?") |
           (="[" & c := tab(find("]")) & move(1)) |
           tab(upto('*?[') | 0)
     #
     #  If it's [abc], create a cset.  Special notations:
     #
     #       A-Z means all characters from A to Z inclusive.
     #       ! (if first) means any character not among those specified.
     #       - (if first, or after initial !) means itself.
     #
     \c ? {
        complement := if match("!") then move(1) else &null
        e := cset(if match("-") then move(1) else "")
        while chars := tab(find("-")) do {
           move(1)
           e ++:= chars[1:-1] ++
                 &cset[ord(chars[-1]) + 1:ord(move(1)) + 2]
           }
        e ++:= tab(0)
        if \complement then e := ~e
        }
     put(plist,e)
     }
      }
   #
   #  Do the pattern match.
   #
   suspend s[i:j] ? (
      allof {wild_element := !plist, case wild_element of {
        "*": move(0 to (*&subject - &pos + 1))
        "?": move(1)
        default: {
           case type(wild_element) of {
          "cset": tab(any(wild_element))
          default: =(wild_element)
          }
           }
        }
     } & i + &pos - 1)
end
##########
wrap.icn
############################################################################
#
#    Name:    wrap.icn
#
#    Title:    Wrap lines of output for use with write()
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  wrap(s,i) -- Facilitates accumulation of small strings into longer
#       output strings, outputting when the accumulated string would
#       exceed a specified length (e.g. outputting items in multiple
#       columns).
#
#       s -- string to accumulate
#       i -- width of desired output string
#
#  Wrap fails if the string s did not necessitate output of the buffered
#  output string; otherwise the output string is returned (which never
#  includes s).
#
#  s defaults to the empty string (""), causing nothing to be
#  accumulated; i defaults to 0, forcing output of any buffered string.
#  Note that calling wrap() with no arguments produces the buffer (if it
#  is not empty) and clears it.
#
#  Wrap does no output to files.
#
#
#  Here's how wrap is normally used:
#
#       wrap()                  # Initialize (not really necessary unless
#                               # a previous use might have left stuff in
#                               # the buffer).
#
#       every i := 1 to 100 do  # Loop to process strings to output --
#         write(wrap(x[i],80))  # only writes when 80-char line filled.
#
#       write(wrap())           # Output what's in buffer -- only outputs
#                               # if something to write.
#

procedure wrap(s,i)
   local t
   static line
   initial line := ""
   /s := "" ; /i := 0
   if *(t := line || s) > i then
     return "" ~== (s :=: line)
   line := t
end

#
#  wraps(s,i) -- Facilitates managing output of numerous small strings
#       so that they do not exceed a reasonable line length (e.g.
#       outputting items in multiple columns).
#
#       s -- string to accumulate
#       i -- maximum width of desired output string
#
#  If the string "s" did not necessitate a line-wrap, the string "s" is
#  returned.  If a line-wrap is needed, "s", preceded by a new-line
#  character ("\n"), is returned.
#
#  "s" defaults to the empty string (""), causing nothing to be
#  accumulated; i defaults to 0, forcing a new line if anything had been
#  output on the current line.  Thus calling wraps() with no arguments
#  reinitializes it.
#
#  Wraps does no output to files.
#
#
#  Here's how wraps is normally used:
#
#       wraps()                 # Initialize (not really necessary unless
#                               # a previous use might have left it in an
#                               # unknown condition).
#
#       every i := 1 to 100 do  # Loop to process strings to output --
#         writes(wraps(x[i],80))# only wraps when 80-char line filled.
#
#       writes(wraps())         # Only outputs "\n" if something written
#                               # on last line.
#

procedure wraps(s,i)
   local t
   static size
   initial size := 0
   /s := "" ; /i := 0
   t := size + *s
   if t > i & size > 0 then {
      size := *s
      return "\n" || s
      }
   size := t
   return s
end
##########
ximage.icn
############################################################################
#
#    Name:    ximage.icn
#
#    Title:    Produces "executable" image of structured data
#
#    Author:    Robert J. Alexander
#
#    Date:    December 5, 1989
#
############################################################################
#
#  ximage() -- enhanced image()-type procedure that outputs all data
#  contained in structured types.  It is called as follows:
#
#       ximage(x)
#
#  just like image(x) (the other arguments in the "procedure"
#  declaration are used for passing data among recursive levels).  The
#  output has an "executable" appearance, which will look familiar to
#  any Icon programmer.  The returned string for complex data contains
#  newline characters and indentation, suitable for write()-ing,
#  providing a pleasing and useful visual representation of the
#  structures.
#


procedure ximage(x,indent,done)
   local i,s,ss,state,t,xtag
   static tag,tr
   #
   #  If this is the outer invocation, do some initialization.
   #
   if /(state := done) then {
      tr := &trace ; &trace := 0    # postpone tracing while in here
      indent := ""
      tag := 0
      done := table()
      }
   #
   #  Determine the type and process accordingly.
   #
   indent := (if indent == "" then "\n" else "") || indent || "   "
   ss := ""
   t := type(x)
   s := if xtag := \done[x] then xtag else case t of {
      #
      #  Unstructured types just return their image().
      #
      "null" | "string" | "integer" | "real" | "cset" |
        "co-expression" | "file" | "procedure" | "external": image(x)
      #
      #  List.
      #
      "list": {
     done[x] := xtag := "L" || (tag +:= 1)
     #
     #  Figure out if there is a predominance of any object in the
     #  list.  If so, make it the default object.
     #
     t := table(0)
     every t[!x] +:= 1
     s := [,0]
     every t := !sort(t) do if s[2] < t[2] then s := t
     if s[2] > *x / 3 & s[2] > 2 then {
        s := s[1]
        t := ximage(s,indent || "   ",done)
        if t ? (not any('\'"') & ss := tab(find(" :="))) then
          t := "{" || t || indent || "   " || ss || "}"
        }
     else t := &null
     #
     #  Output the non-defaulted elements of the list.
     #
     ss := ""
     every i := 1 to *x do if x[i] ~=== s then {
        ss ||:= indent || xtag || "[" || i || "] := " ||
          ximage(x[i],indent,done)
        }
     s := image(x)
     s[-1:-1] := "," || \t
     xtag || " := " || s || ss
     }
      #
      #  Set.
      #
      "set": {
     done[x] := xtag := "S" || (tag +:= 1)
     every i := !sort(x) do {
        ss ||:= indent || "insert(" || xtag || "," ||
          ximage(i,indent,done,) || ")"
        }
     xtag || " := " || "set([])" || ss
     }
      #
      #  Table.
      #
      "table": {
     done[x] := xtag := "T" || (tag +:= 1)
     #
     #  Output the table elements.  This is a bit tricky, since
     #  the subscripts might be structured, too.
     #
     every i := !sort(x) do {
        t := ximage(i[1],indent || "   ",done)
        if t ? (not any('\'"') & s := tab(find(" :="))) then
          t := "{" || t || indent || "   " || s || "}"
        ss ||:= indent || xtag || "[" ||
          t || "] := " ||
          ximage(i[2],indent,done)
        }
     #
     #  Output the table, including its default value (which might
     #  also be structured.
     #
     t := ximage(x[[]],indent || "   ",done)
     if t ? (not any('\'"') & s := tab(find(" :="))) then
           t := "{" || t || indent || "   " || s || "}"
     xtag || " := " || "table(" || t || ")" || ss
     }
      #
      #  Record.
      #
      default: {
     done[x] := xtag := "R" || (tag +:= 1)
     every i := 1 to *x do {
        ss ||:= indent || xtag || "[" || i || "] := " ||
          ximage(\x[i],indent,done)
        }
     xtag || " := " || t || "()" || ss
     }
      }
   #
   #  If this is the outer invocation, clean up before returning.
   #
   if /state then {
      &trace := tr                        # restore &trace
      }
   #
   #  Return the result.
   #
   return s
end