home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
ICONPL8.ZIP
/
PROGS.PAK
< prev
next >
Wrap
Text File
|
1990-03-23
|
295KB
|
10,634 lines
##########
animal.icn
############################################################################
#
# Name: animal.icn
#
# Title: Animal game
#
# Author: Robert J. Alexander
#
# Date: June 10, 1988
#
############################################################################
#
# This is the familiar ``animal game'' written in Icon. The
# program asks its human opponent questions in an attempt to guess
# what animal he is thinking of. It is an ``expert system'' that
# starts out with limited knowledge, but gets smarter as it plays
# and learns from its opponents. At the conclusion of a session,
# the program asks permission to remember for future sessions that
# which it learned.
#
# The game is not limited to guessing animals only. By simply
# modifying the first two lines of procedure "main" it will happily
# guess things in other categories. For example, the lines:
#
# GameObject := "president"
# Tree := Question("Has he ever been known as Bonzo",
# "Reagan","Lincoln")
#
# can be substituted and it works reasonably well. The knowledge
# files will be kept separate, too.
#
# Typing list at any yes/no prompt will show an inventory of
# animals known, and there are some other commands (see procedure
# Confirm).
#
############################################################################
global GameObject,Tree,ShowLine,Learn
record Question(question,yes,no)
procedure main()
GameObject := "animal"
Tree := Question("Does it live in water","goldfish","canary")
Get() # Recall prior knowledge
Game() # Play a game
return
end
procedure Game()
while Confirm("Are you thinking of ",Article(GameObject)," ",
GameObject) do {
Ask(Tree)
}
write("Thanks for a great game.")
if \Learn &
Confirm("Want to save knowledge learned this session") then Save()
return
end
procedure Confirm(q1,q2,q3,q4,q5,q6)
local answer,s
static ok
initial {
ok := table()
ok["y"] := ok["yes"] := ok["yeah"] := ok["uh huh"] := "yes"
ok["n"] := ok["no"] := ok["nope"] := ok["uh uh"] := "no"
}
while /answer do {
write(q1,q2,q3,q4,q5,q6,"?")
case s := read() | exit(1) of {
"save": Save()
"get": Get()
"list": List()
"dump": Output(Tree,&output)
default: {
(answer := \ok[map(s,&ucase,&lcase)]) |
write("This is a \"yes\" or \"no\" question.")
}
}
}
return answer == "yes"
end
procedure Ask(node)
local guess,question
case type(node) of {
"string": {
if not Confirm("It must be ",Article(node)," ",node,", right") then {
Learn := "yes"
write("What were you thinking of?")
guess := read() | exit(1)
write("What question would distinguish ",Article(guess)," ",
guess," from ",Article(node)," ",node,"?")
question := read() | exit(1)
if question[-1] == "?" then question[-1] := ""
question[1] := map(question[1],&lcase,&ucase)
if Confirm("For ",Article(guess)," ",guess,", what would the _
answer be") then {
return Question(question,guess,node)
}
else {
return Question(question,node,guess)
}
}
}
"Question": {
if Confirm(node.question) then {
node.yes := Ask(node.yes)
}
else {
node.no := Ask(node.no)
}
}
}
end
procedure Article(word)
return if any('aeiouAEIOU',word) then "an" else "a"
end
procedure Save()
local f
f := open(GameObject || "s","w")
Output(Tree,f)
close(f)
return
end
procedure Output(node,f,sense)
static indent
initial indent := 0
/sense := " "
case type(node) of {
"string": write(f,repl(" ",indent),sense,"A: ",node)
"Question": {
write(f,repl(" ",indent),sense,"Q: ", node.question)
indent +:= 1
Output(node.yes,f,"y")
Output(node.no,f,"n")
indent -:= 1
}
}
return
end
procedure Get()
local f
f := open(GameObject || "s","r") | fail
Tree := Input(f)
close(f)
return
end
procedure Input(f)
local nodetype,s
read(f) ? (tab(upto(~' \t')) & =("y" | "n" | "") &
nodetype := move(1) & move(2) & s := tab(0))
if nodetype == "Q" then {
return Question(s,Input(f),Input(f))
}
else {
return s
}
end
procedure List()
ShowLine := ""
Show(Tree)
write(trim(ShowLine))
return
end
procedure Show(node)
if type(node) == "Question" then {
Show(node.yes)
Show(node.no)
}
else {
if *ShowLine + *node > 78 then {
write(trim(ShowLine))
ShowLine := ""
}
ShowLine ||:= node || " "
}
return
end
##########
calc.icn
############################################################################
#
# Name: calc.icn
#
# Title: Desk calculator
#
# Author: Ralph E. Griswold
#
# Date: February 22, 1990
#
############################################################################
#
# This is a simple Polish "desk calculator". It accepts as values Icon
# integers, reals, csets, and strings (as they would appear in an Icon
# program). Other lines of input are interpreted as operations. These
# may be Icon operators, functions, or the special instructions listed
# below.
#
# In the case of operator symbols, such as +, that correspond to both unary
# and binary operations, the binary one is used. Thus, the unary operation
# is not available.
#
# In case of Icon functions like write() that take an arbitrary number of
# arguments, one argument is used.
#
# The special instructions are:
#
# clear remove all values from the calculator's stack
# dump write out the contents of the stack
# print print the top value on the stack, but do not remove it
# quit exit the calculator
#
# Example: the input lines
#
# "abc"
# 3
# repl
# print
#
# prints "abcabcabc" and leaves this the only value on the stack.
#
# Failure and most errors are detected, but in these case, arguments are
# consumed and not restored to the stack.
#
############################################################################
global stack
procedure main()
local line, p, n, arglist
stack := []
while line := read() do {
push(stack,value(line)) | { # if it's a value, push it
case line of { # else check special operations
"clear": {stack := []; next}
"dump": {every write(image(!stack)); next}
"print": {write(image(stack[1])); next}
"quit": exit()
}
if p := proc(line,3 | 2 | 1) then { # check for procedure
n := abs(args(p))
arglist := []
every 1 to n do
push(arglist,pop(stack)) | {
write(&errout,"*** not enough arguments ***")
break next
}
&error := 1 # anticipate possible error
push(stack,p!arglist) | {
if &error = 0 then {
write(&errout,"*** error performing ",line)
}
else write(&errout,"*** failure performing ",line)
}
}
else write(&errout,"*** invalid input: ",line)
}
}
end
# Check input to see if it's a value
#
procedure value(s)
local n
if n := numeric(s) then return n
else {
s ? {
if ="\"" & s := tab(-1) & ="\"" then return escape(s)
else if ="'" & s := tab(-1) & ="'" then return cset(escape(s))
else fail
}
}
end
# Handling escape sequences is no fun
#
procedure escape(s)
local ns, c
ns := ""
s ? {
while ns ||:= tab(upto('\\')) do {
move(1)
ns ||:= case c := map(move(1 | 0)) of { # can be either case
"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)
if s > 377 then { # back off if too large
s := s[1:3]
move(-1)
}
return char("8r" || s)
end
procedure ctrlcode(s)
return char(upto(map(move(1)),&lcase))
end
##########
colm.icn
############################################################################
#
# Name: colm.icn
#
# Title: Arrange data into columns
#
# Author: Robert J. Alexander
#
# Date: December 5, 1989
#
############################################################################
#
# Colm -- Arrange data into columns.
#
# Program to arrange a number of data items, one per line, into
# multiple columns. Items are arranged in column-wise order, that is,
# the sequence runs down the first column, then down the second, etc.
#
# If a null line appears in the input stream, it signifies a break in
# the list, and the following line is taken as a title for the
# following data items. No title precedes the initial sequence of
# items.
#
# Usage:
#
# colm [-w line_width] [-s space_between] [-m min_width]
# [-t tab_width] [-x] [-d] [file ...]
#
# The parameters are:
#
# line_width: the maximum width allowed for output lines
# (default: 80).
# space_between: minimum number of spaces between items
# (default: 2).
# min_width: minimum width to be printed for each entry
# (default: no minimum).
# tab_width: tab width used to entab output lines.
# (default: no tabs).
# -x print items in row-wise order rather than
# column-wise.
# -d (distribute) distribute columns throughout available width.
#
# The command "colm -h" generates "help" text.
#
# This is a general utility, but it was written and tailored for a
# specific purpose:
#
# This utility was written to rearrange the file name list from the
# Macintosh Programmer's Workshop "Files" command into a more
# convenient format. "Files" lists file names in a single column.
# This program takes the list produced by "Files" and outputs a
# multi-column list. The names are listed vertically within each
# column, and the column width is computed dynamically depending upon
# the sizes of the names listed. A recommendation is to create a
# command file "lc" (List in Columns) as follows:
#
# Files {"Parameters"} | colm
#
# The output from the Files command is "piped" to the "colm" program
# (this program), which prints its list in the current window.
#
# By putting both the "lc" command file and the "colm" program into
# your {MPW}Tools folder, "lc" can be conveniently issued as a command
# at any time, using the same parameters as the "Files" command.
link options, colmize
procedure main(arg)
local usage, help, opt, rowwise, distribute, maxcols, space, minwidth
local tabwidth, f, entries, entry
#
# Define usage and help strings.
#
usage := "_
Usage:\tcolm [-w line_width] [-s space_between] [-m min_width]\n_
\t\t[-t tab_width] [-x] [file ...]\n_
\tcolm -h for help"
help := "_
\tline_width:\tthe maximum width allowed for output lines\n_
\t\t\t(default: 80).\n_
\tspace_between:\tminimum number of spaces between items\n_
\t\t\t(default: 2).\n_
\tmin_width:\tminimum width to be printed for each entry\n_
\t\t\t(default: no minimum).\n_
\ttab_width:\ttab width used to print output lines.\n_
\t\t\t(default: no tabs).\n_
\t-x\t\tprint items in row-wise order rather than\n_
\t\t\tcolumn-wise.\n_
\t-d (distribute)\tdistribute columns throughout available width."
#
# Process command line options.
#
opt := options(arg,"hxdw+s+m+t+")
if \opt["h"] then write(usage,"\n\n",help) & exit()
rowwise := opt["x"]
distribute := opt["d"]
maxcols := \opt["w"] | 80
space := \opt["s"] | 2
minwidth := \opt["m"] | 0
tabwidth := (\opt["t"] | 0) + 1
if tabwidth = 1 then entab := 1
if *arg = 0 then arg := [&input]
#
# Loop to process input files.
#
while f := get(arg) do {
f := (&input === f) | open(f) | stop("Can't open ",f)
#
# Loop to process input groups (separated by empty lines).
#
repeat {
entries := []
#
# Loop to build a list of non-empty lines of an input file.
#
while entry := "" ~== read(f) do {
put(entries,entry)
}
#
# Now write the data in columns.
#
every write(entab(colmize(entries,maxcols,space,minwidth,
rowwise,distribute),tabwidth))
write("\n",read(f)) | break # print the title line, if any
}
close(f)
write()
}
end
##########
concord.icn
############################################################################
#
# Name: concord.icn
#
# Title: Produce concordance
#
# Author: Ralph E. Griswold
#
# Date: December 22, 1989
#
############################################################################
#
# This program produces a simple concordance from standard input to standard
# output. Words less than three characters long are ignored.
#
# There are two options:
#
# -l n set maximum line length to n (default 72), starts new line
# -w n set maximum width for word to n (default 15), truncates
#
# There are lots of possibilities for improving this program and adding
# functionality to it. For example, a list of words to be ignored could be
# provided. The formatting could be made more flexible, and so on.
#
############################################################################
#
# Note that the program is organized to make it easy (via item()) to
# handle other kinds of tabulations.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global uses, colmax, namewidth, lineno
procedure main(args)
local opts, uselist, name, line
opts := options(args, "l+w+") # process options
colmax := \opts["l"] | 72
namewidth := \opts["w"] | 15
uses := table("")
lineno := 0
every tabulate(item(), lineno) # tabulate all the citations
uselist := sort(uses, 3) # sort by uses
while name := get(uselist) do
format(left(name, namewidth) || get(uselist))
end
# Add line number to citations for name. If it already has been cited,
# add (or increment) the number of citations.
#
procedure tabulate(name, lineno)
local new, count, number
lineno := string(lineno)
new := ""
uses[name] ? {
while new ||:= tab(upto(&digits)) do {
number := tab(many(&digits))
new ||:= number
}
if /number | (number ~== lineno)
then uses[name] ||:= lineno || ", " # new line number
else {
if ="(" then count := tab(upto(')')) else count := 1
uses[name] := new || "(" || count + 1 || "), "
}
}
end
# Format the output, breaking long lines as necessary.
#
procedure format(line)
local i
while *line > colmax + 2 do {
i := colmax + 2
until line[i -:= 1] == " " # back off to break point
write(line[1:i])
line := repl(" ", namewidth) || line[i + 1:0]
}
write(line[1:-2])
end
# Get an item. Different kinds of concordances can be obtained by
# modifying this procedure.
#
procedure item()
local i, word, line
while line := read() do {
lineno +:= 1
write(right(lineno, 6), " ", line)
line := map(line) # fold to lowercase
i := 1
line ? {
while tab(upto(&letters)) do {
word := tab(many(&letters))
if *word >= 3 then suspend word # skip short words
}
}
}
end
##########
cross.icn
############################################################################
#
# Name: cross.icn
#
# Title: Display intersection of words
#
# Author: William P. Malloy
#
# Date: June 10, 1988
#
############################################################################
#
# This program takes a list of words and tries to arrange them
# in cross-word format so that they intersect. Uppercase letters
# are mapped into lowercase letters on input. For example, the
# input
#
# and
# eggplants
# elephants
# purple
#
# produces the output
# +---------+
# | p |
# | u e |
# | r g |
# | p g |
# |elephants|
# | e l |
# | and |
# | n |
# | t |
# | s |
# +---------+
#
# Diagnostics: The program objects if the input contains a nonal-
# phabetic character.
#
# Comments: This program produces only one possible intersection
# and it does not attempt to produce the most compact result. The
# program is not very fast, either. There is a lot of room for
# improvement here. In particular, it is natural for Icon to gen-
# erate a sequence of solutions.
#
############################################################################
global fast, place, array, csave, fsave, number
procedure main()
local words, nonletter, line
nonletter := ~&letters
words := []
while line := map(read()) do
if upto(nonletter,line) then stop("input contains nonletter")
else put(words,line)
number := *words
kross(words)
end
procedure kross(words)
local one, tst, t
array := [get(words)]
t := 0
while one := get(words) do {
tst := *words
if fit(one,array,0 | 1) then
t := 0
else {
t +:= 1
put(words,one)
if t > tst then
break
}
}
if *words = 0 then Print(array)
else write(&errout,"cannot construct puzzle")
end
procedure fit(word,matrix,where)
local i, j, k, l, one, test, t, s
s := *matrix
t := *matrix[1]
every k := gen(*word) do
every i := gen(s) do
every j := gen(t) do
if matrix[i][j] == word[k] then {
# test for vertical fit
if where = 0 then {
test := 0
every l := (i - k + 1) to (i + (*word - k)) do
if tstv(matrix,i,j,l,s,t) then {
test := 1
break
}
if test = 0 then
return putvert(matrix,word,i,j,k)
}
if where = 1 then {
test := 0
every l := (j - k + 1) to (j + (*word - k)) do
if tsth(matrix,i,j,l,s,t) then {
test := 1
break
}
if test = 0 then
return puthoriz(matrix,word,i,j,k)
}
}
end
procedure tstv(matrix,i,j,l,s,t)
return ((matrix[(l ~= i) & (s >= l) & (0 < l)][0 < j-1] ~== " ") |
(matrix[(l ~= i) & (s >= l) & (0 < l)][t >= j + 1] ~== " ") |
(matrix[(i ~= l-1) & (s >= l-1) & (0 < l-1)][j] ~== " ") |
(matrix[(i ~= l + 1) & (s >= l+1) & (0 < l + 1)][j] ~== " ") |
(matrix[(l ~= i) & (s >= l) & (0 < l)][j] ~== " "))
end
procedure tsth(matrix,i,j,l,s,t)
return ((matrix[0 < i-1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
(matrix[s >= i + 1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
(matrix[i][(j ~= l-1) & (t >= l-1) & (0 < l-1)] ~== " ") |
(matrix[i][(j ~= l + 1) & (t >= l + 1) & (0 < l + 1)] ~== " ") |
(matrix[i][(l ~= j) & (t >= l) & (0 < l)] ~== " "))
end
procedure gen(i)
local tmp, up, down
tmp := i / 2
if (i % 2) = 1 then
tmp +:= 1
suspend tmp
up := tmp
down := tmp
while (up < i) do {
suspend up +:= 1
suspend (down > 1) & (down -:= 1)
}
end
# put `word' in vertically at pos(i,j)
procedure putvert(matrix,word,i,j,k)
local hdim, vdim, up, down, l, m, n
vdim := *matrix
hdim := *matrix[1]
up := 0
down := 0
up := abs(0 > (i - k))
down := abs(0 > ((vdim - i) - (*word - k)))
every m := 1 to up do
push(matrix,repl(" ",hdim))
i +:= up
every m := 1 to down do
put(matrix,repl(" ",hdim))
every l := 1 to *word do
matrix[i + l - k][j] := word[l]
return matrix
end
# put `word' in horizontally at position i,j in matrix
procedure puthoriz(matrix,word,i,j,k)
local hdim, vdim, left, right, l, m, n
vdim := *matrix
hdim := *matrix[1]
left := 0
right := 0
left := (abs(0 > (j - k))) | 0
right := (abs(0 > ((hdim - j) - (*word - k)))) | 0
every m := 1 to left do
every l := 1 to vdim do
matrix[l] := " " || matrix[l]
j +:= left
every m := 1 to right do
every l := 1 to vdim do
matrix[l] ||:= " "
every l := 1 to *word do
matrix[i][j + l - k] := word[l]
return matrix
end
procedure Print(matrix)
local i
write("+",repl("-",*matrix[1]),"+")
every i := 1 to *matrix do
write("|",matrix[i],"|")
write("+",repl("-",*matrix[1]),"+")
end
##########
csgen.icn
############################################################################
#
# Name: csgen.icn
#
# Title: Generate instances of sentences from context-sensitive grammars
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program accepts a context-sensitive production grammar
# and generates randomly selected sentences from the corresponding
# language.
#
# Uppercase letters stand for nonterminal symbols and -> indi-
# cates the lefthand side can be rewritten by the righthand side.
# Other characters are considered to be terminal symbols. Lines
# beginning with # are considered to be comments and are ignored.
# A line consisting of a nonterminal symbol followed by a colon and
# a nonnegative integer i is a generation specification for i
# instances of sentences for the language defined by the nontermi-
# nal (goal) symbol. An example of input to csgen is:
#
# # a(n)b(n)c(n)
# # Salomaa, p. 11.
# # Attributed to M. Soittola.
# #
# X->abc
# X->aYbc
# Yb->bY
# Yc->Zbcc
# bZ->Zb
# aZ->aaY
# aZ->aa
# X:10
#
# The output of csgen for this example is
#
# aaabbbccc
# aaaaaaaaabbbbbbbbbccccccccc
# abc
# aabbcc
# aabbcc
# aaabbbccc
# aabbcc
# abc
# aaaabbbbcccc
# aaabbbccc
#
#
# A positive integer followed by a colon can be prefixed to a
# production to replicate that production, making its selection
# more likely. For example,
#
# 3:X->abc
#
# is equivalent to
#
# X->abc
# X->abc
# X->abc
#
# Option: The -t option writes a trace of the derivations to stan-
# dard error output.
#
# Limitations: Nonterminal symbols can only be represented by sin-
# gle uppercase letters, and there is no way to represent uppercase
# letters as terminal symbols.
#
# There can be only one generation specification and it must
# appear as the last line of input.
#
# Comments: Generation of context-sensitive strings is a slow pro-
# cess. It may not terminate, either because of a loop in the
# rewriting rules or because of the progressive accumulation of
# nonterminal symbols. The program avoids deadlock, in which there
# are no possible rewrites for a string in the derivation.
#
# This program would be improved if the specification of nonter-
# minal symbols were more general, as in rsg.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global xlist
procedure main(args)
local line, goal, count, s, opts, deadlock
opts := options(args,"x")
deadlock := \opts["x"]
while line := read() do # read in grammar
if line[1] == "#" then next
else if xpairs(line) then next
else {
line ? (goal := move(1),move(1),count := (0 < integer(tab(0))))
break
}
if /count then stop("no goal specification")
every 1 to count do { # generate sentences
s := goal
while upto(&ucase,s) do { # test for nonterminal
if \deadlock then write(&errout,s)
# quit on deadlock
if not(s ? replace(!xlist)) then break next
until s ?:= replace(?xlist) # make replacement
}
write(s)
}
end
# replace left hand side by right hand side
#
procedure replace(a)
suspend tab(find(a[1])) || (move(*a[1]),a[2]) || tab(0)
end
# enter rewriting rule
#
procedure xpairs(s)
local i, a
initial xlist := []
if s ? {
# handle optional replication factor
i := 1(0 < integer(tab(upto(':'))),move(1)) | 1 &
a := [tab(find("->")),(move(2),tab(0))]
}
then {
every 1 to i do put(xlist,a)
return
}
end
##########
deal.icn
############################################################################
#
# Name: deal.icn
#
# Title: Deal bridge hands
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program shuffles, deals, and displays hands in the game
# of bridge. An example of the output of deal is
# ---------------------------------
#
# S: KQ987
# H: 52
# D: T94
# C: T82
#
# S: 3 S: JT4
# H: T7 H: J9863
# D: AKQ762 D: J85
# C: QJ94 C: K7
#
# S: A652
# H: AKQ4
# D: 3
# C: A653
#
# ---------------------------------
#
# Options: The following options are available:
#
# -h n Produce n hands. The default is 1.
#
# -s n Set the seed for random generation to n. Different
# seeds give different hands. The default seed is 0.
#
############################################################################
#
# Links: options, shuffle
#
############################################################################
link options, shuffle
global deck, deckimage, handsize, suitsize, denom, rank, blanker
procedure main(args)
local hands, opts
deck := deckimage := string(&letters) # initialize global variables
handsize := suitsize := *deck / 4
rank := "AKQJT98765432"
blanker := repl(" ",suitsize)
denom := &lcase[1+:suitsize]
opts := options(args,"h+s+")
hands := \opts["h"] | 1
&random := \opts["s"]
every 1 to hands do
display()
end
# Display the hands
#
procedure display()
local layout, i
static bar, offset
initial {
bar := "\n" || repl("-",33)
offset := repl(" ",10)
}
deck := shuffle(deck)
layout := []
every push(layout,show(deck[(0 to 3) * handsize + 1 +: handsize]))
write()
every write(offset,!layout[1])
write()
every i := 1 to 4 do
write(left(layout[4][i],20),layout[2][i])
write()
every write(offset,!layout[3])
write(bar)
end
# Put the hands in a form to display
#
procedure show(hand)
static clubmap, diamondmap, heartmap, spademap
initial {
clubmap := denom || repl(blanker,3)
diamondmap := blanker || denom || repl(blanker,2)
heartmap := repl(blanker,2) || denom || blanker
spademap := repl(blanker,3) || denom
}
return [
"S: " || arrange(hand,spademap),
"H: " || arrange(hand,heartmap),
"D: " || arrange(hand,diamondmap),
"C: " || arrange(hand,clubmap)
]
end
# Arrange hands for presentation
#
procedure arrange(hand,suit)
return map(map(hand,deckimage,suit) -- ' ',denom,rank)
end
##########
delam.icn
############################################################################
#
# Name: delam.icn
#
# Title: Delaminate file
#
# Author: Thomas R. Hicks
#
# Date: June 10, 1988
#
############################################################################
#
# This program delaminates standard input into several output
# files according to the specified fields. It writes the fields in
# each line to the corresponding output files as individual lines.
# If no data occurs in the specified position for a given input
# line an empty output line is written. This insures that all out-
# put files contain the same number of lines as the input file.
#
# If - is used for the input file, the standard input is read.
# If - is used as an output file name, the corresponding field is
# written to the standard output.
#
# The fields are defined by a list of field specifications,
# separated by commas or colons, of the following form:
#
# n the character in column n
# n-m the characters in columns n through m
# n+m m characters beginning at column n
#
# where the columns in a line are numbered from 1 to the length of
# the line.
#
# The use of delam is illustrated by the following examples.
# The command
#
# delam 1-10,5 x.txt y.txt
#
# reads standard input and writes characters 1 through 10 to file
# x.txt and character 5 to file y.txt. The command
#
# delam 10+5:1-10:1-10:80 mid x1 x2 end
#
# writes characters 10 through 14 to mid, 1 through 10 to x1 and
# x2, and character 80 to end. The command
#
# delam 1-80,1-80 - -
#
# copies standard input to standard output, replicating the first
# eighty columns of each line twice.
#
############################################################################
#
# Links: usage
#
############################################################################
link usage
procedure main(a)
local fylist, ranges
if any(&digits,a[1]) then
ranges := fldecode(a[1])
else
{
write(&errout,"Bad argument to delam: ",a[1])
Usage("delam fieldlist {outputfile | -} ...")
}
if not a[2] then
Usage("delam fieldlist {outputfile | -} ...")
fylist := doutfyls(a,2)
if *fylist ~= *ranges then
stop("Unequal number of field args and output files")
delamr(ranges,fylist)
end
# delamr - do actual division of input file
#
procedure delamr(ranges,fylist)
local i, j, k, line
while line := read() do
{
i := 1
while i <= *fylist do
{
j := ranges[i][1]
k := ranges[i][2]
if k > 0 then
write(fylist[i][2],line[j+:k] | line[j:0] | "")
i +:= 1
}
}
end
# doutfyls - process the output file arguments; return list
#
procedure doutfyls(a,i)
local lst, x
lst := []
while \a[i] do
{
if x := llu(a[i],lst) then # already in list
lst |||:= [[a[i],lst[x][2]]]
else # not in list
if a[i] == "-" then # standard out
lst |||:= [[a[i],&output]]
else # new file
if not (x := open(a[i],"w")) then
stop("Cannot open ",a[i]," for output")
else
lst |||:= [[a[i],x]]
i +:= 1
}
return lst
end
# fldecode - decode the fieldlist argument
#
procedure fldecode(fldlst)
local fld, flst, poslst, m, n, x
poslst := []
flst := str2lst(fldlst,':,')
every fld := !flst do
{
if x := upto('-+',fld) then
{
if not (m := integer(fld[1:x])) then
stop("bad argument in field list; ",fld)
if not (n := integer(fld[x+1:0])) then
stop("bad argument in field list; ",fld)
if upto('-',fld) then
{
if n < m then
n := 0
else
n := (n - m) + 1
}
}
else {
if not (m := integer(fld)) then
stop("bad argument in field list; ",fld)
n := 1
}
poslst |||:= [[m,n]]
}
return poslst
end
# llu - lookup file name in output file list
#
procedure llu(str,lst)
local i
i := 1
while \lst[i] do
{
if \lst[i][1] == str then
return i
i +:= 1
}
end
# str2lst - create a list from a delimited string
#
procedure str2lst(str,delim)
local lst, f
lst := []
str ? {
while f := (tab(upto(delim))) do
{
lst |||:= [f]
move(1)
}
if "" ~== (f := tab(0)) then
lst |||:= [f]
}
return lst
end
##########
delamc.icn
############################################################################
#
# Name: delamc.icn
#
# Title: Delaminate file using tab characters
#
# Author: Thomas R. Hicks
#
# Date: May 28, 1989
#
############################################################################
#
# This program delaminates standard input into several output
# files according to the separator characters specified by the
# string following the -t option. It writes the fields in each
# line to the corresponding output files as individual lines. If no
# data occurs in the specified position for a given input line an
# empty output line is written. This insures that all output files
# contain the same number of lines as the input file.
#
# If - is used as an output file name, the corresponding field
# is written to the standard output. If the -t option is not used,
# an ascii horizontal tab character is assumed as the default field
# separator.
#
# The use of delamc is illustrated by the following examples.
# The command
#
# delamc labels opcodes operands
#
# writes the fields of standard input, each of which is separated
# by a tab character, to the output files labels, opcodes, and
# operands. The command
#
# delamc -t: scores names matric ps1 ps2 ps3
#
# writes the fields of standard input, each of which are separated
# by a colon, to the indicated output files. The command
#
# delamc -t,: oldata f1 f2
#
# separates the fields using either a comma or a colon.
#
############################################################################
#
# Links: usage
#
############################################################################
link usage
procedure main(a)
local tabset, fylist, nxtarg
if match("-t",a[1]) then { # tab char given
tabset := cset(a[1][3:0])
pop(a) # get rid of that argument
}
if 0 = *(fylist := doutfyls(a)) then
Usage("delamc [-tc] {outputfile | -} ...")
/tabset := cset(&ascii[10]) # tab is default separator
delamrc(tabset,fylist) # call main routine
end
# delamrc - do actual division of input file using tab chars
#
procedure delamrc(tabset,fylist)
local i, flen, line
while line := read() do
{
i := 1
flen := *fylist
line ? while (i <= flen) do
{
if i = flen then
write(fylist[i][2],tab(0) | "")
else
write(fylist[i][2],tab(upto(tabset)) | tab(0) | "")
move(1)
i +:= 1
}
}
end
# doutfyls - process output file arguments; return list
#
procedure doutfyls(a)
local lst, x, i
lst := []
i := 1
while \a[i] do {
if x := llu(a[i],lst) then # already in list
lst |||:= [[a[i],lst[x][2]]]
else # not in list
if a[i] == "-" then # standard out
lst |||:= [[a[i],&output]]
else # a new file
if not (x := open(a[i],"w")) then
stop("Cannot open ",a[i]," for output")
else lst |||:= [[a[i],x]]
i +:= 1
}
return lst
end
# llu - lookup file name in output file list
#
procedure llu(str,lst)
local i
i := 1
while \lst[i] do {
if \lst[i][1] == str then return i
i +:= 1
}
end
##########
diffn.icn
############################################################################
#
# Name: diffn.icn
#
# Title: Show differences files
#
# Author: Robert J. Alexander
#
# Date: May 15, 1989
#
############################################################################
#
# This program shows the differences between n files. Is is invoked as
#
# diffn file1 file2 ... filen
#
############################################################################
#
# Links: dif
#
############################################################################
link dif
global f1,f2
record dfile(file,linenbr)
procedure main(arg)
local f, i, files, drec, status
if *arg < 2 then stop("usage: diffn file file ...")
f := list(*arg)
every i := 1 to *arg do
f[i] := dfile(open(arg[i]) | stop("Can't open ",arg[i]),0)
files := list(*arg)
every i := 1 to *arg do {
write("File ",i,": ",arg[i])
files[i] := diff_proc(myread,f[i])
}
every drec := dif(files) do {
status := "diffs"
write("==================================")
every i := 1 to *drec do {
write("---- File ",i,", ",
(drec[i].pos > f[i].linenbr & "end of file") |
"line " || drec[i].pos,
" ---- (",arg[i],")")
listrange(drec[i].diffs,drec[i].pos)
}
}
if /status then write("==== Files match ====")
return
end
procedure listrange(dlist,linenbr)
local x
every x := !dlist do {
write(x); linenbr +:= 1
}
return
end
procedure myread(x)
return x.linenbr <- x.linenbr + 1 & read(x.file)
end
##########
diffword.icn
############################################################################
#
# Name: diffword.icn
#
# Title: List different words
#
# Author: Ralph E. Griswold
#
# Date: May 9, 1989
#
############################################################################
#
# This program lists all the different words in the input text.
# The definition of a "word" is naive.
#
############################################################################
procedure main()
local letter, words, text
letter := &letters
words := set()
while text := read() do
text ? while tab(upto(letter)) do
insert(words,tab(many(letter)))
every write(!sort(words))
end
##########
edscript.icn
############################################################################
#
# Name: edscript.icn
#
# Title: Produce script for the ed editor
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program takes specifications for global edits from standard
# input and outputs an edit script for the UNIX editor ed to standard output.
# Edscript is primarily useful for making complicated literal sub-
# stitutions that involve characters that have syntactic meaning to
# ed and hence are difficult to enter in ed.
#
# Each specification begins with a delimiter, followed by a tar-
# get string, followed by the delimiter, followed by the replace-
# ment string, followed by the delimiter. For example
#
# |...|**|
# |****||
#
# specifies the replacement of all occurrences of three consecutive
# periods by two asterisks, followed by the deletion of all
# occurrences of four consecutive asterisks. Any character may be
# used for the delimiter, but the same character must be used in
# all three positions in any specification, and the delimiter char-
# acter cannot be used in the target or replacement strings.
#
# Diagnostic:
#
# Any line that does not have proper delimiter structure is noted
# and does not contribute to the edit script.
#
# Reference:
#
# "A Tutorial Introduction to the UNIX Text Editor", Brian W. Kernighan.
# AT&T Bell Laboratories.
#
############################################################################
procedure main()
local line, image, object, char
while line := read() do {
line ? {
char := move(1) | {error(line); next}
image := tab(find(char)) | {error(line); next}
move(1)
object := tab(find(char)) | {error(line); next}
}
write("g/",xform(image),"/s//",xform(object),"/g")
}
write("w\nq")
end
# process characters that have meaning to ed
#
procedure insert()
static special
initial special := '\\/^&*[.$'
suspend {
tab(upto(special)) ||
"\\" ||
move(1) ||
(insert() | tab(0))
}
end
procedure error(line)
write(&errout,"*** erroneous input: ",line)
end
# transform line
#
procedure xform(line)
line ?:= insert()
return line
end
##########
empg.icn
############################################################################
#
# Name: empg.icn
#
# Title: Expression Measurement Program Generator
#
# Author: Ralph E. Griswold
#
# Date: March 8, 1990
#
############################################################################
#
# This program reads Icon expressions, one per line, and writes out
# and Icon program, which when run, times the expressions and reports
# average evaluation time and storage allocation.
#
# Lines beginning with a # are treated as comments and written to the
# output program so as to be written as comments when the output program is
# run.
#
# Lines beginning with a : are passed to the output program to be
# evaluated, but not timed.
#
# Lines beginning with a $ are included at the end of the output
# program as declarations.
#
# All other lines are timed in loops.
#
# An example of input is:
#
# :T := table(0)
# $record complex(r,i)
# T[1]
# complex(0.0,0.0)
#
# The resulting output program evaluates the expressions on the last two
# lines and reports their average time and storage allocation.
#
# Loop overhead for timing is computed first. The default number of
# iterations s 10000. A different number can be given on the command line
# when empg is executed, as in
#
# iconx empg 1000 <test.exp >test.icn
#
# which takes expressions from test.exp, computes loop overhead using 1000
# iterations, and writes the measurement program to test.icn.
#
# The default number of iterations for timing expressions is 1000. A
# different number can be given on the command line when the measurement
# program is run, as in
#
# icont test
# iconx test 5000
#
# which times the expressions in test.icn using 5000 iterations.
#
# If a garbage collection occurs during timing, the average time is
# likely to be significantly distorted and average allocation cannot be
# computed. In this case, the number of garbage collections is reported
# instead. To avoid misleading results as a consequence, measurement
# programs should be run with Icon's region sizes set to as large values
# as possible. To avoid residual effects of one timed expression on
# another, expressions that allocate significant amounts of storage
# should be measured in separate programs.
#
# The number of iterations used to compute loop overhead im empg
# and the number of iterations used to time expressions in measurement
# programs should be chosen so that the effects of low clock resolution
# are minimized. In particular, systems with very fast CPUs but
# low clock resolution (like 386 and 486 processors running under
# MS-DOS) need large values.
#
############################################################################
#
# Links: numbers (in measurement programs, not in empg.icn)
#
############################################################################
procedure main(argl)
local i, decls, line, input
i := integer(argl[1]) | 10000
decls := [] # list for declarations
write("link numbers")
write("global _Count, _Coll, _Store, _Overhead, _Names")
write("procedure main(argl)")
write(" _Iter := argl[1] | 1000")
write(" _Names := [\"static\",\"string\",\"block \"]")
write(" write(\"iterations: \",_Iter)")
write(" write(\"&version: \",&version)")
write(" write(\"&host: \",&host)")
write(" write(\"&dateline: \",&dateline)")
write(" write(\"region sizes: \")")
write(" _I := 1")
write(" every _S := ®ions do {")
write(" write(\" \",_Names[_I],\" \",_S)")
write(" _I +:= 1")
write(" }")
write(" _Count := ",i)
write(" _Itime := &time")
write(" every 1 to _Count do { &null }")
write(" _Overhead := real(&time - _Itime) / _Count")
write(" _Itime := &time")
write(" every 1 to _Count do { &null & &null }")
write(" _Overhead := real(&time - _Itime) / _Count - _Overhead")
write(" _Count := _Iter")
while line := read(input) do
case line[1] of {
":": { # evaluate but do not time
write(" ",line[2:0])
write(" write(",image(line[2:0]),")")
}
"$": { # line of declaration
put(decls,line[2:0])
write(" write(",image(line[2:0]),")")
}
"#": # comment
write(" write(",image(line),")")
default: { # time in a loop
write(" write(",image(line),")")
write(" _Prologue()")
write(" _Itime := &time")
write(" every 1 to _Count do {")
write(" &null & ", line)
write(" }")
write(" _Epilogue(&time - _Itime)")
}
}
write("end")
write("procedure _Prologue()")
write(" _Store := []")
write(" _Coll := []")
write(" collect()")
write(" every put(_Store,&storage)")
write(" every put(_Coll,&collections)")
write("end")
write("procedure _Epilogue(_Time)")
write(" every put(_Store,&storage)")
write(" every put(_Coll,&collections)")
write(" write(fix(real(_Time) / _Count - _Overhead,1,8),\" ms.\")")
write(" if _Coll[1] = _Coll[5] then {")
write(" write(\"average allocation:\",)")
write(" every _I := 1 to 3 do")
write(" write(\" \",_Names[_I],fix(real(_Store[_I + 3] - _Store[_I]),_Count,12))")
write(" }")
write(" else {")
write(" write(\"garbage collections:\")")
write(" write(\" total \",right(_Coll[5] - _Coll[1],4))")
write(" every _I := 6 to 8 do write(\" \",_Names[_I - 5],right(_Coll[_I] - _Coll[_I - 4],4))")
write(" }")
write(" write()")
write("end")
every write(!decls) # write out declarations
end
##########
farb.icn
############################################################################
#
# Name: farb.icn
#
# Title: Generate Farberisms
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# Dave Farber, co-author of the original SNOBOL programming
# language, is noted for his creative use of the English language.
# Hence the terms ``farberisms'' and ``to farberate''. This pro-
# gram produces a randomly selected farberism.
#
# Notes: Not all of the farberisms contained in this program were
# uttered by the master himself; others have learned to emulate
# him. A few of the farberisms may be objectionable to some per-
# sons. ``I wouldn't marry her with a twenty-foot pole.''
#
############################################################################
#
# Program note:
#
# This program is organized into several procedures to avoid oveflowing
# the default table sizes in the Icon translator and linker.
#
############################################################################
procedure main(arg)
local count
&random := map(&clock,":","0")
count := integer(arg[1]) | 1
every write(|??[farb1(),farb2(),farb3(),farb4()]) \ count
end
procedure farb1()
return [
"I enjoy his smiling continence.",
"Picasso wasn't born in a day.",
"I'll be there with spades on.",
"Beware a Trojan bearing a horse.",
"A hand in the bush is worth two anywhere else.",
"All the lemmings are going home to roost.",
"Anybody who marries her would stand out like a sore thumb.",
"Before they made him they broke the mold.",
"He's casting a red herring on the face of the water.",
"Clean up or fly right.",
"Come down off your charlie horse.",
"Don't burn your bridges until you come to them.",
"Don't count your chickens until the barn door is closed.",
"Don't do anything I wouldn't do standing up in a hammock.",
"Don't get your eye out of joint.",
"Don't just stand there like a sitting duck.",
"Don't look a mixed bag in the mouth.",
"Don't look at me in that tone of voice.",
"Don't make a molehill out of a can of beans.",
"Don't make a tempest out of a teapot."
]
end
procedure farb2()
return [
"Don't upset the apple pie.",
"Every cloud has a blue horizon.",
"She's faster than the naked eye.",
"Feather your den with somebody else's nest.",
"From here on up, it's down hill all the way.",
"Go fly your little red wagon somewhere else.",
"Half a worm is better than none.",
"He doesn't know which side his head is buttered on.",
"He has feet of molasses.",
"He hit the nose right on the head.",
"He knows which side his pocketbook is buttered on.",
"He smokes like a fish.",
"He was hoisted by a skyhook on his own petard!",
"He was putrified with fright.",
"He would forget his head if it weren't screwed up.",
"He's as happy as a pig at high tide.",
"He's been living off his laurels for years.",
"He's got a rat's nest by the tail.",
"He's got four sheets in the wind.",
"He's letting ground grow under his feet.",
"He's lying through his britches.",
"He's procrastinating like a bandit.",
"He's reached the crescent of his success.",
"He's so far above me I can't reach his bootstraps.",
"He's too smart for his own bootstraps.",
"His foot is in his mouth up to his ear.",
"History is just a repetition of the past.",
"I apologize on cringed knees.",
"I don't know which dagger to clothe it in.",
"I hear the handwriting on the wall.",
"I wouldn't marry her with a twenty-foot pole.",
"I'll procrastinate when I get around to it.",
"I'm going to throw myself into the teeth of the gamut.",
"I'm parked somewhere in the boondoggles."
]
end
procedure farb3()
return [
"I'm walking on cloud nine.",
"I've got to put my duff to the grindstone.",
"I've had it up to the hilt.",
"If Calvin Coolidge were alive today, he'd turn over in his grave.",
"If the onus fits, wear it.",
"Is he an Amazon!",
"It fills a well-needed gap.",
"It is better to have tried and failed than never to have failed at all.",
"It looks like it's going to go on ad infinitum for a while.",
"It sounds like roses to my ears.",
"It's a caterpillar in pig's clothing.",
"It's a fiat accompli.",
"It's a fool's paradise wrapped in sheep's clothing.",
"It's a monkey wrench in your ointment.",
"It's a new high in lows.",
"It's bouncing like a greased pig.",
"It's enough to make you want to rot your socks.",
"It's like talking to a needle in a haystack.",
"It's like trying to light a fire under a lead camel.",
"It's not his bag of tea.",
"It's so unbelieveable you wouldn't believe it.",
"Just because it's there, you don't have to mount it.",
"Keep your ear peeled!",
"Let's not drag any more dead herrings across the garden path.",
"Let's skin another can of worms.",
"Look at the camera and say `bird'.",
"Look before you turn the other cheek.",
"Men, women, and children first!",
"Necessity is the mother of strange bedfellows.",
"Never feed a hungry dog an empty loaf of bread.",
"No rocks grow on Charlie.",
"No sooner said, the better.",
"Nobody could fill his socks.",
"Nobody is going to give you the world in a saucer.",
"Nobody marches with the same drummer.",
"Not by the foggiest stretch of the imagination!",
"Not in a cocked hat, you don't!",
"People in glass houses shouldn't call the kettle black.",
"Put it on the back of the stove and let it simper."
]
end
procedure farb4()
return [
"Put the onus on the other foot.",
"Rome wasn't built on good intentions alone.",
"She has eyes like two holes in a burnt blanket.",
"She's a virgin who has never been defoliated.",
"She's trying to feather her own bush.",
"Somebody's flubbing his dub.",
"It's steel wool and a yard wide.",
"Straighten up or fly right.",
"Strange bedfellows flock together.",
"That's a bird of a different color.",
"That's a horse of a different feather.",
"That's a sight for deaf ears.",
"That's the way the old ball game bounces.",
"The die has been cast on the face of the waters.",
"The early bird will find his can of worms.",
"The foot that rocks the cradle is usually in the mouth.",
"The onus is on the other foot.",
"The whole thing is a hairy potpourri.",
"There are enough cooks in the pot already.",
"There's a dark cloud on every rainbow's horizon.",
"There's a flaw in the ointment.",
"There's going to be hell and high water to pay.",
"They don't stand a teabag's chance in hell.",
"They sure dipsied his doodle.",
"This ivory tower we're living in is a glass house.",
"Time and tide strike but once."
]
end
##########
fileprnt.icn
############################################################################
#
# Name: fileprnt.icn
#
# Title: Display representations of characters in file
#
# Author: Ralph E. Griswold
#
# Date: November 21, 1989
#
############################################################################
#
# This program reads the file specified as a command-line argument and
# writes out a representation of each character in several forms:
# hexadecimal, octal, decimal, symbolic, and ASCII code.
#
# Inpupt is from a named file rather than standard input, so that it
# can be opened in untranslated mode. Otherwise, on some systems, input
# is terminated for characters like ^Z.
#
# Since this program is comparatively slow, it is not suitable
# for processing very large files.
#
# There are several useful extensions that could be added to this program,
# including other character representations, an option to skip an initial
# portion of the input file, and suppression of long ranges of identical
# characters.
#
############################################################################
#
# Requires: co-expressions
#
############################################################################
#
# Program note:
#
# This program illustrates a situation in which co-expressions can be
# used to considerably simplify programming. Try recasting it without
# co-expressions.
#
############################################################################
procedure main(arg)
local width, chars, nonprint, prntc, asc, hex, sym, dec
local oct, ascgen, hexgen, octgen, chrgen, prtgen, c
local cnt, line, length, bar, input
input := open(arg[1],"u") | stop("*** cannot open input file")
width := 16
chars := string(&cset)
nonprint := chars[1:33] || chars[128:0]
prntc := map(chars,nonprint,repl(" ",*nonprint))
asc := table(" |")
hex := table()
sym := table()
dec := table()
oct := table()
ascgen := create "NUL" | "SOH" | "STX" | "ETX" | "EOT" | "ENQ" | "ACK" |
"BEL" | " BS" | " HT" | " LF" | " VT" | " FF" | " CR" | " SO" | " SI" |
"DLE" | "DC1" | "DC2" | "DC3" | "DC4" | "NAK" | "SYN" | "ETB" | "CAN" |
" EM" | "SUB" | "ESC" | " FS" | " GS" | " RS" | " US" | " SP"
hexgen := create !"0123456789ABCDEF" || !"0123456789ABCDEF"
octgen := create (0 to 3) || (0 to 7) || (0 to 7)
chrgen := create !chars
prtgen := create !prntc
every c := !&cset do {
asc[c] := @ascgen || "|"
oct[c] := @octgen || "|"
hex[c] := " " || @hexgen || "|"
sym[c] := " " || @prtgen || " |"
}
asc[char(127)] := "DEL|" # special case
cnt := -1 # to handle zero-indexing of byte count
while line := reads(input,width) do { # read one line's worth
length := *line # may not have gotten that many
bar := "\n" || repl("-",5 + length * 4)
write()
writes("BYTE|")
every writes(right(cnt + (1 to length),3),"|")
write(bar)
writes(" HEX|")
every writes(hex[!line])
write(bar)
writes(" OCT|")
every writes(oct[!line])
write(bar)
writes(" DEC|")
every writes(right(ord(!line),3),"|")
write(bar)
writes(" SYM|")
every writes(sym[!line])
write(bar)
writes(" ASC|")
every writes(asc[!line])
write(bar)
cnt +:= length
}
end
##########
filter.icn
############################################################################
#
# Name: filter.icn
#
# Title: Generic filter skeleton in Icon
#
# Author: Robert J. Alexander
#
# Date: December 5, 1989
#
############################################################################
#
# Generic filter skeleton in Icon.
#
# This program is not intended to be used as is -- it serves as a
# starting point for creation of filter programs. Command line
# options, file names, and tabbing are handled by the skeleton. You
# need only provide the filtering code.
#
# As it stands, filter.icn simply copies the input file(s) to
# standard output.
#
# Multiple files can be specified as arguments, and will be processed
# in sequence. A file name of "-" represents the standard input file.
# If there are no arguments, standard input is processed.
#
############################################################################
#
# Links: options
#
############################################################################
link options
procedure main(arg)
local opt, tabs, Detab, fn, f, line
#
# Process command line options and file names.
#
opt := options(arg,"t+") # e.g. "fs:i+r." (flag, string, integer, real)
if *arg = 0 then arg := ["-"] # if no arguments, standard input
tabs := (\opt["t"] | 8) + 1 # tabs default to 8
Detab := tabs = 1 | detab # if -t 0, no detabbing
#
# Loop to process files.
#
every fn := !arg do {
f := if fn == "-" then &input else
open(fn) | stop("Can't open input file \"",fn,"\"")
#
# Loop to process lines of file (in string scanning mode).
#
while line := Detab(read(f)) do line ? {
write(line) # copy line to standard output
}
#
# Close this file.
#
close(f)
}
#
# End of program.
#
end
##########
format.icn
############################################################################
#
# Name: format.icn
#
# Title: Filter to word wrap a range of text
#
# Author: Robert J. Alexander
#
# Date: December 5, 1989
#
############################################################################
#
# Filter to word wrap a range of text.
#
# A number of options are available, including full justification (see
# usage text, below). All lines that have the same indentation as the
# first line (or same comment leading character format if -c option)
# are wrapped. Other lines are left as is.
#
# This program is useful in conjunction with editors that can invoke
# filters on a range of selected text.
#
# The -c option attemps to establish the form of a comment based on the
# first line, then does its best to deal properly with the following
# lines. The types of comment lines that are handled are those in
# which each line starts with a "comment" character string (possibly
# preceded by spaces). While formatting comment lines, text lines
# following the prototype line that don't match the prototype but are
# flush with the left margin are also formatted as comments. This
# feature simplifies initially entering lengthy comments or making
# major modifications, since new text can be entered without concern
# for comment formatting, which will be done automatically later.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global width
procedure main(arg)
local usage, opts, tabs, comment, format, just1, space, nspace, wchar
local line, pre, empty, outline, spaces, word, len
#
# Process the options.
#
usage :=
"usage: ifmt [-n] [-w N] [-t N]\n_
\t-w N\tspecify line width (default 72)\n_
\t-t N\tspecify tab width (default 8)\n_
\t-j\tfully justify lines\n_
\t-J\tfully justify last line\n_
\t-c\tattemp to format program comments\n_
\t-h\tprint help message"
opts := options(arg,"ht+w+cjJ")
if \opts["h"] then stop(usage)
width := \opts["w"] | 72
tabs := \opts["t"] | 8
comment := opts["c"]
format := if \opts["j"] then justify else 1
just1 := opts["J"]
#
# Initialize variables.
#
space := ' \t'
nspace := ~space
wchar := nspace
#
# Read the first line to establish a prototype of comment format
# if -c option, or of leading spaces if normal formatting.
#
line := ((tabs >= 2,detab) | 1)(read(),tabs) | exit()
line ?
pre := (tab(many(space)) | "") ||
if \comment then
tab(many(nspace)) || tab(many(space)) |
stop("### Can't establish comment pattern")
else
""
width -:= *pre
empty := trim(pre)
outline := spaces := ""
repeat {
line ? {
#
# If this line indicates a formatting break...
#
if (=empty & pos(0)) | (=pre & any(space) | pos(0)) |
(/comment & not match(pre)) then {
write(pre,"" ~== outline)
outline := spaces := ""
write(line)
}
#
# Otherwise continue formatting.
#
else {
=pre
tab(0) ? {
tab(many(space))
while word := tab(many(wchar)) & (tab(many(space)) | "") do {
if *outline + *spaces + *word > width then {
write(pre,"" ~== format(outline))
outline := spaces := ""
}
outline ||:= spaces || word
spaces := if any('.:?!',word[-1]) then " " else " "
}
}
}
}
line := ((tabs >= 2,detab) | 1)(read(),tabs) | break
}
write(((tabs >= 2,entab) | 1)(pre,tabs),
"" ~== (if \just1 then justify else 1)(outline))
end
#
# justify() -- add spaces between words until the line length = "width".
#
procedure justify(s)
local min, spaces, len
while *s < width do {
min := 10000
s ? {
while tab(find(" ")) do {
len := *tab(many(' '))
if min >:= len then spaces := []
if len = min then put(spaces,&pos)
}
}
if /spaces then break
s[?spaces+:0] := " "
}
return s
end
##########
gcomp.icn
############################################################################
#
# Name: gcomp.icn
#
# Title: Produce complement of file specification
#
# Author: William H. Mitchell, modified by Ralph E. Griswold
#
# Date: December 27, 1989
#
############################################################################
#
# This program produces a list of the files in the current directory
# that do not appear among the arguments. For example,
#
# gcomp *.c
#
# produces a list of files in the current directory that do
# not end in .c. As another example, to remove all the files
# in the current directory that do not match Makefile, *.c, and *.h
# the following can be used:
#
# rm `gcomp Makefile *.c *.h`
#
# The files . and .. are not included in the output, but other
# `dot files' are.
#
############################################################################
procedure main(args)
local files
files := set()
read(open("echo * .*","rp")) ? while insert(files,tab(upto(' ') | 0)) do
move(1) | break
every delete(files,"." | ".." | !args)
every write(!sort(files))
end
##########
grpsort.icn
############################################################################
#
# Name: grpsort.icn
#
# Title: Sort groups of lines
#
# Author: Thomas R. Hicks
#
# Date: June 10, 1988
#
############################################################################
#
# This program sorts input containing ``records'' defined to be
# groups of consecutive lines. Output is written to standard out-
# put. Each input record is separated by one or more repetitions
# of a demarcation line (a line beginning with the separator
# string). The first line of each record is used as the key.
#
# If no separator string is specified on the command line, the
# default is the empty string. Because all input lines are trimmed
# of whitespace (blanks and tabs), empty lines are default demarca-
# tion lines. The separator string specified can be an initial sub-
# string of the string used to demarcate lines, in which case the
# resulting partition of the input file may be different from a
# partition created using the entire demarcation string.
#
# The -o option sorts the input file but does not produce the
# sorted records. Instead it lists the keys (in sorted order) and
# line numbers defining the extent of the record associated with
# each key.
#
# The use of grpsort is illustrated by the following examples.
# The command
#
# grpsort "catscats" <x >y
#
# sorts the file x, whose records are separated by lines containing
# the string "catscats", into the file y placing a single line of
# "catscats" between each output record. Similarly, the command
#
# grpsort "cats" <x >y
#
# sorts the file x as before but assumes that any line beginning
# with the string "cats" delimits a new record. This may or may not
# divide the lines of the input file into a number of records dif-
# ferent from the previous example. In any case, the output
# records will be separated by a single line of "cats". Another
# example is
#
# grpsort -o <bibliography >bibkeys
#
# which sorts the file bibliography and produces a sorted list of
# the keys and the extents of the associated records in bibkeys.
# Each output key line is of the form:
#
# [s-e] key
#
# where
#
# s is the line number of the key line
# e is the line number of the last line
# key is the actual key of the record
#
#
############################################################################
#
# Links: usage
#
############################################################################
link usage
global lcount, linelst, ordflag
procedure main(args)
local division, keytable, keylist, line, info, nexthdr, null
linelst := []
keytable := table()
lcount := 0
if *args = 2 then
if args[1] == "-o" then
ordflag := pop(args)
else
Usage("groupsort [-o] [separator string] <file >sortedfile")
if *args = 1 then {
if args[1] == "?" then
Usage("groupsort [-o] [separator string] <file >sortedfile")
if args[1] == "-o" then
ordflag := pop(args)
else
division := args[1]
}
if *args = 0 then
division := ""
nexthdr := lmany(division) | fail # find at least one record or quit
info := [nexthdr,[lcount]]
# gather all data lines for this group/record
while line := getline() do {
if eorec(division,line) then { # at end of this record
# enter record info into sort key table
put(info[2],lcount-1)
enter(info,keytable)
# look for header of next record
if nexthdr := lmany(division) then
info := [nexthdr,[lcount]] # begin next group/record
else
info := null
}
}
# enter last line info into sort key table
if \info then {
put(info[2],lcount)
enter(info,keytable)
}
keylist := sort(keytable,1) # sort by record headers
if \ordflag then
printord(keylist) # list sorted order of records
else
printrecs(keylist,division) # print records in order
end
# enter - enter the group info into the sort key table
procedure enter(info,tbl)
if /tbl[info[1]] then # new key value
tbl[info[1]] := [info[2]]
else
put(tbl[info[1]],info[2]) # add occurrance info
end
# eorec - suceed if a delimiter string has been found, fail otherwise
procedure eorec(div,str)
if div == "" then # If delimiter string is empty,
if str == div then return # then make exact match
else
fail
if match(div,str) then return # Otherwise match initial string.
else
fail
end
# getline - get the next line (or fail), trim off trailing tabs and blanks.
procedure getline()
local line
static trimset
initial trimset := ' \t'
if line := trim(read(),trimset) then {
if /ordflag then # save only if going to print later
put(linelst,line)
lcount +:= 1
return line
}
end
# lmany - skip over many lines matching string div.
procedure lmany(div)
local line
while line := getline() do {
if eorec(div,line) then next #skip over multiple dividing lines
return line
}
end
# printord - print only the selection order of the records.
procedure printord(slist)
local x, y
every x := !slist do
every y := !x[2] do
write(y[1],"-",y[2],"\t",x[1])
end
# printrecs - write the records in sorted order, separated by div string.
procedure printrecs(slist,div)
local x, y, z
every x := !slist do
every y := !x[2] do {
every z := y[1] to y[2] do
write(linelst[z])
write(div)
}
end
##########
hufftab.icn
############################################################################
#
# Name: hufftab.icn
#
# Title: Comnpute state transitions for Huffman decoding.
#
# Author: Gregg M. Townsend
#
# Date: December 1, 1984
#
############################################################################
#
# Each input line should be a string of 0s & 1s followed by a value
# field. Output is a list of items in a form suitable for inclusion
# by a C program as initialization for an array. Each pair of items
# indicates the action to be taken on receipt of a 0 or 1 bit from the
# corresponding state; this is either a state number if more decoding
# is needed or the value field from the input if not. State 0 is the
# initial state; 0 is output only for undefined states. States are
# numbered by two to facilitate use of a one-dimensional array.
#
# sample input: corresponding output:
# 00 a /* 0 */ 2, c, a, 4, 0, b,
# 011 b
# 1 c [new line started every 10 entries]
#
# Interpretation:
# from state 0, input=0 => go to state 2, input=1 => return c
# from state 2, input=0 => return a, input=1 => go to state 4
# from state 4, input=0 => undefined, input=1 => return b
#
############################################################################
global curstate, sttab, line
procedure main()
local code, val, n
sttab := list()
put(sttab)
put(sttab)
while line := read() do {
line ? {
if ="#" | pos(0) then next
(code := tab(many('01'))) | (write(&errout,"bad: ",line) & next)
tab(many(' \t'))
val := tab(0)
}
curstate := 1
every bit(!code[1:-1])
curstate +:= code[-1]
if \sttab[curstate] then write(&errout,"dupl: ",line)
sttab[curstate] := val
}
write("/* generated by machine -- do not edit! */")
write()
writes("/* 0 */")
out(sttab[1])
every n := 2 to *sttab do {
if n % 10 = 1 then writes("\n/* ",n-1," */")
out(sttab[n])
}
write()
end
procedure bit (c)
curstate +:= c
if integer(sttab[curstate]) then {
curstate := sttab[curstate]
return
}
if type(sttab[curstate]) == "string" then write(&errout,"dupl: ",line)
curstate := sttab[curstate] := *sttab + 1
put(sttab)
put(sttab)
end
procedure out(v)
if type(v) == "integer"
then writes(right(v-1,6),",")
else writes(right(\v | "0",6),",")
end
##########
ilnkxref.icn
############################################################################
#
# Name: ilnkxref.icn
#
# Title: Icon "link" Cross Reference Utility
#
# Author: Robert J. Alexander
#
# Date: December 5, 1989
#
############################################################################
#
# Utility to create cross reference of library files used in Icon
# programs (i.e., those files named in "link" declarations).
#
# ilnkxref <icon source file>...
#
############################################################################
#
# Links: wrap
#
############################################################################
link wrap
procedure main(arg)
local p, spaces, sep, proctable, maxlib, maxfile, fn, f, i, root
local comma, line, libname, x, head, fill
#
# Initialize
#
if *arg = 0 then {
p := open("ls *.icn","rp")
while put(arg,read(p))
close(p)
}
spaces := ' \t'
sep := ' \t,'
proctable := table()
maxlib := maxfile := 0
#
# Gather information from files.
#
every fn := !arg do {
write(&errout,"File: ",fn)
f := open(fn) | stop("Can't open ",fn)
i := 0
every i := find("/",fn)
root := fn[1:find(".",fn,i + 1) | 0]
comma := &null
while line := read(f) do {
line ? {
tab(many(spaces))
if \comma | ="link " then {
write(&errout," ",line)
comma := &null
tab(many(spaces))
until pos(0) | match("#") do {
libname := tab(upto(sep) | 0)
put(\proctable[libname],root) | (proctable[libname] := [root])
maxlib <:= *libname
maxfile <:= *root
tab(many(spaces))
comma := &null
if comma := ="," then tab(many(spaces))
}
}
}
}
close(f)
}
#
# Print the cross reference table.
#
write()
every x := !sort(proctable) do {
head := left(x[1],maxlib + 3)
fill := repl(" ",*head)
every x := !sort(x[2]) do {
write(head,wrap(left(x,maxfile + 2),78)) & head := fill
}
write(head,wrap())
}
end
##########
ipp.icn
############################################################################
#
# Name: ipp.icn
#
# Title: Icon preprocessor
#
# Author: Robert C. Wieland
#
# Date: December 22, 1989
#
############################################################################
#
# Ipp is a preprocessor for the Icon language. Ipp has many operations and
# features that are unique to the Icon environment and should not be used as a
# generic preprocessor (such as m4). Ipp produces output which when written to
# a file is designed to be the source for icont, the command processor for Icon
# programs.
#
# Ipp may be invoked from the command line as:
#
# ipp [option ...] [ifile [ofile]]
#
# Two file names may be specified as arguments. 'ifile' and 'ofile' are
# respectively the input and output files for the preprocessor. By default
# these are standard input and standard output. If the output file is to be
# specified while the input file should remain standard input a dash ('-')
# should be given as 'ifile'. For example, 'ipp - test' makes test the output
# file while retaining standard input as the input file.
#
# The following special names are predefined by ipp and may not be redefined
# or undefined. The name _LINE_ is defined as the line number (as an
# integer) of the line of the source file currently processed. The
# name _FILE_ is defined as the name of the current source file (as a string).
# If the source is standard input then it has the value 'stdin'.
#
# Also predefined are names corresponding to the features supported by the
# implementation of Icon at the location the preprocessor is run. This allows
# conditional translations using the 'if' commands, depending on what features
# are available. Given below is a list of the features on a 4.nbsd UNIX
# implementation and the corresponding predefined names:
#
# Feature Name
# -----------------------------------------------------
# UNIX UNIX
# co-expressions co_expressions
# overflow checking overflow_checking
# direct execution direct_execution
# environment variables environment_variables
# error traceback error_traceback
# executable images executable_images
# string invocation string_invocation
# expandable regions expandable_regions
#
#
# Command-Line Options:
# ---------------------
#
# The following options to ipp are recognized:
#
# -C By default ipp strips Icon-style comments. If this option
# is specified all comments are passed along except those
# found on ipp command lines (lines starting with a '$'
# command).
#
# -D name
# -D name=def Allows the user to define a name on the command line instead
# of using a $define command in a source file. In the first
# form the name is defined as '1'. In the second form name is
# defined as the text following the equal sign. This is less
# powerful than the $define command line since def can not
# contain any white space (spaces or tabs).
#
# -d depth By default ipp allows include files to be nested to a depth
# of ten. This allows the preprocessor to detect infinitely
# recursive include sequences. If a different limit for the
# nesting depth is needed it may changed by using this option
# with an integer argument greater than zero. Also, if a file
# is found to already be in a nested include sequence an
# error message is written regardless of the limit.
#
# -I dir The following algorithm is normally used in searching for
# $include files. Names enclosed in <> are always expected to
# in the /usr/icon/src directory. On a UNIX system names enclosed
# in "" are searched for by trying in order the directories
# specified by the PATH environment variable. On other systems
# only the current directory is searched. If the -I option is
# given the directory specified is searched before the 'standard'
# directories. If this option is specified more than once the
# directories specified are tried in the order that they appear
# on the command line, then followed by the 'standard'
# directories.
#
#
# Preprocessor commands:
# ----------------------
#
# All ipp commands start with lines beginning with a '$'. The name of the
# command must immediately follow the '$'. Any line beginning with a '$'
# and not followed by a valid name will cause an error message to be sent
# to standard error and termination of the preprocessor. If the command
# requires an argument then it must be separated from the command name by
# white space (any number of spaces or tabs) otherwise the argument will be
# considered part of the name and the result will likely produce an error.
# In processing the # commands ipp responds to exceptional conditions in one
# of two ways. It may produce a warning and continue processing or produce an
# error message and terminate. In both cases the message is sent to standard
# error. With the exception of error conditions encountered during the
# processing of the command line, the messages normally include the name and
# line number of the source file at the point the condition was
# encountered. Ipp was designed so that most exception conditions
# encountered will produce errors and terminate. This protects the user since
# warnings could simply be overlooked or misinterpreted.
#
# Many ipp command require names as arguments. Names must begin with a
# letter or an underscore, which may be followed by any number of letters,
# underscores, and digits. Icon-style comments may appear on ipp command
# lines, however they must be separated from the normal end of the command by
# white_space. If any extraneous characters appear on a command line a
# warning is issued. This occurs when characters other than white-space or a
# comment follow the normal end of a command.
#
# The following commands are implemented:
#
# $define: This command may be used in one of two forms. The first form
# only allows simple textual substitution. It would be invoked as
# '$define name text'. Subsequent occurrencegs of name are replaced
# with text. Name and text must be separated by one white space
# character which is not considered to be part of the replacement
# text. Normally the replacement text ends at the end of the line.
# The text however may be continued on the next line if the backslash
# character '\' is the last character on the line. If name occurs
# in the replacement text an error message (recursive textual substi-
# tution) is written.
#
# The second form is '$define name(arg,...,arg) text' which defines
# a macro with arguments. There may be no white space between the
# name and the '('. Each occurrenceg of arg in the replacement text
# is replaced by the formal arg specified when the macro is
# encountered. When a macro with arguments is expanded the arguments
# are placed into the expanded replacement text unchanged. After the
# entire replacement text is expanded, ipp restarts its scan for names
# to expand at the beginning of the newly formed replacement text.
# As with the first form above, the replacement text may be continued
# an following lines. The replacement text starts immediately after
# the ')'.
# The names of arguments must comply with the convention for regular
# names. See the section below on Macro processing for more
# information on the replacement process.
#
# $undef: Invoked as '$undef name'. Removes the definition of name. If
# name is not a valid name or if name is one of the reserved names
# _FILE_ or _LINE_ a message is issued.
#
# $include: Invoked as '$include <filename>' or '$include "filename"'. This
# causes the preprocessor to make filename the new source until
# end of file is reached upon which input is again taken from the
# original source. See the -I option above for more detail.
#
# $dump: This command, which has no arguments, causes the preprocessor to
# write to standard error all names which are currently defined.
# See '$ifdef' below for a definition of 'defined'.
#
# $endif: This command has no arguments and ends the section of lines begun
# by a test command ($ifdef, $ifndef, or $if). Each test command
# must have a matching $endif.
#
# $ifdef: Invoked as 'ifdef name'. The lines following this command appear
# in the output only if the name given is defined. 'Defined' means
# 1. The name is a predefined name and was not undefined using
# $undef, or
# 2. The name was defined using $define and has not been undefined
# by an intervening $undef.
#
# $ifndef: Invoked as 'ifndef name'. The lines following this command do not
# appear in the ouput if the name is not defined.
#
# $if: Invoked as 'if constant-expression'. Lines following this command
# are processed only if the constant-expression produces a result.
# The following arithmetic operators may be applied to integer
# arguments: + - * / % ^
#
# If an argument to one of the above operators is not an integer an
# error is produced.
#
# The following functions are provided: def(name), ndef(name)
# This allows the utility of $ifdef and $ifndef in a $if command.
# def produces a result if name is defined and ndef produces a
# result if name is not defined. There must not be any white space
# between the name of the function and the '(' and also between the
# name and the surrounding parentheses.
#
# The following comparision operators may be used on integer
# operands:
#
# > >= = < <= ~=
#
# Also provided are alternation (|) and conjunction(&). The
# following table lists all operators with regard to decreasing
# precedence:
#
# ^ (associates right to left)
# * / %
# + -
# > >= = < <= ~=
# |
# &
#
# The precedence of '|' and '&' are the same as the corresponding
# Icon counterparts. Parentheses may be used for grouping.
#
# $else This command has no arguments and reverses the notion of the test
# command which matches this directive. If the lines preceding this
# command where ignored the lines following are processed, and vice
# versa.
#
# Macro Processing and Textual Substitution
# -----------------------------------------
# No substitution is performed on text inside single quotes (cset literals)
# and double quotes (strings) when a line is processed. The preprocessor will
# detect unclosed cset literals or strings on a line and issue an error message
# unless the underscore character is the last character on the line. The
# output from
#
# $define foo bar
# write("foo")
#
# is
#
# write("foo")
#
# Unless the -C option is specified comments are stripped from the source.
# Even if the option is given the text after the '#' is never expanded.
#
# Macro formal parameters are recognized in $define bodies even inside cset
# constants and strings. The output from
#
# $define test(a) "a"
# test(processed)
#
# is the following sequence of characters: "processed".
#
# Macros are not expanded while processing a $define or $undef. Thus:
#
# $define off invalid
# $define bar off
# $undef off
# bar
#
# produces off. The name argument to $ifdef or $ifndef is also not expanded.
#
# Mismatches between the number of formal and actual parameters in a macro
# call are caught by ipp. If the number of actual parameters is greater than
# the number of formal parameters is error is produced. If the number of
# actual parameters is less than the number of formal parameters a warning is
# issued and the missing actual parameters are turned into null strings.
#
############################################################################
#
# The records and global variables used by ipp are described below:
#
# Src_desc: Record which holds the 'file descriptor' and name
# of the corresponding file. Used in a stack to keep
# track of the source files when $includes are used.
# Opt_rec Record returned by the get_args() routine which returns
# the options and arguments on the command line. options
# is a cset containing options that have no arguments.
# pairs is a list of [option, argument] pairs. ifile and
# ofile are set if the input or output files have been
# specified.
# Defs_rec Record stored in a table keyed by names. Holds the
# names of formal arguments, if any, and the replacement
# text for that name.
# Chars Cset of all characters that may appear in the input.
# Defs The table holding the definition data for each name.
# Depth The maximum depth of the input source stack.
# Ifile Descriptor for the input file.
# Ifile_name Name of the input file.
# Init_name_char Cset of valid initial characters for names.
# Line_no The current line number.
# Name_char Cset of valid characters for names.
# Non_name_char The complement of the above cset.
# Ofile The descriptor of the output file.
# Options Cset of no-argument options specified on the command
# line.
# Path_list List of directories to search in for "" include files.
# Src_stack The stack of input source records.
# Std_include_paths List of directories to search in for <> include files.
# White_space Cset for white-space characters.
# TRUE Defined as 1.
#
############################################################################
record Src_desc(fd, fname)
record Opt_rec(options, pairs, ifile, ofile)
record Defs_rec(arg_list, text)
global Chars, Defs, Depth, Ifile, Ifile_name, Init_name_char,
Line_no, Name_char, Non_name_char, Ofile, Options, Path_list,
Src_stack, Std_include_paths, White_space, TRUE
procedure main(arg_list)
local cmd, line, source
init(arg_list)
repeat {
while line := read(Ifile) do {
Line_no +:= 1
line ? {
if tab(any('$')) then
if cmd := tab(many(Chars)) then
process_cmd(cmd)
else
error("Missing command")
else
write(Ofile, process_text(line))
}
}
# Get new source
close(Ifile)
if source := pop(Src_stack) then {
Ifile := source.fd
Ifile_name := source.fname
Line_no := 0
}
else break
}
end
procedure process_cmd(cmd)
case cmd of {
"dump": dump()
"define": define()
"undef": undefine()
"include": include()
"if": if_cond()
"ifdef": ifdef()
"ifndef": ifndef()
"else" | "endif": error("No previous 'if' expression")
"endif": error("No previous 'if' expression")
default: error("Undefined command")
}
return
end
procedure init(arg_list)
local s
TRUE := 1
Defs := table()
Init_name_char := &letters ++ '_'
Name_char := Init_name_char ++ &digits
Non_name_char := ~Name_char
White_space := ' \t\b'
Chars := &ascii -- White_space
Line_no := 0
Depth := 10
Std_include_paths := ["/usr/icon/src"]
# Predefine features
every s:= &features do {
s[upto(' -', s)] := "_"
Defs[s] := Defs_rec([], "1")
}
# Set path list for $include files given in ""
Path_list := []
if \Defs["UNIX"] then
getenv("PATH") ? while put(Path_list, 1(tab(upto(':')), move(1)))
else
put(Path_list, "")
process_options(arg_list)
end
procedure process_options(arg_list)
local args, arg_opts, pair, simple_opts, tmp_list, value
simple_opts := 'C'
arg_opts := 'dDI'
Src_stack := []
args := get_args(arg_list, simple_opts, arg_opts)
if \args.ifile then {
(Ifile := open(args.ifile)) | stop("Can not open input file ", args.ifile)
Ifile_name := args.ifile
}
else {
Ifile := &input
Ifile_name := "stdin"
}
if \args.ofile then
(Ofile := open(args.ofile, "w")) | stop("Can not open output file",
args.ofile)
else
Ofile := &output
Options := args.options
tmp_list := []
every pair := !args.pairs do
case pair[1] of {
"D": def_opt(pair[2])
"d": if (value := integer(pair[2])) > 0 then
Depth := value
else
stop("Invalid argument for depth")
"I": push(tmp_list, pair[2])
}
Path_list := tmp_list ||| Path_list
end
procedure get_args(arg_list, simple_opts, arg_opts)
local arg, ch, get_ofile, i, opts, queue
opts := Opt_rec('', [])
queue := []
every arg := arg_list[i := 1 to *arg_list] do
if arg == "-" then # Next argument should be output file
get_ofile := (i = *arg_list - 1) |
stop("Invalid position of '-' argument")
else if arg[1] == "-" then # Get options
every ch := !arg[2: 0] do
if any(simple_opts, ch) then
opts.options ++:= ch
else if any(arg_opts, ch) then
put(queue, ch)
else
stop("Invalid option - ", ch)
else if ch := pop(queue) then # Get argument for option
push(opts.pairs, [ch, arg])
else if \get_ofile then { # Get output file
opts.ofile := arg
get_ofile := &null
}
else { # Get input file
opts.ifile := arg
get_ofile := (i < *arg_list)
}
if \get_ofile | *queue ~= 0 then
stop("Invalid number of arguments")
return opts
end
# if_cond is the procedure for $if. The procedure const_expr() which
# evaluates the constant expression may be found in expr.icn
#
# Procedure true_cond is invoked if the evaluation of a previous $if, $ifdef, or
# $ifndef causes subsequent lines to be processed. Lines will be processed
# upto a $endif or a $else. If $else is encountered, lines are skipped until
# the $endif matching the $else is encountered.
#
# Procedure false_cond is invoked if the evaluation of a previous $if, $ifdef,
# or $ifndef causes subsequent lines to be skipped. Lines will be skipped
# upto a $endif or a $else. If $else is encountered, lines are processed until
# the $endif matching the $else is encountered.
#
# If called with a 1, procedure skip_to skips over lines until a $endif is
# encountered. If called with 2, it skips until either a $endif or $else is
# encountered.
procedure if_cond()
local expr
if expr := (tab(many(White_space)) & not pos(0) & tab(0)) then
conditional(const_expr(expr))
else
error("Constant expression argument to 'if' missing")
end
procedure ifdef()
local name
if name := 2(tab(many(White_space)), tab(any(Init_name_char)) ||
(tab(many(Name_char)) | ""), any(White_space) | pos(0)) then {
tab(many(White_space))
if not(pos(0) | any('#')) then
warning("Extraneous characters after argument to 'ifdef'")
conditional(Defs[name])
}
else
error("Argument to 'ifdef' is not a valid name")
end
procedure ifndef()
local name
if name := 2(tab(many(White_space)), tab(any(Init_name_char)) ||
(tab(many(Name_char)) | ""), any(White_space) | pos(0)) then {
tab(many(White_space))
if not(pos(0) | any('#')) then
warning("Extraneous characters after argument to 'ifndef'")
if \Defs[name] then
conditional(&null)
else
conditional(TRUE)
}
else
error("Argument to 'ifndef' is not a valid name")
end
procedure conditional(flag)
if \flag then
true_cond()
else
false_cond()
end
procedure true_cond()
local line
while line := read(Ifile) & (Line_no +:= 1) do
line ? {
if tab(any('$')) then
if tab(match("if")) then
eval_cond()
else if check_cmd("else") then {
# Skip only until a $endif
skip_to(1) |
error("'endif' not encountered before end of file")
return
}
else if check_cmd("endif") then
return
else
process_cmd(tab(many(Chars))) | error("Undefined command")
else
write(Ofile, process_text(line))
}
error("'endif' not encountered before end of file")
end
procedure false_cond()
local cmd, line
# Skip to $else or $endif
(cmd := skip_to(2)) | error("'endif' not encountered before end of file")
if cmd == "endif" then
return
while line := read(Ifile) & (Line_no +:= 1) do
line ? {
if tab(any('$')) then
if check_cmd("endif") then
return
else if tab(match("if")) then
eval_cond()
else
process_cmd(tab(many(Chars))) | error("Undefined command")
else
write(Ofile, process_text(line))
}
error("'endif' not encountered before end of file")
end
procedure eval_cond()
if tab(match("def")) & (any(White_space) | pos(0)) then
ifdef()
else if tab(match("ndef")) & (any(White_space) | pos(0)) then
ifndef()
else if any(White_space) | pos(0) then
return const_expr(tab(0))
else
error("Undefined command")
end
procedure check_cmd(cmd)
local s
if (s := tab(match(cmd))) & (tab(many(White_space)) | pos(0)) then {
if not(match("if", cmd) | pos(0) | any('#')) then
warning("Extraneous characters after command")
return s
}
else
fail
end
procedure skip_to(n)
local cmd, ifs, elses, line, s
ifs := elses := 0
while line := read(Ifile) & (Line_no +:= 1) do
line ? {
if tab(any('$')) then
if cmd := (check_cmd("endif") | (n = 2 & check_cmd("else"))) then
if ifs = elses = 0 then
return cmd
else if cmd == "endif" then {
ifs -:= 1
elses := 0
}
else if elses = 0 then
if ifs > 0 then
elses := 1
else
error("'$else' encountered before 'if'")
else
error("Previous '$else' not terminated by 'endif'")
else if check_cmd("endif") then {
ifs -:= 1
elses := 0
}
else if check_cmd("if" | "ifdef" | "ifndef") then
ifs +:= 1
else # $else
if elses = 0 then
if ifs > 0 then
elses := 1
else
error("'$else' encountered before 'if'")
else
error("Previous '$else' not terminated by 'endif'")
}
end
procedure define()
local args, name, text
if name := 2(tab(many(White_space)), tab(any(Init_name_char)) ||
(tab(many(Name_char)) | ""), any(White_space | '(') | pos(0)) then {
if name == ("_LINE_" | "_FILE_") then
error(name, " is a reserved name and can not be redefined")
if tab(any('(')) then { # A macro
if not upto(')') then
error("Missing ')' in macro definition")
args := get_formals()
text := get_text(TRUE)
}
else {
args := []
text := get_text()
}
if \Defs[name] then
warning(name, " redefined")
Defs[name] := Defs_rec(args, text)
}
else
error("Illegal or missing name in define")
end
procedure get_text(flag)
local get_cont, text, line
if \flag then
text := (tab(many(White_space)) | "") || tab(0)
else
text := (tab(any(White_space)) & tab(0)) | ""
if text[-1] == "\\" then {
get_cont := TRUE
text[-1] := ""
while line := read(Ifile) do {
Line_no +:= 1
text ||:= line
if text[-1] == "\\" then
text[-1] := ""
else {
get_cont := &null
break
}
}
}
if \get_cont then
error("Continuation line not found before end of file")
return text
end
procedure get_formals()
local arg, args, ch, edited
args := []
while arg := 1(tab(upto(',)')), ch := move(1)) do {
if edited := (arg ? 2(tab(many(White_space)) | TRUE,
tab(any(Init_name_char)) || (tab(many(Name_char)) | ""),
tab(many(White_space)) | pos(0))) then
put(args, edited)
else if arg == "" then
return [""]
else
error("Invalid formal argument in macro definition")
if ch == ")" then
break
}
return args
end
procedure undefine()
local name
if name := (tab(many(White_space)) & tab(many(Chars))) then {
tab(many(White_space))
if not(pos(0) | any('#')) then
warning("Extraneous characters after argument to undef")
if not(name ? (tab(any(Init_name_char)), (tab(many(Name_char)) | ""),
pos(0))) then
warning("Argument to undef is not a valid name")
if name == ("_LINE_" | "_FILE_") then
error(name, " is a reserved name that can not be undefined")
\Defs[name] := &null
}
else
error("Name missing in undefine")
end
procedure process_text(line)
local add, entry, new, position, s, token
static in_string, in_cset
new := ""
while *line > 0 do {
add := ""
line ? {
if \in_string then {
if new ||:= (tab(upto('"')) || move(1)) then
in_string := &null
else {
new ||:= tab(0)
if line[-1] ~== "_" then {
in_string := &null
warning("Unclosed double quote")
}
}
}
if \in_cset then {
if new ||:= (tab(upto('\'')) || move(1)) then
in_cset := &null
else {
new ||:= tab(0)
if line[-1] ~== "_" then {
in_cset := &null
warning("Unclosed single quote")
}
}
}
new ||:= tab(many(White_space))
if token := tab(many(Name_char) | any(Non_name_char)) then {
if token == "\"" then { # Process string
new ||:= "\""
if \in_string then
in_string := &null
else {
in_string := TRUE
if pos(0) then {
warning("Unclosed double quote")
in_string := &null
}
}
add ||:= tab(0)
}
else if token == "'" then { # Process cset literal
new ||:= "'"
if \in_cset then
in_cset := &null
else {
in_cset := TRUE
if pos(0) then {
warning("Unclosed single quote")
in_cset := &null
}
}
add ||:= tab(0)
}
else if token == "#" then {
if any(Options, "C") then
new ||:= token || tab(0)
else
(new ||:= (token ? tab(upto('#')))) & tab(0)
}
else if token == "_LINE_" then
new ||:= string(Line_no)
else if token == "_FILE_" then
new ||:= Ifile_name
else if /(entry := Defs[token]) then
new ||:= token
else if *entry.arg_list = 0 then
if in_text(token, entry.text) then
error("Recursive textual substitution")
else
add := entry.text
else if *entry.arg_list = 1 & entry.arg_list[1] == "" then {
if move(2) == "()" then
add := entry.text
else
error(token, ": Invalid macro call")
}
else { # Macro with arguments
s := tab(bal(White_space, '(', ')') | 0)
if not any('(', s) then
error(token, ": Incomplete macro call")
add := process_macro(token, entry, s)
}
}
position := &pos
}
line := add || line[position: 0]
}
return new
end
procedure process_macro(name, entry, s)
local arg, args, new_entry, news, token
s ? {
args := []
if tab(any('(')) then {
repeat {
arg := tab(many(White_space)) | ""
if token := tab(many(Chars -- '(,)')) then {
if /(new_entry := Defs[token]) then
arg ||:= token
else if *new_entry.arg_list = 0 then
arg ||:= new_entry.text
else { # Macro with arguments
if news := tab(bal(' \t\b,)', '(', ')')) then
arg ||:= process_macro(token, new_entry, news)
else
error(token, ": Error in arguments to macro call")
}
} # if
else if not any(',)') then
error(name, ": Incomplete macro call")
arg ||:= tab(many(White_space))
put(args, arg)
if any(')') then
break
move(1)
} # repeat
if *args > *entry.arg_list then
error(name, ": Too many arguments in macro call")
else if *args < *entry.arg_list then
warning(name, ": Missing arguments in macro call")
return macro_call(entry, args)
} # if
}
end
procedure macro_call(entry, args)
local i, map, result, token, x, y
x := create !entry.arg_list
y := create !args
map := table()
while map[@x] := @y | ""
entry.text ? {
result := tab(many(Non_name_char)) | ""
while token := tab(many(Name_char)) do {
result ||:= \map[token] | token
result ||:= tab(many(Non_name_char))
}
}
return result
end
procedure in_text(name, text)
text ?
return (pos(1) & tab(match(name)) & (upto(Non_name_char) | pos(0))) |
(tab(find(name)) & move(-1) & tab(any(Non_name_char)) & move(*name) &
any(Non_name_char) | pos(0))
end
# In order to simplify the evaluation the three relational operators that
# are longer than one character (<= ~= >=) are replaced by one character
# 'aliases'.
#
# One problem with eval_expr() is that the idea of failure as opposed to
# returning some special value can not be used. For example if def(UNIX)
# fails eval_expr() would try to convert it to an integer as its next step.
# We would only want func() to fail if the argument is not a valid function,
# not if the function is valid and the call fails. 'Failure' is therefore
# represented by &null.
procedure const_expr(expr)
local new, temp
new := ""
every new ||:= (" " ~== !expr)
while new[find(">=", new) +: 2] := "\200"
while new[find("<=", new) +: 2] := "\201"
while new[find("~=", new) +: 2] := "\202"
return \eval_expr(new) | &null
end
procedure eval_expr(expr)
while expr ?:= 2(="(", tab(bal(')')), pos(-1))
return lassoc(expr, '&') | lassoc(expr, '|') |
lassoc(expr, '<=>\200\201\202' | '+-' | '*/%') | rassoc(expr, '^') |
func(expr) | integer(process_text(expr)) | error(expr, " : Integer expected")
end
procedure lassoc(expr, op)
local j
expr ? {
every j := bal(op)
return eval(tab(\j), move(1), tab(0))
}
end
procedure rassoc(expr, op)
return expr ? eval(tab(bal(op)), move(1), tab(0))
end
procedure func(expr)
local name, arg
expr ? {
(name := tab(upto('(')),
arg := (move(1) & tab(upto(')')))) | fail
}
if \name == ("def" | "ndef") then
return name(arg)
else
error("Invalid function name")
end
procedure eval(arg1, op, arg2)
arg1 := process_text(\eval_expr(arg1)) | &null
arg2 := process_text(\eval_expr(arg2)) | &null
if (op ~== "&") & (op ~== "|") then
(integer(arg1) & integer(arg2)) |
error(map(op), " : Arguments must be integers")
return case op of {
"+": arg1 + arg2
"-": arg1 - arg2
"*": arg1 * arg2
"/": arg1 / arg2
"%": arg1 % arg2
"^": arg1 ^ arg2
">": arg1 > arg2
"=": arg1 = arg2
"<": arg1 < arg2
"\200": arg1 >= arg2
"\201": arg1 <= arg2
"\202": arg1 ~= arg2
"|": alt(arg1, arg2)
"&": conjunction(arg1, arg2)
}
end
procedure def(name)
if \Defs[name] then
return ""
else
return &null
end
procedure ndef(name)
if \Defs[name] then
return &null
else
return ""
end
procedure alt(x, y)
if \x then
return x
else if \y then
return y
else
return &null
end
procedure conjunction(x, y)
if \x & \y then
return y
else
return &null
end
procedure map(op)
return case op of {
"\200": ">="
"\201": "<="
"\202": "~="
default: op
}
end
procedure dump()
tab(many(White_space))
if not(pos(0) | any('#')) then
warning("Extraneous characters after dump command")
every write(&errout, (!sort(Defs))[1])
end
procedure include()
local ch, fname
static fname_chars
initial fname_chars := Chars -- '<>"'
if fname := 3(tab(many(White_space)), (tab(any('"')) & (ch := "\"")) |
(tab(any('<')) & (ch := ">")), tab(many(fname_chars)),
tab(any('>"')) == ch, tab(many(White_space)) | pos(0)) then {
if not(pos(0) | any('#')) then
warning("Extraneous characters after include file name")
if ch == ">" then
find_file(fname, Std_include_paths)
else
find_file(fname, Path_list)
}
else
error("Missing or invalid include file name")
end
procedure find_file(fname, path_list)
local ifile, ifname, path
every path := !path_list do {
if path == ("" | ".") then
ifname := fname
else
ifname := path || "/" || fname
if ifile := open(ifname) then {
if *Src_stack >= Depth then {
close(ifile)
error("Possibly infinitely recursive file inclusion")
}
if ifname == (Ifile_name | (!Src_stack).fname) then
error("Infinitely recursive file inclusion")
push(Src_stack, Src_desc(Ifile, Ifile_name))
Ifile := ifile
Ifile_name := ifname
Line_no := 0
return
}
}
error("Can not open include file ", fname)
end
procedure def_opt(s)
local name, text, Name
s ? {
name := tab(upto('=')) | tab(0)
text := (move(1) & tab(0)) | "1"
}
if name == ("_LINE_" | "_FILE_") then
error(name, " is a reserved name and can not be redefined by the -D option")
if name ~==:= (tab(any(Init_name_char)) & tab(many(Name_char)) & pos(0)) then
error(name, " : Illegal name argument to -D option")
if \Defs[Name] then
warning(name, " : redefined by -D option")
Defs[name] := Defs_rec([], text)
end
procedure warning(s1, s2)
s1 ||:= \s2
write(&errout, Ifile_name, ": ", Line_no, ": ", "Warning " || s1)
end
procedure error(s1, s2)
s1 ||:= \s2
stop(Ifile_name, ": ", Line_no, ": ", "Error " || s1)
end
##########
iprint.icn
############################################################################
#
# Name: iprint.icn
#
# Title: Print Icon program
#
# Author: Robert J. Alexander
#
# Date: June 10, 1988
#
############################################################################
#
# The defaults are set up for printing of Icon programs, but
# through command line options it can be set up to print programs
# in other languages, too (such as C). This program has several
# features:
#
# If a program is written in a consistent style, this program
# will attempt to keep whole procedures on the same page. The
# default is to identify the end of a print group (i.e. a pro-
# cedure) by looking for the string "end" at the beginning of a
# line. Through the -g option, alternative strings can be used to
# signal end of a group. Using "end" as the group delimiter
# (inclusive), comments and declarations prior to the procedure are
# grouped with the procedure. Specifying a null group delimiter
# string (-g '') suppresses grouping.
#
# Page creases are skipped over, and form-feeds (^L) imbedded in
# the file are handled properly. (Form-feeds are treated as spaces
# by many C compilers, and signal page ejects in a listing). Page
# headings (file name, date, time, page number) are normally
# printed unless suppressed by the -h option.
#
# Options:
#
# -n number lines.
#
# -pN page length: number of lines per page (default: 60
# lines).
#
# -tN tab stop spacing (default: 8).
#
# -h suppress page headings.
#
# -l add three lines at top of each page for laser printer.
#
# -gS end of group string (default: "end").
#
# -cS start of comment string (default: "#").
#
# -xS end of comment string (default: none).
#
# -i ignore FF at start of line.
#
# Any number of file names specified will be printed, each
# starting on a new page.
#
# For example, to print C source files such as the Icon source
# code, use the following options:
#
# iprint -g ' }' -c '/*' -x '*/' file ...
#
# Control lines:
#
# Control lines are special character strings that occur at the
# beginnings of lines that signal special action. Control lines
# begin with the start of comment string (see options). The control
# lines currently recognized are:
#
# <comment string>eject -- page eject (line containing "eject"
# does not print).
#
# <comment string>title -- define a title line to print at top
# of each page. Title text is separated from the <comment
# string>title control string by one space and is terminated by
# <end of comment string> or end of line, whichever comes first.
#
# <comment string>subtitle -- define a sub-title line to print
# at top of each page. Format is parallel to the "title" control
# line, above.
#
# If a page eject is forced by maximum lines per page being
# exceeded (rather than intentional eject via control line, ff, or
# grouping), printing of blank lines at the top of the new page is
# suppressed. Line numbers will still be printed correctly.
#
############################################################################
#
# Links: options
#
############################################################################
global pagelines,tabsize,lines,page,datetime,title,subtitle,pagestatus,blanks,
group,numbers,noheaders,hstuff,gpat,comment,comment_end,laser,
ignore_ff
procedure main(arg)
local files,x
&dateline ? {tab(find(",")) ; move(2) ; datetime := tab(0)}
files := []
pagelines := 60
tabsize := 8
gpat := "end"
comment := "#"
while x := get(arg) do {
if match("-",x) then { # Arg is an option
case x[2] of {
"n": numbers := "yes"
"p": {
pagelines := ("" ~== x[3:0]) | get(arg)
if not (pagelines := integer(pagelines)) then
stop("Invalid -p parameter: ",pagelines)
}
"t": {
tabsize := ("" ~== x[3:0]) | get(arg)
if not (tabsize := integer(tabsize)) then
stop("Invalid -t parameter: ",tabsize)
}
"h": noheaders := "yes"
"l": laser := "yes"
"g": {
gpat := ("" ~== x[3:0]) | get(arg)
}
"c": {
comment := ("" ~== x[3:0]) | get(arg)
}
"x": {
comment_end := ("" ~== x[3:0]) | get(arg)
}
"i": ignore_ff := "yes"
default: stop("Invalid option ",x)
}
}
else put(files,x)
}
if *files = 0 then stop("usage: iprint -options file ...\n_
options:\n_
\t-n\tnumber the lines\n_
\t-p N\tspecify lines per page (default 60)\n_
\t-t N\tspecify tab width (default 8)\n_
\t-h\tsuppress page headers\n_
\t-l\tadd 3 blank lines at top of each page\n_
\t-g S\tpattern for last line in group\n_
\t-c S\t'start of comment' string\n_
\t-x S\t'end of comment' string\n_
\t-i\tignore FF")
every x := !files do expand(x)
end
procedure expand(fn)
local f,line,cmd,linenbr,fname
f := open(fn) | stop("Can't open ",fn)
fn ? {
while tab(find("/")) & move(1)
fname := tab(0)
}
hstuff := fname || " " || datetime || " page "
title := subtitle := &null
lines := pagelines
page := 0 ; linenbr := 0
group := []
while line := trim(read(f)) do {
if \ignore_ff then while match("\f",line) do line[1] := ""
linenbr +:= 1
if match("\f",line) then {
dumpgroup()
lines := pagelines
repeat {
line[1] := ""
if not match("\f",line) then break
}
}
line ? {
if =comment & cmd := =("eject" | "title" | "subtitle") then {
dumpgroup()
case cmd of { # Command line
"title": (move(1) & title := trim(tab(find(comment_end)))) |
(title := &null)
"subtitle": (move(1) & subtitle := trim(tab(find(comment_end)))) |
(subtitle := &null)
}
lines := pagelines
}
else { # Ordinary (non-command) line
if not (*group = 0 & *line = 0) then {
put(group,line)
if \numbers then put(group,linenbr)
}
if endgroup(line) then dumpgroup()
}
}
}
dumpgroup()
close(f)
lines := pagelines
end
procedure dumpgroup()
local line,linenbr
if *group > 0 then {
if lines + *group / ((\numbers & 2) | 1) + 2 >= pagelines then
lines := pagelines
else {write("\n") ; lines +:= 2}
while line := get(group) do {
if \numbers then linenbr := get(group)
if lines >= pagelines then {
printhead()
}
if *line = 0 then {
if pagestatus ~== "empty" then {blanks +:= 1 ; lines +:= 1}
next
}
every 1 to blanks do write()
blanks := 0
pagestatus := "not empty"
if \numbers then writes(right(linenbr,5)," ")
write(detab(line))
lines +:= 1
}
}
return
end
procedure endgroup(s)
return match("" ~== gpat,s)
end
procedure printhead()
static ff,pg
writes(ff) ; ff := "\f"
lines := 0
pg := string(page +:= 1)
if /noheaders then {
if \laser then write("\n\n")
write(left(\title | "",79 - *hstuff - *pg),hstuff,pg)
lines +:= 2
write(\subtitle) & lines +:= 1
write()
}
pagestatus := "empty"
blanks := 0
return
end
procedure detab(s)
local t
t := ""
s ? {
while t ||:= tab(find("\t")) do {
t ||:= repl(" ",tabsize - *t % tabsize)
move(1)
}
t ||:= tab(0)
}
return t
end
##########
ipsort.icn
############################################################################
#
# Name: ipsort.icn
#
# Title: Sort Icon procedures
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program reads an Icon program and writes an equivalent
# program with the procedures sorted alphabetically. Global, link,
# and record declarations come first in the order they appear in
# the original program. The main procedure comes next followed by
# the remaining procedures in alphabetical order.
#
# Comments and white space between declarations are attached to
# the next following declaration.
#
# Limitations: This program only recognizes declarations that start
# at the beginning of a line.
#
# Comments and interline white space between declarations may
# not come out as intended.
#
############################################################################
procedure main()
local line, x, i, proctable, proclist, comments, procname
comments := [] # list of comment lines
proctable := table() # table of procedure declarations
while line := read() do {
line ? {
if ="procedure" & # procedure declaration
tab(many('\t ')) &
procname := tab(upto('(')) | stop("*** bad syntax: ",line)
then { # if main, force sorting order
if procname == "main" then procname := "\0main"
proctable[procname] := x := []
while put(x,get(comments)) # save it
put(x,line)
while line := read() do {
put(x,line)
if line == "end" then break
}
}
# other declarations
else if =("global" | "record" | "link")
then {
while write(get(comments))
write(line)
}
else put(comments,line)
}
}
while write(get(comments))
proclist := sort(proctable,3) # sort procedures
while get(proclist) do
every write(!get(proclist))
end
##########
ipsplit.icn
############################################################################
#
# Name: ipsplit.icn
#
# Title: Split Icon program into separate files
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This progam reads an Icon program and writes each procedure to
# a separate file. The output file names consist of the procedure
# name with .icn appended. If the -g option is specified, any glo-
# bal, link, and record declarations are written to that file. Oth-
# erwise they are written in the file for the procedure that
# immediately follows them.
#
# Comments and white space between declarations are attached to
# the next following declaration.
#
# Notes:
#
# The program only recognizes declarations that start at the
# beginning of lines. Comments and interline white space between
# declarations may not come out as intended.
#
# If the -g option is not specified, any global, link, or record
# declarations that follow the last procedure are discarded.
#
############################################################################
#
# Links: options
#
############################################################################
link options
procedure main(args)
local line, x, i, proctable, proclist, comments, gfile, gname, ofile
local opts
comments := []
opts := options(args,"g:")
if gname := \opts["g"] then {
gfile := open(gname,"w") | stop("*** cannot open ",gname)
}
proctable := table()
while line := read() do {
if line ? {
="procedure" & # procedure declaration
tab(many(' ')) &
proctable[tab(upto('('))] := x := []
} then {
while put(x,get(comments)) # save it
put(x,line)
i := 1
while line := read() do {
put(x,line)
if line == "end" then break
}
}
# other declarations
else if \gfile & line ? =("global" | "record" | "link")
then {
while write(gfile,get(comments))
write(gfile,line)
}
else put(comments,line)
}
while write(\gfile,get(comments))
proclist := sort(proctable,3) # sort procedures
while x := get(proclist) do { # output procedures
ofile := open(x || ".icn","w") | stop("cannot write ",x,".icn")
every write(ofile,!get(proclist))
close(ofile)
}
end
##########
ipxref.icn
############################################################################
#
# Name: ipxref.icn
#
# Title: Produce cross reference for Icon program
#
# Author: Allan J. Anderson
#
# Date: June 10, 1988
#
############################################################################
#
# This program cross-references Icon programs. It lists the
# occurrences of each variable by line number. Variables are listed
# by procedure or separately as globals. The options specify the
# formatting of the output and whether or not to cross-reference
# quoted strings and non-alphanumerics. Variables that are followed
# by a left parenthesis are listed with an asterisk following the
# name. If a file is not specified, then standard input is cross-
# referenced.
#
# Options: The following options change the format defaults:
#
# -c n The column width per line number. The default is 4
# columns wide.
#
# -l n The starting column (i.e. left margin) of the line
# numbers. The default is column 40.
#
# -w n The column width of the whole output line. The default
# is 80 columns wide.
#
# Normally only alphanumerics are cross-referenced. These
# options expand what is considered:
#
# -q Include quoted strings.
#
# -x Include all non-alphanumerics.
#
# Note: This program assumes the subject file is a valid Icon pro-
# gram. For example, quotes are expected to be matched.
#
############################################################################
#
# Bugs:
#
# In some situations, the output is not properly formatted.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global resword, linenum, letters, alphas, var, buffer, qflag, infile, xflag
global inmaxcol, inlmarg, inchunk, localvar, lin
record procrec(pname,begline,lastline)
procedure main(args)
local word, w2, p, prec, i, L, ln, switches, nfile
resword := ["break","by","case","default","do","dynamic","else","end",
"every","fail","global","if","initial","link", "local","next","not",
"of","procedure", "record","repeat","return","static","suspend","then",
"to","until","while"]
linenum := 0
var := table() # var[variable[proc]] is list of line numbers
prec := [] # list of procedure records
localvar := [] # list of local variables of current routine
buffer := [] # a put-back buffer for getword
proc := "global"
letters := &letters ++ '_'
alphas := letters ++ &digits
switches := options(args,"qxw+l+c+")
if \switches["q"] then qflag := 1
if \switches["x"] then xflag := 1
inmaxcol := \switches["w"]
inlmarg := \switches["l"]
inchunk := \switches["c"]
infile := open(args[1],"r") # could use some checking
while word := getword() do
if word == "link" then {
buffer := []
lin := ""
next
}
else if word == "procedure" then {
put(prec,procrec("",linenum,0))
proc := getword() | break
p := pull(prec)
p.pname := proc
put(prec,p)
}
else if word == ("global" | "link" | "record") then {
word := getword() | break
addword(word,"global",linenum)
while (w2 := getword()) == "," do {
if word == !resword then break
word := getword() | break
addword(word,"global",linenum)
}
put(buffer,w2)
}
else if word == ("local" | "dynamic" | "static") then {
word := getword() | break
put(localvar,word)
addword(word,proc,linenum)
while (w2 := getword()) == "," do {
if word == !resword then break
word := getword() | break
put(localvar,word)
addword(word,proc,linenum)
}
put(buffer,w2)
}
else if word == "end" then {
proc := "global"
localvar := []
p := pull(prec)
p.lastline := linenum
put(prec,p)
}
else if word == !resword then
next
else {
ln := linenum
if (w2 := getword()) == "(" then
word ||:= " *" # special mark for procedures
else
put(buffer,w2) # put back w2
addword(word,proc,ln)
}
every write(!format(var))
write("\n\nprocedures:\tlines:\n")
L := []
every p := !prec do
put(L,left(p.pname,16," ") || p.begline || "-" || p.lastline)
every write(!sort(L))
end
procedure addword(word,proc,lineno)
if any(letters,word) | \xflag then {
/var[word] := table()
if /var[word]["global"] | (word == !\localvar) then {
/(var[word])[proc] := [word,proc]
put((var[word])[proc],lineno)
}
else {
/var[word]["global"] := [word,"global"]
put((var[word])["global"],lineno)
}
}
end
procedure getword()
local j, c
static i, nonwhite
initial nonwhite := ~' \t\n'
repeat {
if *buffer > 0 then return get(buffer)
if /lin | i = *lin + 1 then
if lin := read(infile) then {
i := 1
linenum +:= 1
}
else fail
if i := upto(nonwhite,lin,i) then { # skip white space
j := i
if lin[i] == ("'" | "\"") then { # don't xref quoted words
if /qflag then {
c := lin[i]
i +:= 1
repeat
if i := upto(c ++ '\\',lin,i) + 1 then
if lin[i - 1] == c then break
else i +:= 1
else {
i := 1
linenum +:= 1
lin := read(infile) | fail
}
}
else i +:= 1
}
else if lin[i] == "#" then { # don't xref comments; get next line
i := *lin + 1
}
else if i := many(alphas,lin,i) then
return lin[j:i]
else {
i +:= 1
return lin[i - 1]
}
}
else
i := *lin + 1
} # repeat
end
procedure format(T)
local V, block, n, L, lin, maxcol, lmargin, chunk, col
initial {
maxcol := \inmaxcol | 80
lmargin := \inlmarg | 40
chunk := \inchunk | 4
}
L := []
col := lmargin
every V := !T do
every block := !V do {
lin := left(block[1],16," ") || left(block[2],lmargin - 16," ")
every lin ||:= center(block[3 to *block],chunk," ") do {
col +:= chunk
if col >= maxcol - chunk then {
lin ||:= "\n\t\t\t\t\t"
col := lmargin
}
}
if col = lmargin then lin := lin[1:-6] # came out exactly even
put(L,lin)
col := lmargin
}
L := sort(L)
push(L,"variable\tprocedure\t\tline numbers\n")
return L
end
##########
itab.icn
############################################################################
#
# Name: itab.icn
#
# Title: Entab an Icon program
#
# Author: Robert J. Alexander
#
# Date: December 5, 1989
#
############################################################################
#
# itab -- Entab an Icon program, leaving quoted strings alone.
#
# itab [input-tab-spacing] [output-tab-spacing]
# < source-program > entabbed-program
#
# Observes Icon Programming Language conventions for escapes and
# continuations in string constants. Input and output tab spacing
# defaults to 8.
#
############################################################################
global mapchars,intabs
procedure main(arg)
local outtabs, line, c, nonwhite, delim
intabs := (arg[1] | 8) + 1
outtabs := (arg[2] | 8) + 1
line := ""
while c := readx() do {
if not any(' \t',c) then nonwhite := 1
case c of {
"\n": {
write(map(entab(line,outtabs),\mapchars," \t") | line)
line := ""
nonwhite := &null
}
"'" | "\"": {
(/delim := c) | (delim := &null)
line ||:= c
}
"\\": line ||:= c || readx()
default: {
line ||:= if \delim & \nonwhite & \mapchars then
map(c," \t",mapchars) else c
}
}
}
end
procedure readx()
static buf,printchars
initial {
buf := ""
printchars := &cset[33:128]
}
if *buf = 0 then {
buf := detab(read(),intabs) || "\n" | fail
mapchars := (printchars -- buf)[1+:2] | &null
}
return 1(.buf[1],buf[1] := "")
end
##########
iundecl.icn
############################################################################
#
# Name: undeclared.icn
#
# Title: Utility to find undeclared variables in Icon source program.
#
# Author: Robert J. Alexander
#
# Date: March 11, 1990
#
############################################################################
#
# This program invokes icont to find undeclared variables in an Icon
# source program. The output is in the form of a "local" declaration,
# preceded by a comment line that identifies that procedure and file
# name from whence it arose. Beware that undeclared variables aren't
# necessarily local, so any which are intended to be global must be
# removed from the generated list.
#
# Multiple files can be specified as arguments, and will be processed
# in sequence. A file name of "-" represents the standard input file.
# If there are no arguments, standard input is processed.
#
# The program works only if procedures are formatted such that the
# keywords "procedure" and "end" are the first words on their
# respective lines.
#
# Only for UNIX, since the "p" (pipe) option of open() is used.
#
############################################################################
#
# Requires: UNIX
#
############################################################################
link filename
procedure main(arg)
local f, fn, line, names, p, sep, t, argstring, undeclared, pn
#
# Process command line file names.
#
if *arg = 0 then arg := ["-"] # if no arguments, standard input
#
# Build a set of all the undeclared identifiers.
#
argstring := ""
every argstring ||:= " " || !arg
p := open("icont -s -u -o /dev/null 2>&1" || argstring,"p") |
stop("popen failed")
undeclared := set()
while line := read(p) do line ?
if find("undeclared identifier") then
tab(find("\"") + 1) & insert(undeclared,tab(find("\"")))
close(p)
#
# Loop through files to process individual procedures.
#
every fn := !arg do {
f := if fn == "-" then &input else {
fn := \suffix(fn)[1] || ".icn"
open(fn) | stop("Can't open input file \"",fn,"\"")
}
#
# Loop to process lines of file (in string scanning mode).
#
while line := read(f) do line ? {
if tab(many(' \t')) | "" & ="procedure" & tab(many(' \t')) then {
t := open("undeclared_tmp.icn","w") | stop("Can't open work file")
write(t,line)
while line := read(f) do line ? {
write(t,line)
if tab(many(' \t')) | "" & ="end" & many(' \t') | pos(0) then
break
}
close(t)
#
# Now we have an isolated Icon procedure -- invoke icont to
# determine its undeclared variables.
#
p := open("icont -s -u -o /dev/null 2>&1 undeclared_tmp.icn","p") |
stop("popen failed")
names := []
while line := read(p) do line ?
if find("undeclared identifier") then
tab(find("\"") + 1) &
put(names,member(undeclared,tab(find("\""))))
close(p)
#
# Output the declaration.
#
pn := "\"" || tab(upto(' \t(')) || "\"" ||
if *arg > 1 then " (" || fn || ")" else ""
if *names = 0 then write("# ",pn," is OK")
else {
write("# Local declarations for procedure ",pn)
sep := "local "
every writes(sep,!sort(names)) do sep := ","
write()
}
}
}
#
# Close this input file.
#
close(f)
}
remove("undeclared_tmp.icn")
end
##########
iwriter.icn
############################################################################
#
# Name: iwriter.icn
#
# Title: Write Icon code to write input
#
# Author: Ralph E. Griswold
#
# Date: March 7, 1990
#
############################################################################
#
# Program that reads standard input and produces Icon expressions,
# which when compiled and executed, write out the original input.
#
# This is handy for incorporating, for example, message text in
# Icon programs. Or even for writing Icon programs that write Icon
# programs that ... .
procedure main()
while write("write(",image(read()),")")
end
##########
krieg.icn
############################################################################
#
# Name: krieg.icn
#
# Title: Play kriegspiel
#
# Author: David J. Slate
#
# Date: July 25, 1989
#
############################################################################
#
# The game:
#
# Kriegspiel (German for "war game") implements a monitor and, if desired,
# an automatic opponent for a variation of the game of chess which has the
# same rules and goal as ordinary chess except that neither player sees
# the other's moves or pieces. Thus Kriegspiel combines the intricacies
# and flavor of chess with additional elements of uncertainty, psychology,
# subterfuge, etc., which characterize games of imperfect information such
# as bridge or poker.
#
# The version of the game implemented here was learned by the author
# informally many years ago. There may be other variations, and perhaps
# the rules are actually written down somewhere in some book of games.
#
# The game is usually played in a room with three chess boards set up on
# separate tables. The players sit at the two end tables facing away from
# each other. A third participant, the "monitor", acts as a referee and
# scorekeeper and keeps track of the actual game on the middle board,
# which is also out of sight of either player. Since each player knows
# only his own moves, he can only guess the position of the enemy pieces,
# so he may place and move these pieces on his board wherever he likes.
#
# To start the game, the "White" player makes a move on his board. If the
# move is legal, the monitor plays it on his board and invites "Black" to
# make his response. If a move attempt is illegal (because it leaves the
# king in check or tries to move through an enemy piece, etc.), the
# monitor announces that fact to both players and the moving player must
# try again until he finds a legal move. Thus the game continues until it
# ends by checkmate, draw, or agreement by the players. Usually the
# monitor keeps a record of the moves so that the players can play the
# game over at its conclusion and see what actually happened, which is
# often quite amusing.
#
# With no additional information provided by the monitor, the game is very
# difficult but, surprisingly, still playable, with viable tactical and
# strategic ideas. Usually, however, the monitor gives some minimal
# feedback to both players about certain events. The locations of
# captures are announced as well as the directions from which checks on
# the kings originate.
#
# Even with the feedback about checks and captures, a newcomer to
# Kriegspiel might still think that the players have so little information
# that they could do little more than shuffle around randomly hoping to
# accidentally capture enemy pieces or checkmate the enemy king. But in
# fact a skilled player can infer a lot about his opponent's position and
# put together plans with a good chance of success. Once he achieves a
# substantial material and positional advantage, with proper technique he
# can usually exploit it by mopping up the enemy pieces, promoting pawns,
# and finally checkmating the enemy king as he would in an ordinary chess
# game. In the author's experience, a skilled Kriegspiel player will win
# most games against a novice, even if both players are equally matched at
# regular chess.
#
# The implementation:
#
# The functions of this program are to replace the human monitor, whose
# job is actually fairly difficult to do without mistakes, to permit the
# players to play from widely separate locations, to produce a machine-
# readable record of the game, and to provide, if desired, a computer
# opponent for a single player to practice and spar with.
#
# When two humans play, each logs in to the same computer from a separate
# terminal and executes his own copy of the program. This requires a
# multi-tasking, multi-user operating system. For various reasons, the
# author chose to implement Kriegspiel under Unix, using named pipes for
# inter-process communication. The program has been tested successfully
# under Icon Version 7.5 on a DecStation 3100 running Ultrix (a Berkeley-
# style Unix) and also under Icon Version 7.0 on the ATT Unix-PC and
# another System V machine, but unanticipated problems could be
# encountered by the installer on other computers. An ambitious user may
# be able to port the program to non-Unix systems such as Vax-VMS. It may
# also be possible to implement Kriegspiel on a non-multi-tasking system
# such as MS-DOS by using separate computers linked via serial port or
# other network. See the "init" procedure for much of the system-
# dependent code for getting user name, setting up communication files,
# etc.
#
# Two prospective opponents should agree on who is to play "white", make
# sure they know each other's names, and then execute Kriegspiel from
# their respective terminals. The program will prompt each player for his
# name (which defaults to his user or login name), his piece color, the
# name of his opponent, whether he wishes to play in "totally blind" mode
# (no capture or check information - not recommended for beginners), and
# the name of the log file on which the program will leave a record of the
# game (the program supplies a default in /tmp). Each program will set up
# some communication files and wait for the opponent's to show up. Once
# communication is established, each player will be prompted for moves and
# given information as appropriate. The online "help" facility documents
# various additional commands and responses.
#
# A player who wants a computer opponent should select "auto" as his
# opponent's name. Play then proceeds as with a human opponent. "Auto"
# is currently not very strong, but probably requires more than novice
# skill to defeat.
#
# Known bugs and limitations:
#
# No bugs are currently known in the areas of legal move generation,
# board position updating, checkmate detection, etc., but it is still
# possible that there are a few.
#
# Some cases of insufficient checkmating material on both sides are
# not detected as draws by the program.
#
# In the current implementation, a player may not play two
# simultaneous games under the same user name with the same piece color.
#
# If the program is terminated abnormally it may leave a communication
# pipe file in /tmp.
record board( pcs, cmv, cnm, caswq, caswk, casbq, casbk, fepp, ply)
global Me, Yu, Mycname, Yrcname, Mycomm, Yrcomm, Logname, Logfile,
Mycol, Yrcol, Blind, Bg, Frinclst, Lmv, Any, Tries, Remind
procedure automov( )
# Returns a pseudo-randomly selected move type-in to be used in
# "auto opponent" mode. But if possible, try to recapture (unless in
# blind mode):
local m, ms
static anyflag
initial anyflag := 0
if anyflag = 0 then {
anyflag := 1
return "any"
}
anyflag := 0
ms := set( )
every insert( ms, movgen( Bg))
if / Any then {
if find( ":", \ Lmv) & not find( "ep", \ Lmv) & / Blind then {
every m := ! ms do {
if m[ 4:6] == Lmv[ 4:6] & movlegal( Bg, m) then
return m[ 2:6] || "Q"
}
}
while * ms ~= 0 do {
if movlegal( Bg, m := ? ms) then
return m[ 2:6] || "Q"
delete( ms, m)
}
return "end"
}
else {
every m := ! ms do {
if m[ 1] == "P" & m[ 6] == ":" & movlegal( Bg, m) then
return m[ 2:6] || "Q"
}
return "end"
}
end
procedure chksqrs( b)
# Generates the set of squares of pieces giving check in board b;
# fails if moving side's king not in check:
local sk
sk := find( pc2p( "K", b.cmv), b.pcs)
suspend sqratks( b.pcs, sk, b.cnm)
end
procedure fr2s( file, rank)
# Returns the square number corresponding to "file" and "rank"
# numbers; fails if invalid file and/or rank:
return (0 < (9 > file)) + 8 * (0 < ( 9 > rank)) - 8
end
procedure gamend( b)
# If the position b is at end of game,
# return an ascii string giving the result; otherwise, fail:
local nbn, sk
sk := find( pc2p( "K", b.cmv), b.pcs)
if not movlegal( b, movgen( b, sk)) & not movlegal( b, movgen( b)) then {
if chksqrs( b) then {
if b.cnm[ 1] == "W" then
return "1-0"
else
return "0-1"
}
else
return "1/2-1/2"
}
else if not upto( 'PRQprq', b.pcs) then {
nbn := 0
every upto( 'NBnb', b.pcs) do
nbn +:= 1
if nbn < 2 then
return "1/2-1/2"
}
end
procedure init( )
# init initializes the program:
local whopipe, line, namdelim
# Setup a data table for move generation:
Frinclst := table( )
Frinclst[ "R"] := [ [1, 0], [0, 1], [-1, 0], [0, -1] ]
Frinclst[ "N"] := [ [2, 1], [1, 2], [-1, 2], [-2, 1],
[-2, -1], [-1, -2], [1, -2], [2, -1] ]
Frinclst[ "B"] := [ [1, 1], [-1, 1], [-1, -1], [1, -1] ]
Frinclst[ "Q"] := Frinclst[ "R"] ||| Frinclst[ "B"]
Frinclst[ "K"] := Frinclst[ "Q"]
Frinclst[ "r"] := Frinclst[ "R"]
Frinclst[ "n"] := Frinclst[ "N"]
Frinclst[ "b"] := Frinclst[ "B"]
Frinclst[ "q"] := Frinclst[ "Q"]
Frinclst[ "k"] := Frinclst[ "K"]
# Setup a character set to delimit user names:
namdelim := ~(&letters ++ &digits ++ '_.-')
# Set reminder bell flag to off:
Remind := ""
# Set random number seed:
&random := integer( map( "hxmysz", "hx:my:sz", &clock))
# Get my name from user or "who am I" command and issue greeting:
writes( "Your name (up to 8 letters & digits; default = user name)? ")
line := read( ) | kstop( "can't read user name")
Me := tokens( line, namdelim)
if /Me then {
whopipe := open( "who am i | awk '{print $1}' | sed 's/^.*!//'", "rp")
Me := tokens( read( whopipe), namdelim)
close( \whopipe)
}
if /Me then
write( "Can't get user name from system.")
while /Me do {
writes( "Your name? ")
line := read( ) | kstop( "can't get user name")
Me := tokens( line, namdelim)
}
write( "Welcome, ", Me, ", to Kriegspiel (double blind chess).")
# Prompt user to enter color:
while writes( "Your color (w or b)? ") do {
line := read( ) | kstop( "can't read color")
if find( line[ 1], "WwBb") then
break
}
Mycol := (find( line[ 1], "Ww"), "White") | "Black"
Yrcol := map( Mycol, "WhiteBlack", "BlackWhite")
# Prompt user to enter opponent name:
writes( "Enter opponent's name (default = auto): ")
Yu := tokens( read( ), namdelim) | "auto"
# Prompt user to select "blind" mode, if desired:
writes( "Totally blind mode (default is no)? ")
Blind := find( (tokens( read( )) \ 1)[ 1], "Yy")
# Set communication file names and create my communication file:
if Yu == "auto" then {
Mycname := "/dev/null"
Yrcname := "/dev/null"
}
else {
Mycname := "/tmp/krcom" || Mycol[ 1] || Me
Yrcname := "/tmp/krcom" || Yrcol[ 1] || Yu
remove( Mycname)
system( "/etc/mknod " || Mycname || " p && chmod 644 " ||
Mycname) = 0 | kstop( "can't create my comm file")
}
# Get name of my log file, open it, then remove from directory:
Logname := "/tmp/krlog" || Mycol[ 1] || Me
while /Logfile do {
writes( "Log file name (defaults to ", Logname, ")? ")
line := read( ) | kstop( "can't read log file name")
Logname := tokens( line)
Logfile := open( Logname, "cr")
}
remove( Logname)
# Open our communication files, trying to avoid deadlock:
write( "Attempting to establish communication with ", Yu)
if Mycol == "White" then
Mycomm := open( Mycname, "w") | kstop( "can't open my comm file")
while not (Yrcomm := open( Yrcname)) do {
write( "Still attempting to establish communication")
if system( "sleep 3") ~= 0 then
kstop( "gave up on establishing communications")
}
if Mycol == "Black" then
Mycomm := open( Mycname, "w") | kstop( "can't open my comm file")
# Initialize board and moves:
Bg := board(
"RNBQKBNRPPPPPPPP pppppppprnbqkbnr",
"White", "Black", "W-Q", "W-K", "B-Q", "B-K", &null, 0)
# Initialize set of move tries:
Tries := set( )
write( Logfile, "Kriegspiel game begins ", &dateline)
write( Logfile, Me, " is ", Mycol, "; ", Yu, " is ", Yrcol)
\ Blind & write( Logfile, Me, " is in 'totally blind' mode!")
write( "You have the ", Mycol, " pieces against ", Yu)
\ Blind & write( "You have chosen to play in 'totally blind' mode!")
write( "At the \"Try\" prompt you may type help for assistance.")
write( "Initialization complete; awaiting first white move.")
return
end
procedure kstop( s)
# Clean up and terminate execution with message s:
local logtemp
close( \Mycomm)
remove( \Mycname)
write( \Logfile, "Kriegspiel game ends ", &dateline)
logboard( \ Logfile, \ Bg)
if seek( \Logfile) then {
logtemp := open( Logname, "w") | kstop( "can't open my log file")
every write( logtemp, ! Logfile)
write( "Game log is on file ", Logname)
}
stop( "Kriegspiel stop: ", s)
end
procedure logboard( file, b)
# Print the full board position in b to file:
local f, r, p
write( file, "Current board position:")
write( file, " a b c d e f g h")
every r := 8 to 1 by -1 do {
write( file, "-------------------------")
every writes( file, "|", p2c( p := b.pcs[ fr2s( 1 to 8, r)])[ 1],
pc2p( p, "W"))
write( file, "|", r)
}
write( file, "-------------------------")
writes( file, b.cmv, " to move;")
writes( file, " enp file: ", "abcdefgh"[ \ b.fepp], ";")
writes( file, " castle mvs ", b.caswq || " " || b.caswk || " " ||
b.casbq || " " || b.casbk, ";")
write( file, " half-mvs played ", b.ply)
write( file, "")
end
procedure main( )
local line
# Initialize player names and colors and establish communications:
init( )
# Loop validating our moves and processing opponent responses:
repeat {
while Mycol == Bg.cmv do {
writes( Remind, "Try your (", Me, "'s) move # ",
Bg.ply / 2 + 1, ": ")
line := read( ) | kstop( "player read fail")
write( Mycomm, line)
write( Logfile, Me, " typed: ", line)
line := map( tokens( line)) | ""
case line of {
"" : 0
left( "any", *line) : myany( )
left( "board", *line) : myboard( )
"end" : myend( )
left( "help", *line) : myhelp( )
left( "message", *line) : mymessage( )
left( "remind", *line) : myremind( )
default : mytry( line)
}
}
while Yrcol == Bg.cmv do {
if Yu == "auto" then
line := automov( )
else
line := read( Yrcomm) | kstop( "opponent read fail")
write( Logfile, Yu, " typed: ", line)
line := map( tokens( line)) | ""
case line of {
"" : 0
left( "any", *line) : yrany( )
left( "board", *line) : 0
"end" : yrend( )
left( "help", *line) : 0
left( "message", *line) : yrmessage( )
left( "remind", *line) : 0
default : yrtry( line)
}
}
}
end
procedure movgen( b, s)
# movgen generates the pseudo-legal moves in board position b from the
# piece on square s; if s is unspecified all pieces are considered.
# Note: pseudo-legal here means that the legality of the move has been
# determined up to the question of whether it leaves the moving side's
# king in check:
local r, f, p, snfr, m, fto, rto, sl, sh,
sto, fril, rp, r2, r4, r5, r7, ps
ps := b.pcs
sl := (\s | 1)
sh := (\s | 64)
every s := sl to sh do {
if p2c( p := ps[ s]) == b.cmv then {
f := s2f( s)
r := s2r( s)
snfr := s2sn( s)
# Pawn moves:
if find( p, "Pp") then {
if p == "P" then {
rp := 1; r2 := 2; r4 := 4; r5 := 5; r7 := 7
}
else {
rp := -1; r2 := 7; r4 := 5; r5 := 4; r7 := 2
}
if ps[ sto := fr2s( f, r + rp)] == " " then {
m := "P" || snfr || s2sn( sto)
if r = r7 then
suspend m || ! "RNBQ"
else {
suspend m
if r = r2 & ps[ sto := fr2s( f, r4)] == " " then
suspend "P" || snfr || s2sn( sto)
}
}
every fto := 0 < (9 > (f - 1 to f + 1 by 2)) do {
m := "P" || snfr ||
s2sn( sto := fr2s( fto, r + rp)) || ":"
if p2c( ps[ sto]) == b.cnm then {
if r = r7 then
every suspend m || ! "RNBQ"
else
suspend m
}
if r = r5 & fto = \ b.fepp then
suspend m || "ep"
}
}
# Sweep piece (rook, bishop, queen) moves:
else if find( p, "RBQrbq") then {
every fril := ! Frinclst[ p] do {
fto := f
rto := r
while sto := fr2s( fto +:= fril[ 1], rto +:= fril[ 2]) do {
if ps[ sto] == " " then
suspend pc2p( p, "W") || snfr || s2sn( sto)
else {
if p2c( ps[ sto]) == b.cnm then
suspend pc2p( p, "W") ||
snfr || s2sn( sto) || ":"
break
}
}
}
}
# Knight and king moves:
else if find( p, "KNkn") then {
every fril := ! Frinclst[ p] do {
if sto := fr2s( f + fril[ 1], r + fril[ 2]) then {
if p2c( ps[ sto]) == b.cnm then
suspend pc2p( p, "W") ||
snfr || s2sn( sto) || ":"
else if ps[ sto] == " " then
suspend pc2p( p, "W") || snfr || s2sn( sto)
}
}
if p == "K" then {
if (b.caswq ~== "", ps[ sn2s( "b1") : sn2s( "e1")] == " ",
not sqratks( ps, sn2s( "d1"), "Black"),
not sqratks( ps, sn2s( "e1"), "Black")) then
suspend "Ke1c1cas"
if (b.caswk ~== "", ps[ sn2s( "f1") : sn2s( "h1")] == " ",
not sqratks( ps, sn2s( "f1"), "Black"),
not sqratks( ps, sn2s( "e1"), "Black")) then
suspend "Ke1g1cas"
}
else if p == "k" then {
if (b.casbq ~== "", ps[ sn2s( "b8") : sn2s( "e8")] == " ",
not sqratks( ps, sn2s( "d8"), "White"),
not sqratks( ps, sn2s( "e8"), "White")) then
suspend "Ke8c8cas"
if (b.casbk ~== "", ps[ sn2s( "f8") : sn2s( "h8")] == " ",
not sqratks( ps, sn2s( "f8"), "White"),
not sqratks( ps, sn2s( "e8"), "White")) then
suspend "Ke8g8cas"
}
}
}
}
end
procedure movlegal( b, m)
# Tests move m on board b and, if it does not leave the moving color in
# check, returns m; fails otherwise:
local ps, sfr, sto, sk
ps := b.pcs
sfr := sn2s( m[ 2:4])
sto := sn2s( m[ 4:6])
# Castling move:
if m[ 6:9] == "cas" then {
if m == "Ke1c1cas" then
return not sqratks( ps, sn2s( "c1"), "Black") & m
if m == "Ke1g1cas" then
return not sqratks( ps, sn2s( "g1"), "Black") & m
if m == "Ke8c8cas" then
return not sqratks( ps, sn2s( "c8"), "White") & m
if m == "Ke8g8cas" then
return not sqratks( ps, sn2s( "g8"), "White") & m
}
# Enpassant pawn capture:
if m[ 6:9] == ":ep" then
ps[ fr2s( s2f( sto), s2r( sfr))] := " "
# All non-castling moves:
ps[ sto] := ps[ sfr]
ps[ sfr] := " "
sk := find( pc2p( "K", b.cmv), ps)
return not sqratks( ps, sk, b.cnm) & m
end
procedure movmake( b, m)
# Makes move m on board b:
local sfr, sto
if m == "Ke1c1cas" then {
b.pcs[ sn2s( "a1")] := " "
b.pcs[ sn2s( "d1")] := "R"
}
else if m == "Ke1g1cas" then {
b.pcs[ sn2s( "h1")] := " "
b.pcs[ sn2s( "f1")] := "R"
}
else if m == "Ke8c8cas" then {
b.pcs[ sn2s( "a8")] := " "
b.pcs[ sn2s( "d8")] := "r"
}
else if m == "Ke8g8cas" then {
b.pcs[ sn2s( "h8")] := " "
b.pcs[ sn2s( "f8")] := "r"
}
sfr := sn2s( m[ 2:4])
sto := sn2s( m[ 4:6])
b.pcs[ sto] := b.pcs[ sfr]
b.pcs[ sfr] := " "
if find( m[ -1], "rnbqRNBQ") then
b.pcs[ sto] := pc2p( m[ -1], b.cmv)
if sfr = sn2s( "e1") then b.caswq := b.caswk := ""
if sfr = sn2s( "e8") then b.casbq := b.casbk := ""
if (sfr | sto) = sn2s( "a1") then b.caswq := ""
if (sfr | sto) = sn2s( "h1") then b.caswk := ""
if (sfr | sto) = sn2s( "a8") then b.casbq := ""
if (sfr | sto) = sn2s( "h8") then b.casbk := ""
if m[ 6:9] == ":ep" then
b.pcs[ fr2s( s2f( sto), s2r( sfr))] := " "
b.fepp := &null
if m[ 1] == "P" & abs( s2r( sfr) - s2r( sto)) = 2 then
b.fepp := s2f( sto)
b.ply +:= 1
b.cmv :=: b.cnm
end
procedure movtry( m)
# Tests whether the typed move m is legal in the global board Bg and, if so,
# returns the corresponding move returned from movgen (which will be in a
# different format with piece letter prefix, etc.). Fails if m is not
# legal. Note that if the any flag is set, only captures by pawns are
# allowed:
local ml, mt, sfr, sto
mt := map( tokens( m)) | ""
if mt == "o-o" then
mt := (Bg.cmv == "White", "e1g1") | "e8g8"
else if mt == "o-o-o" then
mt := (Bg.cmv == "White", "e1c1") | "e8c8"
sfr := sn2s( mt[ 1:3]) | fail
sto := sn2s( mt[ 3:5]) | fail
if find( mt[ 5], "rnbq") then
mt[ 5] := map( mt[ 5], "rnbq", "RNBQ")
else mt := mt[ 1:5] || "Q"
if \ Any then {
if Bg.pcs[ sfr] ~== pc2p( "P", Bg.cmv) then fail
every ml := movgen( Bg, sfr) do {
if ml[ 4:7] == mt[ 3:5] || ":" then {
if find( ml[ -1], "RNBQ") then
ml[ -1] := mt[ 5]
return movlegal( Bg, ml)
}
}
}
else {
every ml := movgen( Bg, sfr) do {
if ml[ 4:6] == mt[ 3:5] then {
if find( ml[ -1], "RNBQ") then
ml[ -1] := mt[ 5]
return movlegal( Bg, ml)
}
}
}
end
procedure myany( )
# Process my any command.
# Check for captures by pawns and inform the player of any, and, if
# at least one, set Any flag to require that player try only captures
# by pawns:
local m, p, s
if \ Any then {
write( "You have already asked 'Any' and received yes answer!")
fail
}
p := pc2p( "P", Bg.cmv)
if movlegal( Bg, 1( m := movgen( Bg, 1(s := 9 to 56, Bg.pcs[ s] == p)),
m[ 6] == ":")) then {
write( "Yes; you must now make a legal capture by a pawn.")
Any := "Yes"
}
else
write( "No.")
end
procedure myboard( )
# Process my board command by printing the board but omitting the
# opponent's pieces and the enpassant status; a count of pieces of
# both colors is printed:
# Note: no board printed in blind mode.
local f, r, p, nw, nb
\ Blind & write( "Sorry; no board printout in blind mode!") & fail
write( "Current board position (your pieces only):")
write( " a b c d e f g h")
every r := 8 to 1 by -1 do {
write( "-------------------------")
every f := 1 to 8 do {
if (p2c( p := Bg.pcs[ fr2s( f, r)])) == Mycol then
writes( "|", Mycol[ 1], pc2p( p, "W"))
else
writes( "| ")
}
write( "|", r)
}
write( "-------------------------")
writes( Bg.cmv, " to move; ")
writes( "castle mvs ", (Mycol == "White", Bg.caswq || " " || Bg.caswk) |
Bg.casbq || " " || Bg.casbk)
write( "; half-mvs played ", Bg.ply)
nw := nb := 0
every upto( &ucase, Bg.pcs) do nw +:= 1
every upto( &lcase, Bg.pcs) do nb +:= 1
write( nw, " White pieces, ", nb, " Black.")
write( "")
end
procedure myend( )
# Process my end command:
kstop( "by " || Me)
end
procedure myhelp( )
# Process my help command:
write( "")
write( "This is \"Kriegspiel\" (war play), a game of chess between two")
write( "opponents who do not see the location of each other's pieces.")
write( "Note: the moves of the special opponent 'auto' are played by the")
write( "program itself. Currently, auto plays at a low novice level.")
write( "When it is your turn to move, you will be prompted to type")
write( "a move attempt or one of several commands. To try a move,")
write( "type the from and to squares in algebraic notation, as in: e2e4")
write( "or b8c6. Castling may be typed as o-o, o-o-o, or as the move")
write( "of the king, as in: e8g8. Pawn promotions should look like")
write( "d7d8Q. If omitted, the piece promoted to is assumed to be a")
write( "queen. Letters may be in upper or lower case. If the move is")
write( "legal, it stands, and the opponent's response is awaited.")
write( "If the move is illegal, the program will prompt you to")
write( "try again. If the move is illegal because of the opponent's")
write( "position but not impossible based on the position of your")
write( "pieces, then your opponent will be informed that you tried")
write( "an illegal move (note: this distinction between illegal and")
write( "impossible is somewhat tricky and the program may, in some")
write( "cases, not get it right). The program will announce the")
write( "result and terminate execution when the game is over. You may")
write( "then inspect the game log file which the program generated.")
write( "")
writes( "Type empty line for more or 'q' to return from help: ")
if map( read( ))[ 1] == "q" then
fail
write( "")
write( "The program will let you know of certain events that take place")
write( "during the game. For each capture move, both players will be")
write( "informed of the location of the captured piece. The opponent")
write( "will be informed of a pawn promotion but not of the piece")
write( "promoted to or the square on which the promotion takes place.")
write( "When a player gives check, both players will be informed of the")
write( "event and of some information about the direction from which the")
write( "check arises, as in: check on the rank', 'check on the file',")
write( "'check on the + diagonal', 'check on the - diagonal', or 'check")
write( "by a knight'. For a double check, both directions are given.")
write( "(A + diagonal is one on which file letters and rank numbers")
write( "increase together, like a1-h8, and a - diagonal is one in which")
write( "file letters increase while rank numbers decrease, as in a8-h1).")
write( "")
write( "Note: if you have selected the 'blind' mode, then you will")
write( "receive no information about checks, captures, or opponent")
write( "'any' or illegal move tries; nor will you be able to print")
write( "the board. You will not even be told when your own pieces")
write( "are captured. Except for answers to 'any' commands, the")
write( "program will inform you only of when you have moved, when")
write( "your opponent has moved, and of the result at end of game.")
write( "")
writes( "Type empty line for more or 'q' to return from help: ")
if map( read( ))[ 1] == "q" then
fail
write( "")
write( "Description of commands; note: upper and lower case letters")
write( "are not distinguished, and every command except 'end' may be")
write( "abbreviated.")
write( "")
write( "any")
write( "")
write( "The 'any' command is provided to speed up the process of trying")
write( "captures by pawns. Since pawns are the only pieces that capture")
write( "in a different manner from the way they ordinarily move, it is")
write( "often useful to try every possible capture, since such a move")
write( "can only be legal if it in fact captures something. Since the")
write( "process of trying the captures can be time-consuming, the 'any'")
write( "command is provided to signal your intent to try captures by")
write( "pawns until you find a legal one. The program will tell you if")
write( "you have at least one. If you do then you must try captures by")
write( "pawns (in any order) until you find a legal one. Note that the")
write( "opponent will be informed of your plausible 'any' commands (that")
write( "is, those that are not impossible because you have no pawns on")
write( "the board).")
write( "")
writes( "Type empty line for more or 'q' to return from help: ")
if map( read( ))[ 1] == "q" then
fail
write( "")
write( "board")
write( "")
write( "The 'board' command prints the current position of your")
write( "pieces only, but also prints a count of pieces of both sides.")
write( "Note: 'board' is disallowed in blind mode.")
write( "")
write( "end")
write( "")
write( "Then 'end' command informs the program and your")
write( "opponent of your decision to terminate the game")
write( "immediately.")
write( "")
write( "help")
write( "")
write( "The 'help' command prints this information.")
write( "")
writes( "Type empty line for more or 'q' to return from help: ")
if map( read( ))[ 1] == "q" then
fail
write( "")
write( "message")
write( "")
write( "The 'message' command allows you to send a one-line")
write( "message to your opponent. Your opponent will be prompted")
write( "for a one-line response. 'message' may be useful for such")
write( "things as witty remarks, draw offers, etc.")
write( "")
write( "remind")
write( "")
write( "The 'remind' command turns on (if off) or off (if on) the")
write( "bell that is rung when the program is ready to accept your")
write( "move or command. The bell is initially off.")
write( "")
end
procedure mymessage( )
# Process my message command:
local line
write( "Please type a one-line message:")
line := read( ) | kstop( "can't read message")
write( Mycomm, line)
write( Logfile, line)
write( "Awaiting ", Yu, "'s response")
if Yu == "auto" then
line := "I'm just your auto opponent."
else
line := read( Yrcomm) | kstop( "can't read message response")
write( Yu, " answers: ", line)
write( Logfile, line)
end
procedure myremind( )
# Process my remind command:
if Remind == "" then
Remind := "\^g"
else
Remind := ""
end
procedure mytry( mt)
# Process my move try mt:
local ml, result
if ml := movtry( mt) then {
Lmv := ml
write( Me, " (", Mycol, ") has moved.")
write( Logfile, Me, "'s move ", Bg.ply / 2 + 1, " is ", ml)
/ Blind & write( Me, " captures on ", s2sn( sqrcap( Bg, ml)))
movmake( Bg, ml)
/ Blind & saycheck( )
Any := &null
Tries := set( )
if result := gamend( Bg) then {
write( "Game ends; result: ", result)
write( Logfile, "Result: ", result)
kstop( "end of game")
}
}
else
write( "Illegal move, ", Me, "; try again:")
end
procedure p2c( p)
# Returns "White" if p is white piece code ("PRNBQK"), "Black"
# if p is black piece code ("prnbqk"), and " " if empty square
# (" "):
if find( p, "PRNBQK") then
return "White"
else if find( p, "prnbqk") then
return "Black"
else
return " "
end
procedure pc2p( p, c)
# Returns the piece letter for the piece of type p but color c;
# returns " " if p == " ". Thus pc2p( "R", "Black") == "r".
# c may be abbreviated to "W" or "B":
if c[ 1] == "W" then
return map( p, "prnbqk", "PRNBQK")
else
return map( p, "PRNBQK", "prnbqk")
end
procedure s2f( square)
# Returns the file number of the square number "square"; fails
# if invalid square number:
return ( (0 < ( 65 > integer( square))) - 1) % 8 + 1
end
procedure s2r( square)
# Returns the rank number of the square number "square"; fails
# if invalid square number:
return ( (0 < ( 65 > integer( square))) - 1) / 8 + 1
end
procedure s2sn( square)
# Returns the algebraic square name corresponding to square number
# "square"; fails if invalid square number:
return "abcdefgh"[ s2f( square)] || string( s2r( square))
end
procedure saycheck( )
# Announce checks, if any, in global board Bg:
local s, sk
sk := find( pc2p( "K", Bg.cmv), Bg.pcs)
every s := chksqrs( Bg) do {
writes( (Mycol == Bg.cnm, Me) | Yu, " checks ")
if s2r( s) == s2r( sk) then
write( "on the rank.")
else if s2f( s) == s2f( sk) then
write( "on the file.")
else if ( s2f( s) - s2f( sk)) = ( s2r( s) - s2r( sk)) then
write( "on the + diagonal.")
else if ( s2f( s) - s2f( sk)) = ( s2r( sk) - s2r( s)) then
write( "on the - diagonal.")
else
write( "by knight.")
}
end
procedure sn2s( sn)
# Returns the square number corresponding to the algebraic square
# name sn; examples: sn2s( "a1") = 1, sn2s( "b1") = 2, sn2s( "h8") = 64.
# Fails if invalid square name:
return find( sn[ 1], "abcdefgh") + 8 * (0 < (9 > integer( sn[ 2]))) - 8
end
procedure sqratks( ps, s, c)
# Generates the numbers of squares of pieces of color c that "attack"
# square s in board piece array ps; fails if no such squares:
local file, rank, rfr, sfr, fril, p, ffr
file := s2f( s)
rank := s2r( s)
# Check for attacks from pawns:
rfr := (c == "White", rank - 1) | rank + 1
every sfr := fr2s( file - 1 to file + 1 by 2, rfr) do {
if ps[ sfr] == pc2p( "P", c) then
suspend sfr
}
# Check for attack from king or knights:
every fril := ! Frinclst[ p := ("K" | "N")] do {
if sfr := fr2s( file + fril[ 1], rank + fril[ 2]) then {
if ps[ sfr] == pc2p( p, c) then
suspend sfr
}
}
# Check for attacks from sweep (rook and bishop) directions:
every fril := ! Frinclst[ p := ("R" | "B")] do {
ffr := file
rfr := rank
while sfr := fr2s( ffr +:= fril[ 1], rfr +:= fril[ 2]) do {
if ps[ sfr] ~== " " then {
if ps[ sfr] == pc2p( p | "Q", c) then
suspend sfr
break
}
}
}
end
procedure sqrcap( b, m)
# Returns square of piece captured by move m in board b; fails if m
# not a capture:
local fto, rfr
if m[ 6:9] == ":ep" then {
fto := find( m[ 4], "abcdefgh")
rfr := integer( m[ 3])
return fr2s( fto, rfr)
}
else if m[ 6] == ":" then
return sn2s( m[ 4:6])
end
procedure tokens( s, d)
# Generate tokens from left to right in string s given delimiters in cset
# d, where a token is a contiguous string of 1 or more characters not in
# d bounded by characters in d or the left or right end of s.
# d defaults to ' \t'.
s := string( s) | fail
d := (cset( d) | ' \t')
s ? while tab( upto( ~d)) do
suspend( tab( many( ~d)) \ 1)
end
procedure yrany( )
# Process opponent's any command:
local m, p, s
if \ Any then fail
p := pc2p( "P", Bg.cmv)
if not find( p, Bg.pcs) then fail
/ Blind & writes( Yu, " asked 'any' and was told ")
if movlegal( Bg, 1( m := movgen( Bg, 1(s := 9 to 56, Bg.pcs[ s] == p)),
m[ 6] == ":")) then {
/ Blind & write( "yes.")
Any := "Yes"
}
else
/ Blind & write( "no.")
end
procedure yrend( )
# Process opponent's end command:
write( "Game terminated by ", Yu, ".")
kstop( "by " || Yu)
end
procedure yrmessage( )
# Process opponent's message command:
local line
line := read( Yrcomm) | kstop( "can't read opponent message")
write( "Message from ", Yu, ": ", line)
write( Logfile, line)
write( "Please write a one-line response:")
line := read( ) | kstop( "can't read response to opponent message")
write( Mycomm, line)
write( Logfile, line)
end
procedure yrtry( mt)
# Process opponent move try (or other type-in!) mt:
local ml, result, s, mtr, b, po, sfr, sto
if ml := movtry( mt) then {
Lmv := ml
write( Yu, " (", Yrcol, ") has moved.")
write( Logfile, Yu, "'s move ", Bg.ply / 2 + 1, " is ", ml)
/ Blind & write( Yu, " captures on ", s2sn( sqrcap( Bg, ml)))
if find( ml[ -1], "RNBQ") then
/ Blind & write( Yu, " promotes a pawn.")
movmake( Bg, ml)
/ Blind & saycheck( )
Any := &null
Tries := set( )
if result := gamend( Bg) then {
write( "Game ends; result: ", result)
write( Logfile, "Result: ", result)
kstop( "end of game")
}
}
# Inform Me if opponent move illegal but not impossible. Don't inform
# if illegal move already tried. Note: distinction between "illegal"
# and "impossible" is tricky and may not always be made properly.
# Note: don't bother informing if in blind mode.
else {
\ Blind & fail
mtr := map( tokens( mt)) | ""
if mtr == "o-o" then
mtr := (Bg.cmv == "White", "e1g1") | "e8g8"
else if mtr == "o-o-o" then
mtr := (Bg.cmv == "White", "e1c1") | "e8c8"
mtr := mtr[ 1:5] | fail
if member( Tries, mtr) then fail
insert( Tries, mtr)
b := copy( Bg)
po := (b.cmv[ 1] == "W", "prnbqk") | "PRNBQK"
b.pcs := map( b.pcs, po, " ")
sfr := sn2s( mtr[ 1:3]) | fail
sto := sn2s( mtr[ 3:5]) | fail
if sn2s( movgen( b, sfr)[ 4:6]) = sto then
/ Any & write( Yu, " tried illegal move.")
else {
b.pcs[ sto] := pc2p( "P", b.cnm)
if sn2s( movgen( b, sfr)[ 4:6]) = sto then
write( Yu, " tried illegal move.")
}
}
end
##########
kross.icn
############################################################################
#
# Name: kross.icn
#
# Title: Diagram character intersections of strings
#
# Author: Ralph E. Griswold
#
# Date: May 9, 1989
#
############################################################################
#
# This program procedure accepts pairs of strings on successive lines.
# It diagrams all the intersections of the two strings in a common
# character.
#
############################################################################
procedure main()
local line, j
while line := read() do {
kross(line,read())
}
end
procedure kross(s1,s2)
local j, k
every j := upto(s2,s1) do
every k := upto(s1[j],s2) do
xprint(s1,s2,j,k)
end
procedure xprint(s1,s2,j,k)
write()
every write(right(s2[1 to k-1],j))
write(s1)
every write(right(s2[k+1 to *s2],j))
end
##########
kwic.icn
############################################################################
#
# Name: kwic.icn
#
# Title: Produce keywords in context
#
# Author: Stephen B. Wampler, modified by Ralph E. Griswold
#
# Date: October 11, 1988
#
############################################################################
#
# This is a simple keyword-in-context (KWIC) program. It reads from
# standard input and writes to standard output. The "key" words are
# aligned in column 40, with the text shifted as necessary. Text shifted
# left is truncated at the left. Tabs and other characters whose "print width"
# is less than one may not be handled properly.
#
# Some noise words are omitted (see "exceptions" in the program text).
# If a file named except.wrd is open and readable i nthe current directory,
# the words in it are used instead.
#
# This program is pretty simple. Possible extensions include ways
# of specifying words to be omitted, more flexible output formatting, and
# so on. Another "embellisher's delight".
#
############################################################################
global line, loc, exceptions
procedure main()
local exceptfile
if exceptfile := open("except.wrd") then {
exceptions := set()
every insert(exceptions, lcword(exceptfile))
close(exceptfile)
}
else
exceptions := set(["or", "in", "the", "to", "of", "on", "a",
"an", "at", "and", "i", "it"])
every write(kwic(&input))
end
procedure kwic(file)
local index, word
# Each word, in lowercase form, is a key in the table "index".
# The corresponding values are lists of the positioned lines
# for that word. This method may use an impractically large
# amount of space for large input files.
index := table()
every word := lcword(file) do {
if not member(exceptions,word) then {
/index[word] := []
index[word] := put(index[word],position())
}
}
# Before the new sort options, it was done this way -- the code preserved
# as an example of "generators in action".
# suspend !((!sort(index,1))[2])
index := sort(index,3)
while get(index) do
suspend !get(index)
end
procedure lcword(file)
static chars
initial chars := &ucase ++ &lcase ++ '\''
every line := !file do
line ? while tab(loc := upto(chars)) do
suspend map(tab(many(chars)) \ 1)
end
procedure position()
local offset
# Note that "line" and ""loc" are global.
offset := 40 - loc
if offset >= 0 then return repl(" ",offset) || line
else return line[-offset + 1:0]
end
##########
labels.icn
############################################################################
#
# Name: labels.icn
#
# Title: Format mailing labels
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program produces labels using coded information taken
# from the input file. In the input file, a line beginning with #
# is a label header. Subsequent lines up to the next header or
# end-of-file are accumulated and output so as to be centered hor-
# izontally and vertically on label forms. Lines beginning with *
# are treated as comments and are ignored.
#
# Options: The following options are available:
#
# -c n Print n copies of each label.
#
# -s s Select only those labels whose headers contain a char-
# acter in s.
#
# -t Format for curved tape labels (the default is to format
# for rectangular mailing labels).
#
# -w n Limit line width to n characters. The default width is
# 40.
#
# -l n Limit the number of printed lines per label to n. The
# default is 8.
#
# -d n Limit the depth of the label to n. The default is 9 for
# rectangular labels and 12 for tape labels (-t).
#
# -f Print the first line of each selected entry instead of
# labels.
#
# Options are processed from left to right. If the number of
# printed lines is set to a value that exceeds the depth of the
# label, the depth is set to the number of lines. If the depth is
# set to a value that is less than the number of printed lines, the
# number of printed lines is set to the depth. Note that the order
# in which these options are specified may affect the results.
#
# Printing Labels: Label forms should be used with a pin-feed pla-
# ten. For mailing labels, the carriage should be adjusted so that
# the first character is printed at the leftmost position on the
# label and so that the first line of the output is printed on the
# topmost line of the label. For curved tape labels, some experi-
# mentation may be required to get the text positioned properly.
#
# Diagnostics: If the limits on line width or the number of lines
# per label are exceeded, a label with an error message is written
# to standard error output.
#
############################################################################
#
# Links: options
#
# See also: zipsort
#
############################################################################
link options
global line, lsize, repet, llength, ldepth, first, opts
procedure main(args)
local selectors, y, i
line := ""
selectors := '#'
lsize := 9
ldepth := 8
llength := 40
repet := 1
i := 0
opts := options(args,"cfd+l+s:tw+")
if \opts["f"] then first := 1
selectors := cset(\opts["s"])
if \opts["t"] then {
lsize := 12
if ldepth > lsize then ldepth := lsize
}
llength := nonneg("w")
if ldepth := nonneg("l") then {
if lsize < ldepth then lsize := ldepth
}
if lsize := nonneg("d") then {
if ldepth > lsize then ldepth := lsize
}
repet := nonneg("c")
repeat { # processing loop
if line[1] == "#" & upto(selectors,line)
then obtain() else {
line := read() | break
}
}
end
# Obtain next label
#
procedure obtain()
local label, max
label := []
max := 0
line := ""
while line := read() do {
if line[1] == "*" then next
if line[1] == "#" then break
if \first then {
write(line)
return
}
else put(label,line)
max <:= *line
if *label > ldepth then {
error(label[1],1)
return
}
if max > llength then {
error(label[1],2)
return
}
}
every 1 to repet do format(label,max)
end
# Format a label
#
procedure format(label,width)
local j, indent
indent := repl(" ",(llength - width) / 2)
j := lsize - *label
every 1 to j / 2 do write()
every write(indent,!label)
every 1 to (j + 1) / 2 do write()
end
# Issue label for an error
#
procedure error(name,type)
static badform
initial badform := list(lsize)
case type of {
1: badform[3] := " **** too many lines"
2: badform[3] := " **** line too long"
}
badform[1] := name
every write(&errout,!badform)
end
procedure nonneg(s)
s := \opts[s] | fail
return 0 < integer(s) | stop("-",s," needs postive numeric parameter")
end
##########
lam.icn
############################################################################
#
# Name: lam.icn
#
# Title: Laminate files
#
# Author: Thomas R. Hicks
#
# Date: June 10, 1988
#
############################################################################
#
# This program laminates files named on the command line onto
# the standard output, producing a concatenation of corresponding
# lines from each file named. If the files are different lengths,
# empty lines are substituted for missing lines in the shorter
# files. A command line argument of the form - s causes the string
# s to be inserted between the concatenated file lines.
#
# Each command line argument is placed in the output line at the
# point that it appears in the argument list. For example, lines
# from file1 and file2 can be laminated with a colon between each
# line from file1 and the corresponding line from file2 by the com-
# mand
#
# lam file1 -: file2
#
# File names and strings may appear in any order in the argument
# list. If - is given for a file name, standard input is read at
# that point. If a file is named more than once, each of its lines
# will be duplicated on the output line, except that if standard
# input is named more than once, its lines will be read alter-
# nately. For example, each pair of lines from standard input can
# be joined onto one line with a space between them by the command
#
# lam - "- " -
#
# while the command
#
# lam file1 "- " file1
#
# replicates each line from file1.
#
############################################################################
#
# Links: usage
#
############################################################################
link usage
global fndxs
procedure main(a)
local bufs, i
bufs := list(*a)
fndxs := []
if (*a = 0) | a[1] == "?" then Usage("lam file [file | -string]...")
every i := 1 to *a do {
if a[i] == "-" then {
a[i] := &input
put(fndxs,i)
}
else if match("-",a[i]) then {
bufs[i] := a[i][2:0]
a[i] := &null
}
else {
if not (a[i] := open(a[i])) then
stop("Can't open ",a[i])
else put(fndxs,i)
}
}
if 0 ~= *fndxs then lamr(a,bufs) else Usage("lam file [file | -string]...")
end
procedure lamr(args,bufs)
local i, j
every i := !fndxs do
bufs[i] := (read(args[i]) | &null)
while \bufs[!fndxs] do {
every j := 1 to *bufs do
writes(\bufs[j])
write()
every i := !fndxs do
bufs[i] := (read(args[i]) | &null)
}
end
##########
latexidx.icn
############################################################################
#
# Name: latexidx.icn
#
# Title: Process LaTeX .idx file
#
# Author: David S. Cargo
#
# Date: April 19, 1989
#
############################################################################
#
# Input:
#
# A latex .idx file containing the \indexentry lines.
#
# Output:
#
# \item lines sorted in order by entry value,
# with page references put into sorted order.
#
# Processing:
#
# While lines are available from standard input
# Read a line containing an \indexentry
# Form a sort key for the indexentry
# If there is no table entry for it
# Then create a subtable for it and assign it an initial value
# If there is a table entry for it,
# But not an subtable entry for the actual indexentry
# Then create an initial page number set for it
# Otherwise add the page number to the corresponding page number set
# Sort the table of subtables by sort key value
# For all subtables in the sorted list
# Sort the subtables by indexentry values
# For all the indexentries in the resulting list
# Sort the set of page references
# Write an \item entry for each indexentry and the page references
#
# Limitations:
#
# Length of index handled depends on implementation limits of memory alloc.
# Page numbers must be integers (no roman numerals). Sort key formed by
# mapping to lower case and removing leading articles (a separate function
# is used to produce the sort key, simplifying customization) -- otherwise
# sorting is done in ASCII order.
#
############################################################################
procedure main() # no parameters, reading from stdin
local key_table, s, page_num, itemval, key, item_list, one_item
local page_list, refs
key_table := table() # for items and tables of page sets
while s := read() do # read strings from standard input
{
# start with s = "\indexentry{item}{page}"
# save what's between the opening brace and the closing brace,
# and reverse it
s := reverse(s[upto('{',s)+1:-1])
# giving s = "egap{}meti"
# reversing allows extracting the page number first, thereby allowing
# ANYTHING to be in the item field
# grab the "egap", reverse it, convert to integer, convert to set
# in case of conversion failure, use 0 as the default page number
page_num := set([integer(reverse(s[1:upto('{',s)])) | 0])
# the reversed item starts after the first closing brace
# grab the "meti", reverse it
itemval := reverse(s[upto('}', s)+1:0])
# allow the sort key to be different from the item
# reform may be customized to produce different equivalence classes
key := reform(itemval)
# if the assigned value for the key is null
if /key_table[key]
then
{
# create a subtable for the key and give it its initial value
key_table[key] := table()
key_table[key][itemval] := page_num
}
# else if the assigned value for the itemval is null
# (e. g., when the second itemval associated with a key is found)
else if /key_table[key][itemval]
# give it its initial value
then key_table[key][itemval] := page_num
# otherwise just add it to the existing page number set
else key_table[key][itemval] ++:= page_num
}
# now that all the input has been read....
# sort keys and subtables by key value
key_table := sort(key_table, 3)
# loop, discarding the sort keys
while get(key_table) do
{
# dequeue and sort one subtable into a list
# sort is strictly by ASCII order within the equivalence class
item_list := sort(get(key_table), 3)
# loop, consuming the item and the page number sets as we go
while one_item := get(item_list) do
{
# convert the page number set into a sorted list
page_list := sort(get(item_list))
# dequeue first integer and convert to string
refs := string(get(page_list))
# dequeue rest of page nums and append
while (refs ||:= ", " || string(get(page_list)))
write("\\item ", one_item, " ", refs)
}
}
return
end
# reform - modify the item to enforce sort order appropriately
# This could do much more. For example it could strip leading braces,
# control sequences, quotation marks, etc. It doesn't. Maybe later.
procedure reform(item)
item := map(item) # map to lowercase
# drop leading article if present
if match("a ", item) then return item[3:0]
if match("an ", item) then return item[4:0]
if match("the ", item) then return item[5:0]
return item
end
##########
linden.icn
############################################################################
#
# Name: linden.icn
#
# Title: Generate sentences in Lindenmayer system
#
# Author: Ralph E. Griswold
#
# Date: October 11, 1988
#
############################################################################
#
# This program reads in a 0L-system (Lindenmayer system) consisting of
# rewriting rules in which a string is rewritten with every character
# replaced simultaneously (conpectually) by a specified string of
# symbols.
#
# The last line of input consists of an initial string followed by a colon
# (which cannot be a symbol in the initial string) and the number of times
# the rewriting rules are to be applied. An example is
#
# 1->2#3
# 2->2
# 3->2#4
# 4->504
# 5->6
# 6->7
# 7->8(1)
# 8->8
# (->(
# )->)
# #->#
# 0->0
# 1:14
#
# Here, the initial string is "1" and the rewriting rules are to be
# applied 14 times.
#
# If no rule is provided for a character, the character is not changed
# by rewriting. Thus, the example above can be expressed more concisely
# as
#
# 1->2#3
# 3->2#4
# 4->504
# 5->6
# 6->7
# 7->8(1)
# 1:14
#
# If -a is given on the command line, each rewriting is written out.
# Otherwise, only the final result is written out.
#
# Reference:
#
# Formal Languages, Arto Salomaa, Academic Press, 1973. pp. 234-252.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global rewrite
procedure main(args)
local line, count, axiom, detail, opts, i, result, s
rewrite := table()
# What follows is a trick. It takes advantage of the fact that Icon
# functions are first-class data objects and that function invocation
# and mutual evaluation have the same syntax. If -a is specified,
# the value of "detail" becomes the function for writing and the
# value of "write" becomes 1. See below.
detail := 1
opts := options(args,"a")
if \opts["a"] then detail :=: write
while line := read() do
if line[2:4] == "->" then rewrite[line[1]] := line[4:0]
else {
i := upto(':',line) # asssume last line
result := line[1:i]
count := line[i+1:0]
break
}
detail(result)
every result := detail(linden(result)) \ count
write(result) # write the last result if not already written
end
procedure linden(pstring)
local c, s
repeat {
s := ""
every c := !pstring do
s ||:= (\rewrite[c] | c)
suspend pstring := s
}
end
##########
lisp.icn
############################################################################
#
# Name: lisp.icn
#
# Title: Lips interpreter
#
# Author: Stephen B. Wampler
#
# Date: August 7, 1989
#
############################################################################
#
# This program is a simple interpreter for pure Lisp.
#
# The syntax and semantics are based on EV-LISP, as described in
# Laurent Siklossy's "Let's Talk LISP" (Prentice-Hall, 1976, ISBN
# 0-13-532762-8). Functions that have been predefined match those
# described in Chapters 1-4 of the book.
#
# No attempt at improving efficiency has been made, this is
# rather an example of how a simple LISP interpreter might be
# implemented in Icon.
#
# The language implemented is case-insensitive.
#
# It only reads enough input lines at one time to produce at least
# one LISP-expression, but continues to read input until a valid
# LISP-expression is found.
#
# Errors:
#
# fails on EOF; fails with error message if current
# input cannot be made into a valid LISP-expression (i.e. more
# right than left parens).
#
############################################################################
global words, # table of variable atoms
T, NIL # universal constants
global trace_set # set of currently traced functions
record prop(v,f) # abbreviated propery list
### main interpretive loop
#
procedure main()
local sexpr
initialize()
every sexpr := bstol(getbs()) do
PRINT([EVAL([sexpr])])
end
## (EVAL e) - the actual LISP interpreter
#
procedure EVAL(l)
local fn, arglist, arg
l := l[1]
if T === ATOM([l]) then { # it's an atom
if T === l then return .T
if EQ([NIL,l]) === T then return .NIL
return .((\words[l]).v | NIL)
}
if glist(l) then { # it's a list
if T === ATOM([l[1]]) then
case Map(l[1]) of {
"QUOTE" : return .(l[2] | NIL)
"COND" : return COND(l[2:0])
"SETQ" : return SET([l[2]]|||evlis(l[3:0]))
"ITRACEON" : return (&trace := -1,T)
"ITRACEOFF" : return (&trace := 0,NIL)
default : return apply([l[1]]|||evlis(l[2:0])) | NIL
}
return apply([EVAL([l[1]])]|||evlis(l[2:0])) | NIL
}
return .NIL
end
## apply(fn,args) - evaluate the function
procedure apply(l)
local fn, arglist, arg, value, fcn
fn := l[1]
if member(trace_set, Map(string(fn))) then {
write("Arguments of ",fn)
PRINT(l[2:0])
}
if value := case Map(string(fn)) of {
"CAR" : CAR([l[2]]) | NIL
"CDR" : CDR([l[2]]) | NIL
"CONS" : CONS(l[2:0]) | NIL
"ATOM" : ATOM([l[2]]) | NIL
"NULL" : NULL([l[2]]) | NIL
"EQ" : EQ([l[2],l[3]]) | NIL
"PRINT" : PRINT([l[2]]) | NIL
"EVAL" : EVAL([l[2]]) | NIL
"DEFINE" : DEFINE(l[2]) | NIL
"TRACE" : TRACE(l[2]) | NIL
"UNTRACE" : UNTRACE(l[2]) | NIL
} then {
if member(trace_set, Map(string(fn))) then {
write("value of ",fn)
PRINT(value)
}
return value
}
fcn := (\words[Map(fn)]).f | return NIL
if type(fcn) == "list" then
if Map(fcn[1]) == "LAMBDA" then {
value := lambda(l[2:0],fcn[2],fcn[3])
if member(trace_set, Map(string(fn))) then {
write("value of ",fn)
PRINT(value)
}
return value
}
else
return EVAL([fn])
return NIL
end
## evlis(l) - evaluate everything in a list
#
procedure evlis(l)
local arglist, arg
arglist := []
every arg := !l do
put(arglist,EVAL([arg])) | fail
return arglist
end
### Initializations
## initialize() - set up global values
#
procedure initialize()
words := table()
trace_set := set()
T := "T"
NIL := []
end
### Primitive Functions
## (CAR l)
#
procedure CAR(l)
return glist(l[1])[1] | NIL
end
## (CDR l)
#
procedure CDR(l)
return glist(l[1])[2:0] | NIL
end
## (CONS l)
#
procedure CONS(l)
return ([l[1]]|||glist(l[2])) | NIL
end
## (SET a l)
#
procedure SET(l)
(T === ATOM([l[1]])& l[2]) | return NIL
/words[l[1]] := prop()
if type(l[2]) == "prop" then
return .(words[l[1]].v := l[2].v)
else
return .(words[l[1]].v := l[2])
end
## (ATOM a)
#
procedure ATOM(l)
if type(l[1]) == "list" then
return (*l[1] = 0 & T) | NIL
return T
end
## (NULL l)
#
procedure NULL(l)
return EQ([NIL,l[1]])
end
## (EQ a1 a2)
#
procedure EQ(l)
if type(l[1]) == type(l[2]) == "list" then
return (0 = *l[1] = *l[2] & T) | NIL
return (l[1] === l[2] & T) | NIL
end
## (PRINT l)
#
procedure PRINT(l)
if type(l[1]) == "prop" then
return PRINT([l[1].v])
return write(strip(ltos(l)))
end
## COND(l) - support routine to eval
# (for COND)
procedure COND(l)
local pair
every pair := !l do {
if type(pair) ~== "list" |
*pair ~= 2 then {
write(&errout,"COND: ill-formed pair list")
return NIL
}
if T === EVAL([pair[1]]) then
return EVAL([pair[2]])
}
return NIL
end
## (TRACE l)
#
procedure TRACE(l)
local fn
every fn := !l do {
insert(trace_set, Map(fn))
}
return NIL
end
## (UNTRACE l)
#
procedure UNTRACE(l)
local fn
every fn := !l do {
delete(trace_set, Map(fn))
}
return NIL
end
## glist(l) - verify that l is a list
#
procedure glist(l)
if type(l) == "list" then return l
end
## (DEFINE fname definition)
#
# This has been considerable rewritten (and made more difficult to use!)
# in order to match EV-LISP syntax.
procedure DEFINE(l)
local fn_def, fn_list
fn_list := []
every fn_def := !l do {
put(fn_list, define_fn(fn_def))
}
return fn_list
end
## Define a single function (called by 'DEFINE')
#
procedure define_fn(fn_def)
/words[Map(fn_def[1])] := prop(NIL)
words[Map(fn_def[1])].f := fn_def[2]
return Map(fn_def[1])
end
## lambda(actuals,formals,def)
#
procedure lambda(actuals, formals, def)
local save, act, form, pair, result, arg, i
save := table()
every arg := !formals do
save[arg] := \words[arg] | prop(NIL)
i := 0
every words[!formals] := (prop(actuals[i+:=1]|NIL)\1)
result := EVAL([def])
every pair := !sort(save) do
words[pair[1]] := pair[2]
return result
end
# Date: June 10, 1988
#
procedure getbs()
static tmp
initial tmp := ("" ~== |read()) || " "
repeat {
while not checkbal(tmp) do {
if more(')','(',tmp) then break
tmp ||:= (("" ~== |read()) || " ") | break
}
suspend balstr(tmp)
tmp := (("" ~== |read()) || " ") | fail
}
end
## checkbal(s) - quick check to see if s is
# balanced w.r.t. parentheses
#
procedure checkbal(s)
return (s ? 1(tab(bal()),pos(-1)))
end
## more(c1,c2,s) - succeeds if any prefix of
# s has more characters in c1 than
# characters in c2, fails otherwise
#
procedure more(c1,c2,s)
local cnt
cnt := 0
s ? while (cnt <= 0) & not pos(0) do {
(any(c1) & cnt +:= 1) |
(any(c2) & cnt -:= 1)
move(1)
}
return cnt >= 0
end
## balstr(s) - generate the balanced disjoint substrings
# in s, with blanks or tabs separating words
#
# errors:
# fails when next substring cannot be balanced
#
#
procedure balstr(s)
static blanks
initial blanks := ' \t'
(s||" ") ? repeat {
tab(many(blanks))
if pos(0) then break
suspend (tab(bal(blanks))\1 |
{write(&errout,"ill-formed expression")
fail}
) \ 1
}
end
## bstol(s) - convert a balanced string into equivalent
# list representation.
#
procedure bstol(s)
static blanks
local l
initial blanks := ' \t'
(s||" ") ? {tab(many(blanks))
l := if not ="(" then s else []
}
if not string(l) then
every put(l,bstol(balstr(strip(s))))
return l
end
## ltos(l) - convert a list back into a string
#
#
procedure ltos(l)
local tmp
if type(l) ~== "list" then return l
if *l = 0 then return "NIL"
tmp := "("
every tmp ||:= ltos(!l) || " "
tmp[-1] := ")"
return tmp
end
procedure strip(s)
s ?:= 2(="(", tab(bal()), =")", pos(0))
return s
end
procedure Map(s)
return map(s, &lcase, &ucase)
end
##########
loadmap.icn
############################################################################
#
# Name: loadmap.icn
#
# Title: Produce load map of UNIX obect file
#
# Author: Stephen B. Wampler
#
# Date: December 13, 1985
#
############################################################################
#
# This program produces a formatted listing of selected symbol classes
# from a compiled file. The listing is by class, and gives the
# name, starting address, and length of the region associated with
# each symbol.
#
# The options are:
#
# -a Display the absolute symbols.
#
# -b Display the BSS segment symbols.
#
# -c Display the common segment symbols.
#
# -d Display the data segment symbols.
#
# -t Display the text segment symbols.
#
# -u Display the undefined symbols.
#
# If no options are specified, -t is assumed.
#
# If the address of a symbol cannot be determined, ???? is given in
# its place.
#
############################################################################
#
# Notes:
#
# The size of the last region in a symbol class is suspect and is
# usually given as rem.
#
# Output is not particularly exciting on a stripped file.
#
############################################################################
#
# Requires: UNIX
#
############################################################################
record entry(name,address)
procedure main(args)
local maptype, arg, file, nm, ldmap, tname, line, text, data, bss
local SPACE, COLON, DIGITS, HEXDIGITS, usize, address, name, nmtype
initial {
if *args = 0 then stop("usage: loadmap [-t -d -b -u -a -c -l] file")
SPACE := '\t '
COLON := ':'
DIGITS := '0123456789'
HEXDIGITS := DIGITS ++ 'abcdef'
ldmap := table(6)
ldmap["u"] := []
ldmap["d"] := []
ldmap["a"] := []
ldmap["b"] := []
ldmap["t"] := []
ldmap["c"] := []
tname := table(6)
tname["u"] := "Undefined symbols"
tname["a"] := "Absolute locations"
tname["t"] := "Text segment symbols"
tname["d"] := "Data segment symbols"
tname["b"] := "BSS segment symbols"
tname["c"] := "Common symbols"
nmtype := "nm -gno "
}
maptype := ""
every arg := !args do
if arg[1] ~== "-" then file := arg
else if arg == "-l" then nmtype := "nm -no "
else if arg[1] == "-" then maptype ||:= (!"ltdbuac" == arg[2:0]) |
stop("usage: loadmap [-t -d -b -u -a -c -l] file")
maptype := if *maptype = 0 then "t" else string(cset(maptype))
write("\n",file,"\n")
usize := open("size " || file,"rp") | stop("loadmap: cannot execute size")
!usize ? {
writes("Text space: ",right(text := tab(many(DIGITS)),6)," ")
move(1)
writes("Initialized Data: ",right(data := tab(many(DIGITS)),6)," ")
move(1)
write("Uninitialized Data: ",right(bss := tab(many(DIGITS)),6))
}
close(usize)
nm := open(nmtype || file,"rp") | stop("loadmap: cannot execute nm")
every line := !nm do
line ? {
tab(upto(COLON)) & move(1)
address := integer("16r" || tab(many(HEXDIGITS))) | "????"
tab(many(SPACE))
type := map(move(1))
tab(many(SPACE))
name := tab(0)
if find(type,maptype) then put(ldmap[type],entry(name,address))
}
every type := !maptype do {
if *ldmap[type] > 0 then {
write("\n\n\n")
write(tname[type],":")
write()
show(ldmap[type],(type == "t" & text) |
(type == "d" & data) | (type == "b" & bss) | &null,
ldmap[type][1].address)
}
}
end
procedure show(l,ssize,base)
local i1, i2, nrows
static ncols
initial ncols := 3
write(repl(repl(" ",3) || left("name",9) || right("addr",7) ||
right("size",6),ncols))
write()
nrows := (*l + (ncols - 1)) / ncols
every i1 := 1 to nrows do {
every i2 := i1 to *l by nrows do
writes(repl(" ",3),left(l[i2].name,9),right(l[i2].address,7),
right(area(l[i2 + 1].address,l[i2].address) |
if /ssize then "rem" else base + ssize - l[i2].address,6))
write()
}
return
end
procedure area(high,low)
if integer(low) & integer(high) then return high - low
else return "????"
end
##########
memsum.icn
############################################################################
#
# Name: memsum.icn
#
# Title: Summarize Icon memory management
#
# Author: Ralph E. Griswold
#
# Date: March 8, 1990
#
############################################################################
#
# This program is a filter for Icon allocation history files (see IPD113).
# It tabulates the number of allocations by type and the total amount of
# storage (in bytes) by type.
#
# It takes an Icon allocation history file from standard input and writes to
# standard output.
#
# The command-line options are:
#
# -t produce tab-separated output for use in spreadsheets (the
# default is a formatted report
# -d produce debugging output
#
# Some assumptions are made about where newlines occur -- specifically
# that verification commands are on single lines and that refresh and
# garbage collection data are on multiple lines.
#
############################################################################
#
# Links: numbers, options
#
############################################################################
global cmds, highlights, lastlen, alloccnt, alloctot, collections
global mmunits, diagnose, namemap
link numbers, options
procedure main(args)
local line, region, s, skip, opts
opts := options(args,"dt")
diagnose := if \opts["d"] then write else 1
display := if \opts["t"] then spread else report
cmds := 'cefihLlRrSsTtux"XAF' # command characters
highlights := '%$Y' # highlight commands
mmunits := 4 # (for most systems)
namemap := table("*** undefined ***")
namemap["b"] := "large integer"
namemap["c"] := "cset"
namemap["e"] := "table element tv"
namemap["f"] := "file"
namemap["h"] := "hash block"
namemap["i"] := "large integer"
namemap["L"] := "list header"
namemap["l"] := "list element"
namemap["R"] := "record"
namemap["r"] := "real number"
namemap["S"] := "set header"
namemap["s"] := "set element"
namemap["T"] := "table header"
namemap["t"] := "table element"
namemap["u"] := "substring tv"
namemap["x"] := "refresh block"
namemap["\""] := "string"
namemap["X"] := "co-expression"
namemap["A"] := "alien block"
namemap["F"] := "free space"
lastlen := table() # last size
alloccnt := table(0) # count of allocations
alloctot := table(0) # total allocation
collections := list(4,0) # garbage collection counts
every alloccnt[!cmds] := 0
every alloctot[!cmds] := 0
cmds ++:= highlights
while line := read() do { # input from MemMon history file
line ? { # note: coded for extensions
if region := tab(upto('{')) then { # skip refresh sequence
collections[region] +:= 1
while line := read() | stop("**** premature eof") do
line ? if upto('#!') then break next
}
case move(1) of {
"=": next # skip verification command
"#": next # skip comment
";": next # skip pause command
"!" | ">": next # resynchronize (edited file)
default: { # data to process
move(-1) # back off from move(1) above
if s := tab(upto('<')) then {
mmunits := integer(s) # covers old case with no mmunits
while line := read() | stop("**** premature eof") do
line ? if upto('#>') then break next
}
else {
repeat { # process allocation
tab(many(' ')) # skip blanks (old files)
if pos(0) then break next
skip := process(tab(upto(cmds) + 1)) |
stop("*** unexpected data: ",line)
move(skip)
}
}
}
}
}
}
display()
end
# Display a table of allocation data
#
procedure report()
local cnt, cnttotal, i, tot, totalcoll, tottotal
static col1, col2, gutter # column widths
initial {
col1 := 16 # name field
col2 := 10 # number field
gutter := repl(" ",6)
}
write(, # write column headings
"\n",
left("type",col1),
right("number",col2),
gutter,
right("bytes",col2),
gutter,
right("average",col2),
gutter,
right("% bytes",col2),
"\n"
)
alloccnt := sort(alloccnt,3) # get the data
alloctot := sort(alloctot,3)
cnttotal := 0
tottotal := 0
every i := 2 to *alloccnt by 2 do {
cnttotal +:= alloccnt[i]
tottotal +:= alloctot[i]
}
while write( # write the data
left(namemap[get(alloccnt)],col1), # name
right(cnt := get(alloccnt),col2), # number of allocations
gutter,
get(alloctot) & right(tot := get(alloctot),col2), # space allocated
gutter,
fix(tot,cnt,col2) | repl(" ",col2),
gutter,
fix(100.0 * tot,tottotal,col2) | repl(" ",col2)
)
write( # write totals
"\n",
left("total:",col1),
right(cnttotal,col2),
gutter,
right(tottotal,col2),
gutter,
fix(tottotal,cnttotal,col2) | repl(" ",col2)
)
totalcoll := 0 # garbage collections
every totalcoll +:= !collections
write("\n",left("collections:",col1),right(totalcoll,col2))
if totalcoll > 0 then {
write(left(" static region:",col1),right(collections[1],col2))
write(left(" string region:",col1),right(collections[2],col2))
write(left(" block region:",col1),right(collections[3],col2))
write(left(" no region:",col1),right(collections[4],col2))
}
return
end
# Produce tab-separated output for a spreadsheet.
#
procedure spread()
alloccnt := sort(alloccnt,3) # get the data
alloctot := sort(alloctot,3)
write("*\nname number bytes")
while write( # write the data
namemap[get(alloccnt)],
"\t",
get(alloccnt),
"\t",
get(alloctot) & get(alloctot),
)
return
end
# Process datm
#
procedure process(s)
local cmd, len
s ? {
tab(upto('+') + 1) # skip address
len := tab(many(&digits)) | &null
cmd := move(1)
if cmd == !highlights then return 2 else {
# if given len is nonstring, scale
if cmd ~== "\"" then \len *:= mmunits
alloccnt[cmd] +:= 1
(/len := lastlen[cmd]) | (lastlen[cmd] := len)
diagnose(&errout,"cmd=",cmd,", len=",len)
alloctot[cmd] +:= len
return 0
}
}
end
##########
miu.icn
############################################################################
#
# Name: miu.icn
#
# Title: Generate strings from the MIU system
#
# Author: Cary A. Coutant, modified by Ralph E. Griswold
#
# Date: December 27, 1989
#
############################################################################
#
# This program generates strings from the MIU string system.
#
# The number of generations is determined by the command-line argument.
# The default is 7.
#
# Reference:
#
# Godel, Escher, and Bach: an Eternal Golden Braid, Douglas R.
# Hofstadter, Basic Books, 1979. pp. 33-36.
#
############################################################################
procedure main(arg)
local count, gen, limit
count := 0
limit := integer(arg[1]) | 7
gen := ["MI"]
every count := 1 to limit do {
show(count,gen)
gen := nextgen(gen)
}
end
# show - show a generation of strings
procedure show(count,gen)
write("Generation #",count)
every write(" ",image(\!gen))
write()
end
# nextgen - given a generation of strings, compute the next generation
procedure nextgen(gen)
local new, s
new := set()
every insert(new,apply(!gen))
return sort(new)
end
# apply - produce all strings derivable from s in a single rule application
procedure apply(s)
local i
if s[-1] == "I" then suspend s || "U"
if s[1] == "M" then suspend s || s[2:0]
every i := find("III",s) do
suspend s[1:i] || "U" || s[i+3:0]
every i := find("UU",s) do
suspend s[1:i] || s[i+2:0]
end
##########
monkeys.icn
############################################################################
#
# Name: monkeys.icn
#
# Title: Generate random text
#
# Author: Stephen B. Wampler, modified by Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# The old monkeys at the typewriters anecdote ...
#
# This program uses ngram analysis to randomly generate text in
# the same 'style' as the input text. The arguments are:
#
# -s show the input text
# -n n use n as the ngram size (default:3)
# -l n output at about n lines (default:10)
# -r n set random number seed to n
#
############################################################################
#
# Links: options
#
############################################################################
link options
procedure main(args)
local switches, n, linecount, ngrams, preline
local line, ngram, nextchar, firstngram, Show
switches := options(args,"sn+l+r+")
if \switches["s"] then Show := writes else Show := 1
n := \switches["n"] | 3
linecount := \switches["l"] | 10
ngrams := table()
Show("Orginal Text is: \n\n")
preline := ""
every line := preline || !&input do {
Show(line)
line ? {
while ngram := move(n) & nextchar := move(1) do {
/firstngram := ngram
/ngrams[ngram] := ""
ngrams[ngram] ||:= nextchar
move(-n)
}
preline := tab(0) || "\n"
}
}
Show("\n\nGenerating Sentences\n\n")
ngram := writes(firstngram)
while linecount > 0 do {
if /ngrams[ngram] then
exit() # if hit EOF ngram early
ngram := ngram[2:0] || writes(nextchar := ?ngrams[ngram])
if (nextchar == "\n") then
linecount -:= 1
}
end
##########
pack.icn
############################################################################
#
# Name: pack.icn
#
# Title: Package multiple files
#
# Author: Ralph E. Griswold
#
# Date: May 27, 1989
#
############################################################################
#
# This programs reads a list of file names from standard input and
# packages the files into a single file, which is written to standard
# output.
#
# Files are separated by a header, ##########, followed by the file
# name. This simple scheme does not work if a file contains such a header
# itself, and it's problematical for files of binary data.
#
############################################################################
#
# See also: unpack.icn
#
############################################################################
procedure main()
local in
while name := read() do {
close(\in)
in := open(name) | stop("cannot open input file: ",name)
write("##########")
write(name)
while write(read(in))
}
end
##########
parens.icn
############################################################################
#
# Name: parens.icn
#
# Title: Produce random parenthesis-balanced strings
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program produces parenthesis-balanced strings in which
# the parentheses are randomly distributed.
#
# Options: The following options are available:
#
# -b n Bound the length of the strings to n left and right
# parentheses each. The default is 10.
#
# -n n Produce n strings. The default is 10.
#
# -l s Use the string s for the left parenthesis. The default
# is ( .
#
# -r s Use the string s for the right parenthesis. The default
# is ) .
#
# -v Randomly vary the length of the strings between 0 and
# the bound. In the absence of this option, all strings
# are the exactly as long as the specified bound.
#
# For example, the output for
#
# parens -v -b 4 -l "begin " -r "end "
#
# is
#
# begin end
# begin end begin end
# begin begin end end begin end
# begin end begin begin end end
# begin end
# begin begin end end
# begin begin begin end end end
# begin end begin begin end end
# begin end begin end
# begin begin end begin end begin end end
#
#
# Comments: This program was motivated by the need for test data
# for error repair schemes for block-structured programming lan-
# gauges. A useful extension to this program would be some
# way of generating other text among the parentheses. In addition
# to the intended use of the program, it can produce a variety of
# interesting patterns, depending on the strings specified by -l
# and -r.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global r, k, lp, rp
procedure main(args)
local string, i, s, bound, limit, varying, opts
bound := limit := 10 # default bound and limit
lp := "(" # default left paren
rp := ")" # default right paren
opts := options(args,"l:r:vb+n+")
bound := \opts["b"] | 10
limit := \opts["n"] | 10
lp := \opts["l"] | "("
rp := \opts["r"] | ")"
varying := opts["v"]
every 1 to limit do {
if \varying then k := 2 * ?bound else k := 2 * bound
string := ""
r := 0
while k ~= r do {
if r = 0 then string ||:= Open()
else if ?0 < probClose()
then string ||:= Close() else string ||:= Open()
}
while k > 0 do string ||:= Close()
write(string)
}
end
procedure Open()
r +:= 1
k -:= 1
return lp
end
procedure Close()
r -:= 1
k -:= 1
return rp
end
procedure probClose()
return ((r * (r + k + 2)) / (2.0 * k * (r + 1)))
end
##########
parse.icn
############################################################################
#
# Name: parse.icn
#
# Title: Parse simple statements
#
# Author: Kenneth Walker
#
# Date: December 22, 1989
#
############################################################################
global lex # co-expression for lexical analyzer
global next_tok # next token from input
record token(type, string)
procedure main()
lex := create ((!&input ? get_tok()) | |token("eof", "eof"))
prog()
end
#
# get_tok is the main body of lexical analyzer
#
procedure get_tok()
local tok
repeat { # skip white space and comments
tab(many(' '))
if ="#" | pos(0) then fail
if any(&letters) then # determine token type
tok := token("id", tab(many(&letters ++ '_')))
else if any(&digits) then
tok := token("integer", tab(many(&digits)))
else case move(1) of {
";" : tok := token("semi", ";")
"(" : tok := token("lparen", "(")
")" : tok := token("rparen", ")")
":" : if ="=" then tok := token("assign", ":=")
else tok := token("colon", ":")
"+" : tok := token("add_op", "+")
"-" : tok := token("add_op", "-")
"*" : tok := token("mult_op", "*")
"/" : tok := token("mult_op", "/")
default : err("invalid character in input")
}
suspend tok
}
end
#
# The procedures that follow make up the parser
#
procedure prog()
next_tok := @lex
stmt()
while next_tok.type == "semi" do {
next_tok := @lex
stmt()
}
if next_tok.type ~== "eof" then
err("eof expected")
end
procedure stmt()
if next_tok.type ~== "id" then
err("id expected")
write(next_tok.string)
if (@lex).type ~== "assign" then
err(":= expected")
next_tok := @lex
expr()
write(":=")
end
procedure expr()
local op
term()
while next_tok.type == "add_op" do {
op := next_tok.string
next_tok := @lex
term()
write(op)
}
end
procedure term()
local op
factor()
while next_tok.type == "mult_op" do {
op := next_tok.string
next_tok := @lex
factor()
write(op)
}
end
procedure factor()
case next_tok.type of {
"id" | "integer": {
write(next_tok.string)
next_tok := @lex
}
"lparen": {
next_tok := @lex
expr()
if next_tok.type ~== "rparen" then
err(") expected")
else
next_tok := @lex
}
default:
err("id or integer expected")
}
end
procedure err(s)
stop(" ** error ** ", s)
end
##########
parsex.icn
############################################################################
#
# Name: parsex.icn
#
# Title: Parse arithmetic expressions
#
# Author: Cheyenne Wills
#
# Date: June 10, 1988
#
############################################################################
#
# Adapted from C code written by Allen I. Holub published in the
# Feb 1987 issue of Dr. Dobb's Journal.
#
# General purpose expression analyzer. Can evaluate any expression
# consisting of number and the following operators (listed according
# to precedence level):
#
# () - ! 'str'str'
# * / &
# + -
# < <= > >= == !=
# && ||
#
# All operators associate left to right unless () are present.
# The top - is a unary minus.
#
#
# <expr> ::= <term> <expr1>
# <expr1> ::= && <term> <expr1>
# ::= || <term> <expr1>
# ::= epsilon
#
# <term> ::= <fact> <term1>
# <term1> ::= < <fact> <term1>
# ::= <= <fact> <term1>
# ::= > <fact> <term1>
# ::= >= <fact> <term1>
# ::= == <fact> <term1>
# ::= != <fact> <term1>
# ::= epsilon
#
# <fact> ::= <part> <fact1>
# <fact1> ::= + <part> <fact1>
# ::= - <part> <fact1>
# ::= - <part> <fact1>
# ::= epsilon
#
# <part> ::= <const> <part1>
# <part1> ::= * <const> <part1>
# ::= / <const> <part1>
# ::= % <const> <part1>
# ::= epsilon
#
# <const> ::= ( <expr> )
# ::= - ( <expr> )
# ::= - <const>
# ::= ! <const>
# ::= 's1's2' # compares s1 with s2 0 if ~= else 1
# ::= NUMBER # number is a lose term any('0123456789.Ee')
#
#############################################################################
procedure main()
local line
writes("->")
while line := read() do {
write(parse(line))
writes("->")
}
end
procedure parse(exp)
return exp ? expr()
end
procedure expr(exp)
local lvalue
lvalue := term()
repeat {
tab(many(' \t'))
if ="&&" then lvalue := iand(term(),lvalue)
else if ="||" then lvalue := ior(term(),lvalue)
else break
}
return lvalue
end
procedure term()
local lvalue
lvalue := fact()
repeat {
tab(many(' \t'))
if ="<=" then lvalue := if lvalue <= fact() then 1 else 0
else if ="<" then lvalue := if lvalue < fact() then 1 else 0
else if =">=" then lvalue := if lvalue >= fact() then 1 else 0
else if =">" then lvalue := if lvalue > fact() then 1 else 0
else if ="==" then lvalue := if lvalue = fact() then 1 else 0
else if ="!=" then lvalue := if lvalue ~= fact() then 1 else 0
else break
}
return lvalue
end
procedure fact()
local lvalue
lvalue := part()
repeat {
tab(many(' \t'))
if ="+" then lvalue +:= part()
else if ="-" then lvalue -:= part()
else break
}
return lvalue
end
procedure part()
local lvalue
lvalue := const()
repeat {
tab(many(' \t'))
if ="*" then lvalue *:= part()
else if ="%" then lvalue %:= part()
else if ="/" then lvalue /:= part()
else break
}
return lvalue
end
procedure const()
local sign, logical, rval, s1, s2
tab(many(' \t'))
if ="-" then sign := -1 else sign := 1
if ="!" then logical := 1 else logical := &null
if ="(" then {
rval := expr()
if not match(")") then {
write(&subject)
write(right("",&pos-1,"_"),"^ Mis-matched parenthesis")
}
else move(1)
}
else if ="'" then {
s1 := tab(upto('\''))
move(1)
s2 := tab(upto('\''))
move(1)
rval := if s1 === s2 then 1 else 0
}
else {
rval := tab(many('0123456789.eE'))
}
if \logical then { return if rval = 0 then 1 else 0 }
else return rval * sign
end
##########
press.icn
############################################################################
#
# Name: press.icn
#
# Title: LZW Compression and Decompression Utility
#
# Author: Robert J. Alexander
#
# Date: December 5, 1989
#
############################################################################
#
# Note: This program is designed primarily to demonstrate the LZW
# compression process. It contains a lot of tracing toward
# that end and is too slow for practical use.
#
############################################################################
#
# Usage: press [-t] -c [-s n] [-f <compressed file>] <file to compress>...
# press [-t] -x <compressed file>...
#
# -c perform compression
# -x expand (decompress) compressed file
# -f output file for compression -- if missing standard output used
# -s maximum string table size
# (for compression only -- default = 1024)
# -t output trace info to standard error file
#
# If the specified maximum table size is positive, the string table is
# discarded when the maximum size is reached and rebuilt (recommended).
# If negative, the original table is not discarded, which might produce
# better results in some circumstances.
#
############################################################################
#
# Features that might be nice to add someday:
#
# Allow decompress output to standard output.
#
# Handle heirarchies.
#
# Way to list files in archive, and access individual files
#
############################################################################
#
# Links: options
#
############################################################################
global inchars,outchars,tinchars,toutchars,lzw_recycles,
lzw_stringTable,lzw_trace,wr,wrs,rf,wf
link options
procedure main(arg)
local compr,expand,fn,maxT,maxTableSize,opt,outfile,wfn
#
# Initialize.
#
opt := options(arg,"ts+f:cx")
if *arg = 0 then arg := ["-"]
lzw_trace := opt["t"]
expand := opt["x"]
compr := opt["c"]
outfile := opt["f"]
maxTableSize := \opt["s"]
if (/expand & /compr) then Usage()
wr := write ; wrs := writes
inchars := outchars := tinchars := toutchars := lzw_recycles := 0
#
# Process compression.
#
if \compr then {
if \expand then Usage()
if \outfile then
wf := open(outfile,"w") | stop("Can't open output file ",outfile)
#
# Loop to process files on command line.
#
every fn := !arg do {
if fn === outfile then next
wr(&errout,"\nFile \"",fn,"\"")
rf := if fn ~== "-" then open(fn) | &null else &input
if /rf then {
write(&errout,"Can't open input file \"",fn,"\" -- skipped")
next
}
write(wf,tail(fn))
maxT := compress(r,w,maxTableSize)
close(rf)
stats(maxT)
}
}
#
# Process decompression.
#
else if \expand then {
if \(compr | outfile | maxTableSize) then Usage()
#
# Loop to process files on command line.
#
every fn := !arg do {
rf := if fn ~== "-" then open(fn) | &null else &input
if /rf then {
write(&errout,"Can't open input file \"",fn,"\" -- skipped")
next
}
while wfn := read(rf) do {
wr(&errout,"\nFile \"",wfn,"\"")
wf := open(wfn,"w") | &null
if /wf then {
write(&errout,"Can't open output file \"",wfn,"\" -- quitting")
exit(1)
}
maxT := decompress(r,w)
close(wf)
stats(maxT)
}
close(rf)
}
}
else Usage()
#
# Write statistics
#
wr(&errout,"\nTotals: ",
"\n input = ",tinchars,
"\n output = ",toutchars,
"\n compression factor = ",(real(toutchars) / real(0 < tinchars)) | "")
end
procedure stats(maxTableSize)
#
# Write statistics
#
wr(&errout,
" input = ",inchars,
"\n output = ",outchars,
"\n compression factor = ",(real(outchars) / real(0 < inchars)) | "",
"\n table size = ",*lzw_stringTable,"/",maxTableSize,
" (",lzw_recycles," recycles)")
tinchars +:= inchars
toutchars +:= outchars
inchars := outchars := lzw_recycles := 0
return
end
procedure r()
return 1(reads(rf),inchars +:= 1)
end
procedure w(s)
return 1(writes(wf,s),outchars +:= *s)
end
procedure Usage()
stop("_
# Usage: icompress [-t] -c [-s n] <file to compress>...\n_
# icompress [-t] -x <compressed file>...\n_
#\n_
# -c perform compression\n_
# -x expand (decompress) compressed file\n_
# -f output file for compression -- if missing standard output used\n_
# -s maximum string table size\n_
# (for compression only -- default = 1024)\n_
# -t output trace info to standard error file\n_
#")
end
procedure tail(fn)
local i
i := 0
every i := find("/",fn)
return fn[i + 1:0]
end
#
# 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)
local outcode
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
############################################################################
#
# 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)
local code
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
##########
proto.icn
############################################################################
#
# Name: proto.icn
#
# Title: Instances of different syntactic forms in Icon
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program doesn't "do" anything. It just contains an example of
# every syntactic form in Version 7 of Icon (or close to it). It might
# be useful for checking programs that process Icon programs. Note, however,
# that it does not contain many combinations of different syntactic forms.
#
############################################################################
#
# Program note:
#
# This program is divided into procedures to avoid overflow with
# default values for Icon's translator and linker.
#
############################################################################
#
# Links: options
#
# Requires: co-expressions
#
############################################################################
link options
record three(x,y,z)
record zero()
record one(z)
global line, count
procedure main()
expr1()
expr2()
expr3()
expr4(1,2)
expr4{1,2}
expr5(1,2,3,4)
end
procedure expr1()
local x, y, z
local i, j
static e1
initial e1 := 0
exit() # get out before there's trouble
()
{}
();()
[]
[,]
x.y
x[i]
x[i:j]
x[i+:j]
x[i-:j]
(,,,)
x(,,,)
not x
|x
!x
*x
+x
-x
end
procedure expr2()
local x, i, y, j, c1, c2, s1, s2, a2, k, a1
.x
/x
=x
?x
\x
~x
@x
^x
x \ i
x @ y
i ^ j
i * j
i / j
i % j
c1 ** c2
i + j
i - j
c1 ++ c2
c1 -- c2
s1 || s2
a1 ||| a2
i < j
i <= j
i = j
i >= j
i > j
i ~= j
s1 << s2
s1 == s2
s1 >>= s2
s1 >> s2
s1 ~== s2
x === y
x ~=== y
x | y
i to j
i to j by k
x := y
x <- y
x :=: y
x <-> y
i +:= j
i -:= j
i *:= j
end
procedure expr3()
local i, j, c1, c2, s1, s2, a1, a2, x, y, s
i /:= j
i %:= j
i ^:= j
i <:= j
i <=:= j
i =:= j
i >=:= j
i ~=:= j
c1 ++:= c2
c1 --:= c2
c1 **:= c2
s1 ||:= s2
s1 <<:= s2
s1 <<=:= s2
s1 ==:= s2
s1 >>=:= s2
s1 >>:= s2
s1 ~==:= s2
s1 ?:= s2
a1 |||:= a2
x ===:= y
x ~===:= y
x &:= y
x @:= y
s ? x
x & y
create x
return
return x
suspend x
suspend x do y
fail
end
procedure expr4()
local e1, e2, e, x, i, j, size, s, e3, X_
while e1 do break
while e1 do break e2
while e1 do next
case e of {
x: fail
(i > j) | 1 : return
}
case size(s) of {
1: 1
default: fail
}
if e1 then e2
if e1 then e2 else e3
repeat e
while e1
while e1 do e2
until e1
until e1 do e2
every e1
every e1 do e2
x
X_
&cset
&null
"abc"
"abc_
cde"
'abc'
'abc_
cde'
"\n"
"^a"
"\001"
"\x01"
1
999999
36ra1
3.5
2.5e4
4e-10
end
procedure expr5(a,b,c[])
end
##########
queens.icn
############################################################################
#
# Name: queens.icn
#
# Title: Generate solutions to the n-queens problem
#
# Author: Stephen B. Wampler
#
# Date: June 10, 1988
#
############################################################################
#
# This program displays the solutions to the non-attacking n-
# queens problem: the ways in which n queens can be placed on an
# n-by-n chessboard so that no queen can attack another. A positive
# integer can be given as a command line argument to specify the
# number of queens. For example,
#
# iconx queens -n8
#
# displays the solutions for 8 queens on an 8-by-8 chessboard. The
# default value in the absence of an argument is 6. One solution
# for six queens is:
#
# -------------------------
# | | Q | | | | |
# -------------------------
# | | | | Q | | |
# -------------------------
# | | | | | | Q |
# -------------------------
# | Q | | | | | |
# -------------------------
# | | | Q | | | |
# -------------------------
# | | | | | Q | |
# -------------------------
#
# Comments: There are many approaches to programming solutions to
# the n-queens problem. This program is worth reading for
# its programming techniques.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global n, solution
procedure main(args)
local i, opts
opts := options(args,"n+")
n := \opts["n"] | 6
if n <= 0 then stop("-n needs a positive numeric parameter")
solution := list(n) # ... and a list of column solutions
write(n,"-Queens:")
every q(1) # start by placing queen in first column
end
# q(c) - place a queen in column c.
#
procedure q(c)
local r
static up, down, rows
initial {
up := list(2*n-1,0)
down := list(2*n-1,0)
rows := list(n,0)
}
every 0 = rows[r := 1 to n] = up[n+r-c] = down[r+c-1] &
rows[r] <- up[n+r-c] <- down[r+c-1] <- 1 do {
solution[c] := r # record placement.
if c = n then show()
else q(c + 1) # try to place next queen.
}
end
# show the solution on a chess board.
#
procedure show()
static count, line, border
initial {
count := 0
line := repl("| ",n) || "|"
border := repl("----",n) || "-"
}
write("solution: ", count+:=1)
write(" ", border)
every line[4*(!solution - 1) + 3] <- "Q" do {
write(" ", line)
write(" ", border)
}
write()
end
##########
recgen.icn
############################################################################
#
# Name: recgen.icn
#
# Title: Generate recognizer for sentences in a context-free language
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program reads a context-free grammar and produces an Icon
# program that is a recognizer for the corresponding language.
#
# Nonterminal symbols are represented by uppercase letters. Vertical
# bars separate alternatives. All other characters are considered to
# be terminal symbols. The nonterminal symbol on the last line is
# taken to be the goal.
#
# An example is:
#
# X::=T|T+X
# T::=E|E*T
# E::=x|y|z|(X)
#
# Limitations:
#
# Left recursion in the grammar may cause the recognizer to loop.
# There is no check that all nonterminal symbols that are referenced
# are defined.
#
# Reference:
#
# The Icon Programming Language, Ralph E. and Madge T. Griswold,
# Prentice-Hall, 1983. pp. 161-165.
#
############################################################################
global goal
procedure main()
local line, sym
while line := read() do define(line)
write("\nprocedure main()")
write(" while line := read() do {")
write(" writes(image(line))")
write(" if line ? (",goal,"() & pos(0)) then _
write(\": accepted\")\n else write(\": rejected\")")
write(" }")
write("end")
end
procedure expand(s,x)
local s1, sym
s1 := ""
s ? while sym := move(1) do
if any(&ucase,sym) then s1 ||:= sym || "() || "
else s1 ||:= "=\"" || sym || "\" || "
return s1[1:-4]
end
procedure define(line)
line ? (
write("\nprocedure ",goal := move(1),"()"),
="::=",
write(" suspend {"),
(every write(" ",prodlist())) | "",
write(" }"),
write("end")
)
end
procedure prodlist()
local p
while p := expand(tab(many(~'|')),"=") do {
move(1) | return "(" || p || ")" # last alternative
suspend "(" || p || ") |"
}
end
##########
roffcmds.icn
############################################################################
#
# Name: roffcmds.icn
#
# Title: List commands and macros in a roff document
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This progam processes standard input and writes a tabulation of
# nroff/troff commands and defined strings to standard output.
#
# Limitations:
#
# This program only recognizes commands that appear at the beginning of
# lines and does not attempt to unravel conditional constructions.
# Similarly, defined strings buried in disguised form in definitions are
# not recognized.
#
# Reference:
#
# Nroff/Troff User's Manual, Joseph F. Ossana, Bell Laboratories,
# Murray Hill, New Jersey. October 11, 1976.
#
############################################################################
procedure main()
local line, con, mac, y, nonpuncs, i, inname, infile, outname, outfile
nonpuncs := ~'. \t\\'
con := table(0)
mac := table(0)
while line := read() do {
line ? if tab(any('.\'')) then
con[tab(any(nonpuncs)) || (tab(upto(' ') | 0))] +:= 1
line ? while tab((i := find("\\")) + 1) do {
case move(1) of {
"(": move(2)
"*" | "f" | "n": if ="(" then move(2) else move(1)
}
mac[&subject[i:&pos]] +:= 1
}
}
con := sort(con,3)
write(,"Commands:\n")
while write(,get(con),"\t",get(con))
mac := sort(mac,3)
write(,"\nControls:\n")
while write(,get(mac),"\t",get(mac))
end
##########
rsg.icn
############################################################################
#
# Name: rsg.icn
#
# Title: Generate randomly selected sentences from a grammar
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program generates randomly selected strings (``sen-
# tences'') from a grammar specified by the user. Grammars are
# basically context-free and resemble BNF in form, although there
# are a number of extensions.
#
# The program works interactively, allowing the user to build,
# test, modify, and save grammars. Input to rsg consists of various
# kinds of specifications, which can be intermixed:
#
# Productions define nonterminal symbols in a syntax similar to
# the rewriting rules of BNF with various alternatives consisting
# of the concatenation of nonterminal and terminal symbols. Gen-
# eration specifications cause the generation of a specified number
# of sentences from the language defined by a given nonterminal
# symbol. Grammar output specifications cause the definition of a
# specified nonterminal or the entire current grammar to be written
# to a given file. Source specifications cause subsequent input to
# be read from a specified file.
#
# In addition, any line beginning with # is considered to be a
# comment, while any line beginning with = causes the rest of that
# line to be used subsequently as a prompt to the user whenever rsg
# is ready for input (there normally is no prompt). A line consist-
# ing of a single = stops prompting.
#
# Productions: Examples of productions are:
#
# <expr>::=<term>|<term>+<expr>
# <term>::=<elem>|<elem>*<term>
# <elem>::=x|y|z|(<expr>)
#
# Productions may occur in any order. The definition for a nonter-
# minal symbol can be changed by specifying a new production for
# it.
#
# There are a number of special devices to facilitate the defin-
# ition of grammars, including eight predefined, built-in nontermi-
# nal symbols:
# symbol definition
# <lb> <
# <rb> >
# <vb> |
# <nl> newline
# <> empty string
# <&lcase> any single lowercase letter
# <&ucase> any single uppercase letter
# <&digit> any single digit
#
# In addition, if the string between a < and a > begins and ends
# with a single quotation mark, it stands for any single character
# between the quotation marks. For example,
#
# <'xyz'>
#
# is equivalent to
#
# x|y|z
#
# Generation Specifications: A generation specification consists of
# a nonterminal symbol followed by a nonnegative integer. An exam-
# ple is
#
# <expr>10
#
# which specifies the generation of 10 <expr>s. If the integer is
# omitted, it is assumed to be 1. Generated sentences are written
# to standard output.
#
# Grammar Output Specifications: A grammar output specification
# consists of a nonterminal symbol, followed by ->, followed by a
# file name. Such a specification causes the current definition of
# the nonterminal symbol to be written to the given file. If the
# file is omitted, standard output is assumed. If the nonterminal
# symbol is omitted, the entire grammar is written out. Thus,
#
# ->
#
# causes the entire grammar to be written to standard output.
#
# Source Specifications: A source specification consists of @ fol-
# lowed by a file name. Subsequent input is read from that file.
# When an end of file is encountered, input reverts to the previous
# file. Input files can be nested.
#
# Options: The following options are available:
#
# -s n Set the seed for random generation to n. The default
# seed is 0.
#
# -l n Terminate generation if the number of symbols remaining
# to be processed exceeds n. The default is limit is 1000.
#
# -t Trace the generation of sentences. Trace output goes to
# standard error output.
#
# Diagnostics: Syntactically erroneous input lines are noted but
# are otherwise ignored. Specifications for a file that cannot be
# opened are noted and treated as erroneous.
#
# If an undefined nonterminal symbol is encountered during gen-
# eration, an error message that identifies the undefined symbol is
# produced, followed by the partial sentence generated to that
# point. Exceeding the limit of symbols remaining to be generated
# as specified by the -l option is handled similarly.
#
# Caveats: Generation may fail to terminate because of a loop in
# the rewriting rules or, more seriously, because of the progres-
# sive accumulation of nonterminal symbols. The latter problem can
# be identified by using the -t option and controlled by using the
# -l option. The problem often can be circumvented by duplicating
# alternatives that lead to fewer rather than more nonterminal sym-
# bols. For example, changing
#
# <term>::=<elem>|<elem>*<term>
#
# to
#
# <term>::=<elem>|<elem>|<elem>*<term>
#
# increases the probability of selecting <elem> from 1/2 to 2/3.
#
# There are many possible extensions to the program. One of the
# most useful would be a way to specify the probability of select-
# ing an alternative.
#
############################################################################
#
# Links: options
#
############################################################################
link options
global defs, ifile, in, limit, prompt, tswitch
record nonterm(name)
record charset(chars)
procedure main(args)
local line, plist, s, opts
# procedures to try on input lines
plist := [define,generate,grammar,source,comment,prompter,error]
defs := table() # table of definitions
defs["lb"] := [["<"]] # built-in definitions
defs["rb"] := [[">"]]
defs["vb"] := [["|"]]
defs["nl"] := [["\n"]]
defs[""] := [[""]]
defs["&lcase"] := [[charset(&lcase)]]
defs["&ucase"] := [[charset(&ucase)]]
defs["&digit"] := [[charset(&digits)]]
opts := options(args,"tl+s+")
limit := \opts["l"] | 1000
tswitch := \opts["t"]
&random := \opts["s"]
ifile := [&input] # stack of input files
prompt := ""
while in := pop(ifile) do { # process all files
repeat {
if *prompt ~= 0 then writes(prompt)
line := read(in) | break
while line[-1] == "\\" do line := line[1:-1] || read(in) | break
(!plist)(line)
}
close(in)
}
end
# process alternatives
#
procedure alts(defn)
local alist
alist := []
defn ? while put(alist,syms(tab(upto('|') | 0))) do move(1) | break
return alist
end
# look for comment
#
procedure comment(line)
if line[1] == "#" then return
end
# look for definition
#
procedure define(line)
return line ?
defs[(="<",tab(find(">::=")))] := (move(4),alts(tab(0)))
end
# define nonterminal
#
procedure defnon(sym)
local chars, name
if sym ? {
="'" &
chars := cset(tab(-1)) &
="'"
}
then return charset(chars)
else return nonterm(sym)
end
# note erroneous input line
#
procedure error(line)
write("*** erroneous line: ",line)
return
end
# generate sentences
#
procedure gener(goal)
local pending, symbol
pending := [nonterm(goal)]
while symbol := get(pending) do {
if \tswitch then
write(&errout,symimage(symbol),listimage(pending))
case type(symbol) of {
"string": writes(symbol)
"charset": writes(?symbol.chars)
"nonterm": {
pending := ?\defs[symbol.name] ||| pending | {
write(&errout,"*** undefined nonterminal: <",symbol.name,">")
break
}
if *pending > \limit then {
write(&errout,"*** excessive symbols remaining")
break
}
}
}
}
write()
end
# look for generation specification
#
procedure generate(line)
local goal, count
if line ? {
="<" &
goal := tab(upto('>')) \ 1 &
move(1) &
count := (pos(0) & 1) | integer(tab(0))
}
then {
every 1 to count do
gener(goal)
return
}
else fail
end
# get right hand side of production
#
procedure getrhs(a)
local rhs
rhs := ""
every rhs ||:= listimage(!a) || "|"
return rhs[1:-1]
end
# look for request to write out grammar
#
procedure grammar(line)
local file, out, name
if line ? {
name := tab(find("->")) &
move(2) &
file := tab(0) &
out := if *file = 0 then &output else {
open(file,"w") | {
write(&errout,"*** cannot open ",file)
fail
}
}
}
then {
(*name = 0) | (name[1] == "<" & name[-1] == ">") | fail
pwrite(name,out)
if *file ~= 0 then close(out)
return
}
else fail
end
# produce image of list of grammar symbols
#
procedure listimage(a)
local s, x
s := ""
every x := !a do
s ||:= symimage(x)
return s
end
# look for new prompt symbol
#
procedure prompter(line)
if line[1] == "=" then {
prompt := line[2:0]
return
}
end
# write out grammar
#
procedure pwrite(name,ofile)
local nt, a
static builtin
initial builtin := ["lb","rb","vb","nl","","&lcase","&ucase","&digit"]
if *name = 0 then {
a := sort(defs,3)
while nt := get(a) do {
if nt == !builtin then {
get(a)
next
}
write(ofile,"<",nt,">::=",getrhs(get(a)))
}
}
else write(ofile,name,"::=",getrhs(\defs[name[2:-1]])) |
write("*** undefined nonterminal: ",name)
end
# look for file with input
#
procedure source(line)
local file, new
return line ? {
if ="@" then {
new := open(file := tab(0)) | {
write(&errout,"*** cannot open ",file)
fail
}
push(ifile,in) &
in := new
return
}
}
end
# produce string image of grammar symbol
#
procedure symimage(x)
return case type(x) of {
"string": x
"nonterm": "<" || x.name || ">"
"charset": "<'" || x.chars || "'>"
}
end
# process the symbols in an alternative
#
procedure syms(alt)
local slist
static nonbrack
initial nonbrack := ~'<'
slist := []
alt ? while put(slist,tab(many(nonbrack)) |
defnon(2(="<",tab(upto('>')),move(1))))
return slist
end
##########
ruler.icn
############################################################################
#
# Name: ruler.icn
#
# Title: Write a character ruler to standard output
#
# Author: Robert J. Alexander
#
# Date: December 5, 1989
#
############################################################################
#
# Write a character ruler to standard output. The first optional
# argument is the length of the ruler in characters (default 80).
# The second is a number of lines to write, with a line number on
# each line.
#
procedure main(arg)
local length, ruler, lines, i
length := "" ~== arg[1] | 80
every writes(right(1 to length / 10,10))
ruler := right("",length,"----+----|")
if lines := arg[2] then {
write()
every i := 2 to lines do
write(i,ruler[*i + 1:0])
}
else write("\n",ruler)
end
##########
shuffile.icn
############################################################################
#
# Name: shuffile.icn
#
# Title: Shuffle lines in a file
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program writes a version of the input file with the lines
# shuffled. For example, the result of shuffling
#
# On the Future!-how it tells
# Of the rapture that impells
# To the swinging and the ringing
# Of the bells, bells, bells-
# Of the bells, bells, bells, bells,
# Bells, bells, bells-
# To the rhyming and the chiming of the bells!
#
# is
#
# To the rhyming and the chiming of the bells!
# To the swinging and the ringing
# Bells, bells, bells-
# Of the bells, bells, bells-
# On the Future!-how it tells
# Of the bells, bells, bells, bells,
# Of the rapture that impells
#
# Option: The option -s n sets the seed for random generation to n.
# The default seed is 0.
#
# Limitation:
#
# This program stores the input file in memory and
# shuffles pointers to the lines; there must be enough memory
# available to store the entire file.
#
############################################################################
#
# Links: options, shuffle
#
############################################################################
link options, shuffle
procedure main(args)
local opts, a
opts := options(args, "s+")
&random := \opts["s"]
a := []
every put(a,!&input)
every write(!shuffle(a))
end
##########
solit.icn
############################################################################
#
# Name: solit.icn
#
# Title: Play the game of solitaire
#
# Author: Jerry Nowlin
#
# Date: June 10, 1988
#
############################################################################
#
# This program was inspired by a solitaire game that was written
# by Allyn Wade and copyrighted by him in 1985. His game was
# designed for the IBM PC/XT/PCjr with a color or monochrome moni-
# tor.
#
# I didn't follow his design exactly because I didn't want to
# restrict myself to a specific machine. This program has the
# correct escape sequences programmed into it to handle several
# common terminals and PC's. It's commented well enough that most
# people can modify the source to work for their hardware.
#
# These variables must be defined with the correct escape
# sequences to:
#
# CLEAR - clear the screen
# CLREOL - clear to the end of line
# NORMAL - turn on normal video for foreground characters
# RED - make the foreground color for characters red
# BLACK - make the foreground color for characters black
#
# If there is no way to use red and black, the escape sequences
# should at least make RED and BLACK have different video attri-
# butes; for example red could have inverse video while black has
# normal video.
#
# There are two other places where the code is device dependent.
# One is in the face() procedure. The characters used to display
# the suites of cards can be modified there. For example, the IBM
# PC can display actual card face characters while all other
# machines currently use HDSC for hearts, diamonds, spades and
# clubs respectively.
#
# The last, and probably trickiest place is in the movecursor()
# procedure. This procedure must me modified to output the correct
# escape sequence to directly position the cursor on the screen.
# The comments and 3 examples already in the procedure will help.
#
# So as not to cast dispersions on Allyn Wade's program, I
# incorporated the commands that will let you cheat. They didn't
# exist in his program. I also incorporated the auto pilot command
# that will let the game take over from you at your request and try
# to win. I've run some tests, and the auto pilot can win about
# 10% of the games it's started from scratch. Not great but not
# too bad. I can't do much better myself without cheating. This
# program is about as totally commented as you can get so the logic
# behind the auto pilot is fairly easy to understand and modify.
# It's up to you to make the auto pilot smarter.
#
############################################################################
#
# Note:
#
# The command-line argument, which defaults to support for the VT100,
# determines the screen driver. For MS-DOS computers, the ANSI.SYS driver
# is needed.
#
############################################################################
global VERSION, CLEAR, CLREOL, NORMAL, RED, BLACK
global whitespace, amode, seed, deck, over, hidden, run, ace
procedure main(args)
local a, p, c, r, s, cnt, cheat, cmd, act, from, dest
VERSION := (!args == ("Atari ST" | "hp2621" | "IBM PC" | "vt100"))
case VERSION of {
"Atari ST": {
CLEAR := "\eE"
CLREOL := "\eK"
NORMAL := "\eb3"
RED := "\eb1"
BLACK := "\eb2"
}
"hp2621": {
CLEAR := "\eH\eJ"
CLREOL := "\eK"
NORMAL := "\e&d@"
RED := "\e&dJ"
BLACK := "\e&d@"
}
"IBM PC" | "vt100": {
CLEAR := "\e[H\e[2J"
CLREOL := "\e[0K"
NORMAL := "\e[0m"
RED := "\e[31m"
BLACK := "\e[34m"
}
default: { # same as IBM PC and vt100
CLEAR := "\e[H\e[2J"
CLREOL := "\e[0K"
NORMAL := "\e[0m"
RED := "\e[31m"
BLACK := "\e[34m"
}
}
# white space is blanks or tabs
whitespace := ' \t'
# clear the auto pilot mode flag
amode := 0
# if a command line argument started with "seed" use the rest of
# the argument for the random number generator seed value
if (a := !args)[1:5] == "seed" then seed := integer(a[5:0])
# initialize the data structures
deck := shuffle()
over := []
hidden := [[],[],[],[],[],[],[]]
run := [[],[],[],[],[],[],[]]
ace := [[],[],[],[]]
# lay down the 7 piles of cards
every p := 1 to 7 do every c := p to 7 do put(hidden[c],get(deck))
# turn over the top of each pile to start a run
every r := 1 to 7 do put(run[r],get(hidden[r]))
# check for aces in the runs and move them to the ace piles
every r := 1 to 7 do while getvalue(run[r][1]) = 1 do {
s := getsuite(!run[r])
push(ace[s],get(run[r]))
put(run[r],get(hidden[r]))
}
# initialize the command and cheat counts
cnt := cheat := 0
# clear the screen and display the initial layout
writes(CLEAR)
display()
# if a command line argument was "auto" let the auto pilot take over
if !args == "auto" then autopilot()
# loop reading commands
repeat {
# increment the command count
cnt +:= 1
# prompt for a command
movecursor(15,0)
writes("cmd:",cnt,"> ",CLREOL)
# scan the command line
(cmd := read() | exit()) ? {
# parse the one character action
tab(many(whitespace))
act := (move(1) | "")
tab(many(whitespace))
# switch on the action
case act of {
# turn on the automatic pilot
"a": autopilot()
# move a card or run of cards
"m": {
from := move(1) | whoops(cmd)
tab(many(whitespace))
dest := move(1) | whoops(cmd)
if not movecard(from,dest) then
whoops(cmd)
else if cardsleft() = 0 then
finish(cheat)
else &null
}
# thumb the deck
"t" | "": thumb()
# print some help
"h" | "?": disphelp()
# print the rules of the game
"r": disprules()
# give up without winning
"q": break
# shuffle the deck (cheat!)
"s": {
deck |||:= over
over := []
deck := shuffle(deck)
display(["deck"])
cheat +:= 1
}
# put hidden cards in the deck (cheat!)
"p": {
from := move(1) | whoops(cmd)
if integer(from) &
from >= 2 & from <= 7 &
*hidden[from] > 0 then {
deck |||:= hidden[from]
hidden[from] := []
display(["hide","deck"])
cheat +:= 1
} else {
whoops(cmd)
}
}
# print the contents of the deck (cheat!)
"d": {
movecursor(17,0)
write(*deck + *over," cards in deck:")
every writes(face(deck[*deck to 1 by -1])," ")
every writes(face(!over)," ")
writes("\nHit RETURN")
read()
movecursor(17,0)
every 1 to 4 do write(CLREOL)
cheat +:= 1
}
# print the contents of a hidden pile (cheat!)
"2" | "3" | "4" | "5" | "6" | "7": {
movecursor(17,0)
write(*hidden[act]," cards hidden under run ",
act)
every writes(face(!hidden[act])," ")
writes("\nHit RETURN")
read()
movecursor(17,0)
every 1 to 4 do write(CLREOL)
cheat +:= 1
}
# they gave an invalid command
default: whoops(cmd)
} # end of action case
} # end of scan line
} # end of command loop
# a quit command breaks the loop
movecursor(16,0)
writes(CLREOL,"I see you gave up")
if cheat > 0 then
write("...even after you cheated ",cheat," times!")
else
write("...but at least you didn't cheat...congratulations!")
exit(1)
end
# this procedure moves cards from one place to another
procedure movecard(from,dest,limitmove)
# if from and dest are the same fail
if from == dest then fail
# move a card from the deck
if from == "d" then {
# to one of the aces piles
if dest == "a" then {
return deck2ace()
# to one of the 7 run piles
} else if integer(dest) & dest >= 1 & dest <= 7 then {
return deck2run(dest)
}
# from one of the 7 run piles
} else if integer(from) & from >= 1 & from <= 7 then {
# to one of the aces piles
if dest == "a" then {
return run2ace(from)
# to another of the 7 run piles
} else if integer(dest) & dest >= 1 & dest <= 7 then {
return run2run(from,dest,limitmove)
}
}
# if none of the correct move combinations were found fail
fail
end
procedure deck2run(dest)
local fcard, dcard, s
# set fcard to the top of the overturned pile or fail
fcard := (over[1] | fail)
# set dcard to the low card of the run or to null if there are no
# cards in the run
dcard := (run[dest][-1] | &null)
# check to see if the move is legal
if chk2run(fcard,dcard) then {
# move the card and update the display
put(run[dest],get(over))
display(["deck",dest])
# while there are aces on the top of the overturned pile
# move them to the aces piles
while getvalue(over[1]) = 1 do {
s := getsuite(over[1])
push(ace[s],get(over))
display(["deck","ace"])
}
return
}
end
procedure deck2ace()
local fcard, a, s
# set fcard to the top of the overturned pile or fail
fcard := (over[1] | fail)
# for every ace pile
every a := !ace do {
# if the top of the ace pile is one less than the from card
# they are in the same suit and in sequence
if a[-1] + 1 = fcard then {
# move the card and update the display
put(a,get(over))
display(["deck","ace"])
# while there are aces on the top of the overturned
# pile move them to the aces piles
while getvalue(over[1]) = 1 do {
s := getsuite(!over)
push(ace[s],get(over))
display(["deck","ace"])
}
return
}
}
end
procedure run2ace(from)
local fcard, a, s
# set fcard to the low card of the run or fail if there are no
# cards in the run
fcard := (run[from][-1] | fail)
# for every ace pile
every a := !ace do {
# if the top of the ace pile is one less than the from card
# they are in the same suit and in sequence
if a[-1] + 1 = fcard then {
# move the card and update the display
put(a,pull(run[from]))
display([from,"ace"])
# if the from run is now empty and there are hidden
# cards to expose
if *run[from] = 0 & *hidden[from] > 0 then {
# while there are aces on the top of the
# hidden pile move them to the aces piles
while getvalue(hidden[from][1]) = 1 do {
s := getsuite(hidden[from][1])
push(ace[s],get(hidden[from]))
display(["ace"])
}
# put the top hidden card in the empty run
# and display the hidden counts
put(run[from],get(hidden[from]))
display(["hide"])
}
# update the from run display
display([from])
return
}
}
end
procedure run2run(from,dest,limitmove)
local fcard, dcard, s
# set fcard to the high card of the run or fail if there are no
# cards in the run
fcard := (run[from][1] | fail)
# set dcard to the low card of the run or null if there are no
# cards in the run
dcard := (run[dest][-1] | &null)
# avoid king thrashing in automatic mode (there's no point in
# moving a king high run to an empty run if there are no hidden
# cards under the king high run to be exposed)
if amode > 0 & /dcard & getvalue(fcard) = 13 & *hidden[from] = 0 then
fail
# avoid wasted movement if the limit move parameter was passed
# (there's no point in moving a pile if there are no hidden cards
# under it unless you have a king in the deck)
if amode > 0 & \limitmove & *hidden[from] = 0 then fail
# check to see if the move is legal
if chk2run(fcard,dcard) then {
# add the from run to the dest run
run[dest] |||:= run[from]
# empty the from run
run[from] := []
# display the updated runs
display([from,dest])
# if there are hidden cards to expose
if *hidden[from] > 0 then {
# while there are aces on the top of the hidden
# pile move them to the aces piles
while getvalue(hidden[from][1]) = 1 do {
s := getsuite(hidden[from][1])
push(ace[s],get(hidden[from]))
display(["ace"])
}
# put the top hidden card in the empty run and
# display the hidden counts
put(run[from],get(hidden[from]))
display(["hide"])
}
# update the from run display
display([from])
return
}
end
procedure chk2run(fcard,dcard)
# if dcard is null the from card must be a king or
if ( /dcard & (getvalue(fcard) = 13 | fail) ) |
# if the value of dcard is one more than fcard and
( getvalue(dcard) - 1 = getvalue(fcard) &
# their colors are different they can be moved
getcolor(dcard) ~= getcolor(fcard) ) then return
end
# this procedure finishes a game where there are no hidden cards left and the
# deck is empty
procedure finish(cheat)
movecursor(16,0)
writes("\007I'll finish for you now\007")
# finish moving the runs to the aces piles
while movecard(!"7654321","a")
movecursor(16,0)
writes(CLREOL,"\007You WIN\007")
if cheat > 0 then
write("...but you cheated ",cheat," times!")
else
write("...and without cheating...congratulations!")
exit(0)
end
# this procedure takes over and plays the game for you
procedure autopilot()
local tseq, totdeck
movecursor(16,0)
writes("Going into automatic mode...")
# set auto pilot mode
amode := 1
# while there are cards that aren't in runs or the aces piles
while (cardsleft()) > 0 do {
# try to make any run to run plays that will uncover
# hidden cards
while movecard(!"7654321",!"1234567","hidden")
# try for a move that will leave an empty spot
if movecard(!"7654321",!"1234567") then next
# if there's no overturned card thumb the deck
if *over = 0 then thumb()
# initialize the thumbed sequence set
tseq := set()
# try thumbing the deck for a play
totdeck := *deck + *over
every 1 to totdeck do {
if movecard("d",!"1234567a") then break
insert(tseq,over[1])
thumb()
}
# if we made a deck to somewhere move continue
if totdeck > *deck + *over then next
# try for a run to ace play
if movecard(!"7654321","a") then next
# if we got this far and couldn't play give up
break
}
# position the cursor for the news
movecursor(16,28)
# if all the cards are in runs or the aces piles
if cardsleft() = 0 then {
writes("\007YEA...\007")
# finish moving the runs to the aces piles
while movecard(!"7654321","a")
movecursor(16,34)
write("I won!!!!!")
exit(0)
} else {
writes("I couldn't win this time")
# print the information needed to verify that the
# program couldn't win
movecursor(17,0)
writes(*deck + *over," cards in deck")
if *tseq > 0 then {
write("...final thumbing sequence:")
every writes(" ",face(!tseq))
}
write()
exit(1)
}
end
# this procedure updates the display
procedure display(parts)
local r, a, h, c, part, l
static long # a list with the length of each run
initial {
long := [1,1,1,1,1,1,1]
}
# if the argument list is empty or contains "all" update all parts
# of the screen
if /parts | !parts == "all" then {
long := [1,1,1,1,1,1,1]
parts := [ "label","hide","ace","deck",
"1","2","3","4","5","6","7" ]
}
# for every part in the argument list
every part := !parts do case part of {
# display the run number, aces and deck labels
"label" : {
every r := 1 to 7 do {
movecursor(1,7+(r-1)*5)
writes(r)
}
movecursor(1,56)
writes("ACES")
movecursor(6,56)
writes("DECK")
}
# display the hidden card counts
"hide" : {
every r := 1 to 7 do {
movecursor(1,9+(r-1)*5)
writes(0 < *hidden[r] | " ")
}
}
# display the aces piles
"ace" : {
movecursor(3,49)
every a := 1 to 4 do
writes(face(ace[a][-1]) | "---"," ")
}
# display the deck and overturned piles
"deck" : {
movecursor(8,54)
writes((*deck > 0 , " # ") | " "," ")
writes(face(!over) | " "," ")
}
# display the runs piles
"1" | "2" | "3" | "4" | "5" | "6" | "7" : {
l := ((long[part] > *run[part]) | long[part])
h := ((long[part] < *run[part]) | long[part])
l <:= 1
every c := l to h do {
movecursor(c+1,7+(part-1)*5)
writes(face(run[part][c]) | " ")
}
long[part] := *run[part]
}
}
return
end
# this procedure thumbs the deck 3 cards at a time
procedure thumb()
local s
# if the deck is all thumbed
if *deck = 0 then {
# if there are no cards in the overturned pile either return
if *over = 0 then return
# turn the overturned pile back over
while put(deck,pull(over))
}
# turn over 3 cards or at least what's left
every 1 to 3 do if *deck > 0 then push(over,get(deck))
display(["deck"])
# while there are aces on top of the overturned pile move them to
# the aces pile
while getvalue(over[1]) = 1 do {
s := getsuite(over[1])
push(ace[s],get(over))
display(["deck","ace"])
}
# if the overturned pile is empty again and there are still cards
# in the deck thumb again (this will only happen if the top three
# cards in the deck were aces...not likely but)
if *over = 0 & *deck > 0 then thumb()
return
end
# this procedure shuffles a deck of cards
procedure shuffle(cards)
static fulldeck # the default shuffle is a full deck of cards
initial {
# set up a full deck of cards
fulldeck := []
every put(fulldeck,1 to 52)
# if seed isn't already set use the time to set it
if /seed then seed := integer(&clock[1:3] ||
&clock[4:6] ||
&clock[7:0])
# seed the random number generator for the first time
&random := seed
}
# if no cards were passed use the full deck
/cards := fulldeck
# copy the cards (shuffling is destructive)
deck := copy(cards)
# shuffle the deck
every !deck :=: ?deck
return deck
end
procedure face(card)
static cstr, # the list of card color escape sequences
vstr, # the list of card value labels
sstr # the list of card suite labels
initial {
cstr := [RED,BLACK]
vstr := ["A",2,3,4,5,6,7,8,9,10,"J","Q","K"]
if \VERSION == "IBM PC" then
sstr := ["\003","\004","\005","\006"]
else
sstr := ["H","D","S","C"]
}
# return a string containing the correct color change escape sequence,
# the value and suite labels right justified in 3 characters,
# and the back to normal escape sequence
return cstr[getcolor(card)] ||
right(vstr[getvalue(card)] || sstr[getsuite(card)],3) ||
NORMAL
end
# a deck of cards is made up of 4 suites of 13 values; 1-13, 14-26, etc.
procedure getvalue(card)
return (card-1) % 13 + 1
end
# each suite of cards is made up of ace - king (1-13)
procedure getsuite(card)
return (card-1) / 13 + 1
end
# the first two suites are hearts and diamonds so all cards 1-26 are red
# and all cards 27-52 are black.
procedure getcolor(card)
return (card-1) / 26 + 1
end
# this procedure counts cards that aren't in runs or the aces piles
procedure cardsleft()
local totleft
# count the cards left in the deck and the overturned pile
totleft := *deck + *over
# add in the hidden cards
every totleft +:= *!hidden
return totleft
end
# this procedure implements a device dependent cursor positioning scheme
procedure movecursor(line,col)
if \VERSION == "Atari ST" then
writes("\eY",&ascii[33+line],&ascii[33+col])
else if \VERSION == "hp2621" then
writes("\e&a",col,"c",line,"Y")
else
writes("\e[",line,";",col,"H")
end
# all invalid commands call this procedure
procedure whoops(cmd)
local i, j
movecursor(15,0)
writes("\007Invalid Command: '",cmd,"'\007")
# this delay loop can be diddled for different machines
every i := 1 to 500 do j := i
movecursor(15,0)
writes("\007",CLREOL,"\007")
return
end
# display the help message
procedure disphelp()
static help
initial {
help := [
"Commands: t or RETURN : thumb the deck 3 cards at a time",
" m [d1-7] [1-7a] : move cards or runs",
" a : turn on the auto pilot (in case you get stuck)",
" s : shuffle the deck (cheat!)",
" p [2-7] : put a hidden pile into the deck (cheat!)",
" d : print the cards in the deck (cheat!)",
" [2-7] : print the cards in a hidden pile (cheat!)",
" h or ? : print this command summary",
" r : print the rules of the game",
" q : quit",
"",
"Moving: 1-7, 'd', or 'a' select the source and destination for a move. ",
" Valid moves are from a run to a run, from the deck to a run,",
" from a run to an ace pile, and from the deck to an ace pile.",
"",
"Cheating: Commands that allow cheating are available but they will count",
" against you in your next life!"
]
}
writes(CLEAR)
every write(!help)
writes("Hit RETURN")
read()
writes(CLEAR)
display()
return
end
# display the rules message
procedure disprules()
static rules
initial {
rules := [
"Object: The object of this game is to get all of the cards in each suit",
" in order on the proper ace pile.",
" ",
"Rules: Cards are played on the ace piles in ascending order: A,2,...,K. ",
" All aces are automatically placed in the correct aces pile as",
" they're found in the deck or in a pile of hidden cards. Once a",
" card is placed in an ace pile it can't be removed.",
"",
" Cards must be played in descending order: K,Q,..,2, on the seven",
" runs which are initially dealt. They must always be played on a",
" card of the opposite color. Runs must always be moved as a",
" whole, unless you're moving the lowest card on a run to the",
" correct ace pile.",
"",
" Whenever a whole run is moved, the top hidden card is turned",
" over, thus becoming the beginning of a new run. If there are no",
" hidden cards left, a space is created which can only be filled by",
" a king.",
"",
" The rest of the deck is thumbed 3 cards at a time, until you spot",
" a valid move. Whenever the bottom of the deck is reached, the",
" cards are turned over and you can continue thumbing."
]
}
writes(CLEAR)
every write(!rules)
writes("Hit RETURN")
read()
writes(CLEAR)
display()
return
end
##########
tablc.icn
############################################################################
#
# Name: tablc.icn
#
# Title: Tabulate characters in a file
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program tabulates characters and lists each character and
# the number of times it occurs. Characters are written using
# Icon's escape conventions. Line termination characters and other
# control characters are included in the tabulation.
#
# Options: The following options are available:
#
# -a Write the summary in alphabetical order of the charac-
# ters. This is the default.
#
# -n Write the summary in numerical order of the counts.
#
# -u Write only the characters that occur just once.
#
############################################################################
#
# Links: options
#
############################################################################
link options
procedure main(args)
local ccount, unique, order, s, a, pair, rwidth, opts
unique := 0 # switch to list unique usage only
order := 3 # alphabetical ordering switch
opts := options(args,"anu")
if \opts["a"] then order := 3
if \opts["n"] then order := 4
if \opts["u"] then unique := 1
ccount := table(0) # table of characters
while ccount[reads()] +:= 1
a := sort(ccount,order)
if unique = 1 then {
while s := get(a) do
if get(a) = 1 then write(s)
}
else {
rwidth := 0
every rwidth <:= *!a
while s := get(a) do
write(left(image(s),10),right(get(a),rwidth))
}
end
##########
tablw.icn
############################################################################
#
# Name: tablw.icn
#
# Title: Tabulate words in a file
#
# Author: Ralph E. Griswold
#
# Date: December 27, 1989
#
############################################################################
#
# This program tabulates words and lists number of times each
# word occurs. A word is defined to be a string of consecutive
# upper- and lowercase letters with at most one interior occurrence
# of a dash or apostrophe.
#
# Options: The following options are available:
#
# -a Write the summary in alphabetical order of the words.
# This is the default.
#
# -i Ignore case distinctions among letters; uppercase
# letters are mapped into to corresponding lowercase
# letters on input. The default is to maintain case dis-
# tinctions.
#
# -n Write the summary in numerical order of the counts.
#
# -l n Tabulate only words longer than n characters. The
# default is to tabulate all words.
#
# -u Write only the words that occur just once.
#
############################################################################
#
# Links: options, usage
#
############################################################################
link options, usage
global limit, icase
procedure main(args)
local wcount, unique, order, s, pair, lwidth, rwidth, max, opts, l, i
limit := 0 # lower limit on usage to list
unique := 0 # switch to list unique usage only
order := 3 # alphabetical ordering switch
opts := options(args,"ail+nu")
if \opts["a"] then order := 3
if \opts["n"] then order := 4
if \opts["u"] then unique := 1
if \opts["i"] then icase := 1
l := \opts["l"] | 1
if l <= 0 then Usage("-l needs positive parameter")
wcount := table(0) # table of words
every wcount[words()] +:= 1
wcount := sort(wcount,order)
if unique = 1 then {
while s := get(wcount) do
if get(wcount) = 1 then write(s)
}
else {
max := 0
rwidth := 0
i := 1
while i < *wcount do {
max <:= *wcount[i]
rwidth <:= *wcount[i +:= 1]
}
lwidth := max + 3
while write(left(get(wcount),lwidth),right(get(wcount),rwidth))
}
end
# generate words
#
procedure words()
local line, word
while line := read() do {
if \icase then line := map(line)
line ? while tab(upto(&letters)) do {
word := tab(many(&letters)) || ((tab(any('-\'')) ||
tab(many(&letters))) | "")
if *word > limit then suspend word
}
}
end
##########
textcnt.icn
############################################################################
#
# Name: textcnt.icn
#
# Title: Tabulate properties of text file
#
# Author: Ralph E. Griswold
#
# Date: December 27, 1989
#
############################################################################
#
# This program tabulates the number of characters, "words", and
# lines in standard input and gives the maxium and minimum line length.
#
############################################################################
procedure main()
local chars, words, lines, name, infile, max, min, line
chars := words := lines := 0
max := 0
min := 2 ^ 30 # larger than possible line length
while line := read(infile) do {
max <:= *line
min >:= *line
lines +:= 1
chars +:= *line + 1
line ? while tab(upto(&letters)) do {
words +:= 1
tab(many(&letters))
}
}
if min = 2 ^ 30 then
write("empty file")
else {
write("number of lines: ",right(lines,8))
write("number of words: ",right(words,8))
write("number of characters:",right(chars,8))
write()
write("longest line: ",right(max,8))
write("shortest line: ",right(min,8))
}
end
##########
trim.icn
############################################################################
#
# Name: trim.icn
#
# Title: Trim lines in a file
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program copies lines from standard input to standard out-
# put, truncating the lines at n characters and removing any trail-
# ing blanks. The default value for n is 80. For example,
#
# trim 70 <grade.txt >grade.fix
#
# copies grade.txt to grade.fix, with lines longer than 70 charac-
# ters truncated to 70 characters and the trailing blanks removed
# from all lines.
#
# The -f option causes all lines to be n characters long by
# adding blanks to short lines; otherwise, short lines are left as
# is.
#
############################################################################
#
# Links: options
#
############################################################################
link options
procedure main(args)
local n, pad, line, opts
opts := options(args,"f")
if \opts["f"] then pad := 1 else pad := 0
n := (0 <= integer(args[1])) | 80
while line := read() do {
line := line[1+:n]
line := trim(line)
if pad = 1 then line := left(line,n)
write(line)
}
end
##########
turing.icn
############################################################################
#
# Name: turing.icn
#
# Title: Simulate a Turing machine
#
# Author: Gregg M. Townsend
#
# Date: June 10, 1988
#
############################################################################
#
# This program simulates the operation of an n-state Turing machine,
# tracing all actions. The machine starts in state 1 with an empty tape.
#
# A description of the Turing machine is read from the file given as a
# comand-line argument, or from standard input if none is specified.
# Comment lines beginning with '#' are allowed, as are empty lines.
#
# The program states must be numbered from 1 and must appear in order.
# Each appears on a single line in this form:
#
# sss. wdnnn wdnnn
#
# sss is the state number in decimal. The wdnnn fields specify the
# action to be taken on reading a 0 or 1 respectively:
#
# w is the digit to write (0 or 1)
# d is the direction to move (L/l/R/r, or H/h to halt)
# nnn is the next state number (0 if halting)
#
# Sample input file:
#
# 1. 1r2 1l3
# 2. 1l1 1r2
# 3. 1l2 1h0
#
# One line is written for each cycle giving the cycle number, current
# state, and an image of that portion of the tape that has been visited
# so far. The current position is indicated by reverse video (using
# ANSI terminal escape sequences).
#
# Input errors are reported to standard error output and inhibit
# execution.
#
# Bugs:
#
# Transitions to nonexistent states are not detected.
# Reverse video should be parameterizable or at least optional.
# There is no way to limit the number of cycles.
# Infinite loops are not detected. (Left as an excercise... :-)
#
# Reference:
#
# Scientific American, August 1984, pp. 19-23. A. K. Dewdney's
# discussion of "busy beaver" turing machines in his "Computer
# Recreations" column motivated this program. The sample above
# is the three-state busy beaver.
#
############################################################################
#
# Links: options
#
############################################################################
link options
record action (wrt, mov, nxs)
global machine, lns, lno, errs
global cycle, tape, posn, state, video
procedure main(args)
local opts
opts := options(args,"v")
video := \opts["v"]
rdmach(&input) # read machine description
if errs > 0 then stop("[execution suppressed]")
lns := **machine # initialize turing machine
tape := "0"
posn := 1
cycle := 0
state := 1
while state > 0 do { # execute
dumptape()
transit(machine[state][tape[posn]+1])
cycle +:= 1
}
dumptape()
end
# dumptape - display current tape contents on screen
procedure dumptape()
if cycle < 10 then writes(" ")
writes(cycle,". [",right(state,lns),"] ",tape[1:posn])
if \video then write("\e[7m",tape[posn],"\e[m",tape[posn + 1:0])
else {
write(tape[posn:0])
write(repl(" ",6 + *state + posn),"^")
}
end
# transit (act) - transit to the next state peforming the given action
procedure transit(act)
tape[posn] := act.wrt
if act.mov == "R" then {
posn +:= 1
if posn > *tape then tape ||:= "0"
}
else if act.mov == "L" then {
if posn = 1 then tape := "0" || tape
else posn -:= 1
}
state := act.nxs
return
end
# rdmach (f) - read machine description from the given file
procedure rdmach(f)
local nstates, line, a0, a1,n
machine := list()
nstates := 0
lno := 0
errs := 0
while line := trim(read(f),' \t') do {
lno +:= 1
if *line > 0 & line[1] ~== "#"
then line ? {
tab(many(' \t'))
n := tab(many(&digits)) | 0
if n ~= nstates + 1 then warn("sequence error")
nstates := n
tab(many('. \t'))
a0 := tab(many('01LRHlrh23456789')) | ""
tab(many(' \t'))
a1 := tab(many('01LRHlrh23456789')) | ""
pos(0) | (warn("syntax error") & next)
put(machine,[mkact(a0),mkact(a1)])
}
}
lno := "<EOF>"
if *machine = errs = 0 then warn("no machine!")
return
end
# mkact (a) - construct the action record specified by the given string
procedure mkact(a)
local w, m, n
w := a[1] | "9"
m := map(a[2],&lcase,&ucase) | "X"
(any('01',w) & any('LRH',m)) | warn("syntax error")
n := integer(a[3:0]) | (warn("bad nextstate"), 0)
return action (w, m, n)
end
# warn (msg) - report an error in the machine description
procedure warn(msg)
write(&errout, "line ", lno, ": ", msg)
errs +:= 1
return
end
##########
unique.icn
############################################################################
#
# Name: unique.icn
#
# Title: Filter out identical adjacent lines
#
# Author: Anthony Hewitt
#
# Date: December 22, 1989
#
############################################################################
#
# Filters out identical adjacent lines in a file.
#
############################################################################
procedure main()
local s
write(s := !&input)
every write(s ~==:= !&input)
end
##########
unpack.icn
############################################################################
#
# Name: unpack.icn
#
# Title: Unpackage files
#
# Author: Ralph E. Griswold
#
# Date: May 27, 1989
#
############################################################################
#
# This program unpackages files produced by pack.icn. See that program
# for information about limitations.
#
############################################################################
#
# See also: pack.icn
#
############################################################################
procedure main()
local line, out
while line := read() do {
if line == "##########" then {
close(\out)
out := open(name := read(),"w") | stop("cannot open ",name)
}
else write(out,line)
}
end
##########
vnq.icn
############################################################################
#
# Name: vnq.icn
#
# Title: Display solutions to n-queens problem
#
# Author: Stephen B. Wampler
#
# Date: December 12, 1989
#
############################################################################
#
# Links: options
#
############################################################################
link options
global n, nthq, solution, goslow, showall, line, border
procedure main(args)
local i, opts
opts := options(args, "sah")
n := integer(get(args)) | 8 # default is 8 queens
if \opts["s"] then goslow := "yes"
if \opts["a"] then showall := "yes"
if \opts["h"] then helpmesg()
line := repl("| ", n) || "|"
border := repl("----", n) || "-"
clearscreen()
movexy(1, 1)
write()
write(" ", border)
every 1 to n do {
write(" ", line)
write(" ", border)
}
nthq := list(n+2) # need list of queen placement routines
solution := list(n) # ... and a list of column solutions
nthq[1] := &main # 1st queen is main routine.
every i := 1 to n do # 2 to n+1 are real queen placement
nthq[i+1] := create q(i) # routines, one per column.
nthq[n+2] := create show() # n+2nd queen is display routine.
write(n, "-Queens:")
@nthq[2] # start by placing queen in first colm.
movexy(1, 2 * n + 5)
end
# q(c) - place a queen in column c (this is c+1st routine).
procedure q(c)
local r
static up, down, rows
initial {
up := list(2 * n -1, 0)
down := list(2 * n -1, 0)
rows := list(n, 0)
}
repeat {
every (0 = rows[r := 1 to n] = up[n + r - c] = down[r + c -1] &
rows[r] <- up[n + r - c] <- down[r + c -1] <- 1) do {
solution[c] := r # record placement.
if \showall then {
movexy(4 * (r - 1) + 5, 2 * c + 1)
writes("@")
}
@nthq[c + 2] # try to place next queen.
if \showall then {
movexy(4 * (r - 1) + 5, 2 * c + 1)
writes(" ")
}
}
@nthq[c] # tell last queen placer 'try again'
}
end
# show the solution on a chess board.
procedure show()
local c
static count, lastsol
initial {
count := 0
}
repeat {
if /showall & \lastsol then {
every c := 1 to n do {
movexy(4 * (lastsol[c] - 1) + 5, 2 * c + 1)
writes(" ")
}
}
movexy(1, 1)
write("solution: ", right(count +:= 1, 10))
if /showall then {
every c := 1 to n do {
movexy(4 * (solution[c] - 1) + 5, 2 * c + 1)
writes("Q")
}
lastsol := copy(solution)
}
if \goslow then {
movexy(1, 2 * n + 4)
writes("Press return to see next solution:")
read() | {
movexy(1, 2 * n + 5)
stop("Aborted.")
}
movexy(1, 2 * n + 4)
clearline()
}
@nthq[n+1] # tell last queen placer to try again
}
end
procedure helpmesg()
write(&errout, "Usage: vnq [-s] [-a] [n]")
write(&errout, " where -s means to stop after each solution, ")
write(&errout, " -a means to show placement of every queen")
write(&errout, " while trying to find a solution")
write(&errout, " and n is the size of the board (defaults to 8)")
stop()
end
# Move cursor to x, y
#
procedure movexy (x, y)
writes("\^[[", y, ";", x, "H")
return
end
#
# Clear the text screen
#
procedure clearscreen()
writes("\^[[2J")
return
end
#
# Clear the rest of the line
#
procedure clearline()
writes("\^[[2K")
return
end
##########
zipsort.icn
############################################################################
#
# Name: zipsort.icn
#
# Title: Sort mailing labels by ZIP code
#
# Author: Ralph E. Griswold
#
# Date: June 10, 1988
#
############################################################################
#
# This program sorts labels produced by labels in ascending
# order of their postal zip codes.
#
# Option:
#
# The option -d n sets the number of lines per label to n.
# The default is 9. This value must agree with the value used to
# format the labels.
#
# Zip Codes:
#
# The zip code must be the last nonblank string at the
# end of the label. It must consist of digits but may have an
# embedded dash for extended zip codes. If a label does not end
# with a legal zip code, it is placed after all labels with legal
# zip codes. In such a case, an error messages also is written to
# standard error output.
#
############################################################################
#
# Links: options
#
# See also: labels.icn
#
############################################################################
link options
procedure main(args)
local t, a, label, zip, y, lsize, opts
opts := options(args,"d+")
lsize := (0 > integer(opts["d"])) | 9
t := table("")
repeat {
label := ""
every 1 to lsize do
label ||:= read() || "\n" | break break
label ? {
while tab(upto(' ')) do tab(many(' '))
zip := tab(upto('-') | 0)
zip := integer(zip) | write(&errout,"*** illegal zipcode: ",label)
}
t[zip] ||:= label
}
a := sort(t,3)
while get(a) do
writes(get(a))
end
