diff options
Diffstat (limited to 'ipl/progs')
274 files changed, 41729 insertions, 0 deletions
diff --git a/ipl/progs/adlcheck.icn b/ipl/progs/adlcheck.icn new file mode 100644 index 0000000..9b5a01c --- /dev/null +++ b/ipl/progs/adlcheck.icn @@ -0,0 +1,105 @@ +############################################################################ +# +# File: adlcheck.icn +# +# Subject: Program to check for bad address list data +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program checks address lists for correctness. +# +# There are five options: +# +# -s Check state (U.S. labels only) +# -z Check ZIP code (U.S. labels only) +# -c Check country name (a very heuristic check) +# -a Check all of the above +# -d Report addresses that exceed "standard dimensions" for labels: +# 40 character line length, 8 lines per entry +# +############################################################################ +# +# See also: address.doc, adlcount.icn, adlfiltr.icn, adllist.icn, +# adlsort,icn, labels.icn +# +# Links: adlutils, options +# +############################################################################ + +link adlutils, options + +procedure main(args) + local opts, choice, item, badchar, print, states, i, line, dim, add + + states := set(["AK", "AL", "AR", "AS", "AZ", "CA", "CO", "CT", "DC", + "DE", "FL", "FM", "GA", "GU", "HI", "IA", "ID", "IL", "IN", "KS", + "KY", "LA", "MA", "MD", "ME", "MH", "MI", "MN", "MO", "MP", "MS", + "MT", "NC", "ND", "NE", "NH", "NJ", "NM", "NV", "NY", "OH", "OK", + "ON", "OR", "PA", "PR", "PW", "RI", "SC", "SD", "TN", "TX", "UT", + "VA", "VT", "WA", "WI", "WV", "WY"]) + + print := "" + + badchar := ~&ucase -- ' .' # very heuristic country name check + + opts := options(args,"acszd") + if \opts["a"] then { # if -a, do all + opts["a"] := &null + every opts[!"csz"] := 1 + } + if \opts["d"] then dim := write(1) # dimension check + + while add := nextadd() do { + add.text ? { + i := 0 + while line := tab(upto('\n') | 0) do { + i +:= 1 + if *line > 40 then print ||:= "o" + move(1) | break + } + if i > 8 then print ||:= "o" + } + + every \opts[choice := !"csz"] do + case choice of { + "c": { # check country name + get_country(add) ? { + if upto(badchar) then { + print ||:= choice + } + } + } + "s": { # check state + if not member(states,get_state(add)) then { + print ||:= choice + } + } + "z": { + if get_zipcode(add) == "9999999999" then { + print ||:= choice + } + } + } + if *print > 0 then { + every choice := !print do + write("*** ",case choice of { + "c": "bad country name" + "s": "bad state abbreviation" + "z": "bad ZIP code" + "o": \dim & "size exceeds label dimensions" + }) + write() + writeadd(add) + print := "" + } + } + +end diff --git a/ipl/progs/adlcount.icn b/ipl/progs/adlcount.icn new file mode 100644 index 0000000..e47d3ff --- /dev/null +++ b/ipl/progs/adlcount.icn @@ -0,0 +1,40 @@ +############################################################################ +# +# File: adlcount.icn +# +# Subject: Program to count address list entries +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program counts the number of entries in an address list file. +# If an argument is given, it counts only those that have designators +# with characters in the argument. Otherwise, it counts all entries. +# +############################################################################ +# +# See also: address.doc, adlcheck.icn, adlfiltr.icn, adllist.icn, +# adlsort,icn, labels.icn +# +############################################################################ + +procedure main(arg) + local s, count + + s := cset(arg[1]) | &cset + + count := 0 + every !&input ? { + any('#') & upto(s) \ 1 + } do + count +:= 1 + write(count) + +end diff --git a/ipl/progs/adlfiltr.icn b/ipl/progs/adlfiltr.icn new file mode 100644 index 0000000..656a163 --- /dev/null +++ b/ipl/progs/adlfiltr.icn @@ -0,0 +1,58 @@ +############################################################################ +# +# File: adlfiltr.icn +# +# Subject: Program to filter address list entries +# +# Author: Ralph E. Griswold +# +# Date: September 2, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program filters address lists, allowing through only those entries +# with specified selectors. +# +# The options are: +# +# -s arg selects entries with characters in args (default is all) +# -x inverts the logic, selecting characters not in args +# +############################################################################ +# +# See also: address.doc, adlcheck.icn, adlcount.icn, adllist.icn, +# adlsort,icn, labels.icn +# +# Links: adlutils, options +# +############################################################################ + +link adlutils, options + +procedure main(args) + local selectors, add, opts + + opts := options(args,"xs:") + + selectors := cset(\opts["s"]) | &cset + + if /opts["x"] then { + while add := nextadd() do + add.header ? { + move(1) + if upto(selectors) then writeadd(add) + } + } + else { + while add := nextadd() do + add.header ? { + move(1) + if not upto(selectors) then writeadd(add) + } + } + +end diff --git a/ipl/progs/adlfirst.icn b/ipl/progs/adlfirst.icn new file mode 100644 index 0000000..0a10864 --- /dev/null +++ b/ipl/progs/adlfirst.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: adlfirst.icn +# +# Subject: Program to write first line of addresses +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes the first lines of entries in an address list file. +# If an argument is given, it counts only those that have designators +# with characters in the argument. Otherwise, it counts all entries. +# +############################################################################ +# +# See also: address.doc, adlcheck.icn, adlfiltr.icn, adllist.icn, +# adlsort,icn, labels.icn +# +############################################################################ + +procedure main(arg) + local s, line + + s := cset(arg[1]) | &cset + + while line := read() do + line ? { + if any('#') & upto(s) then { + while line := read() | exit() do + if line[1] == ("*" | "#" ) then next + else { + write(line) + break + } + } + } + +end diff --git a/ipl/progs/adllist.icn b/ipl/progs/adllist.icn new file mode 100644 index 0000000..9906a91 --- /dev/null +++ b/ipl/progs/adllist.icn @@ -0,0 +1,79 @@ +############################################################################ +# +# File: adllist.icn +# +# Subject: Program to list address list fields +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists entries in address lists. The options are: +# +# -c by country +# -n by name +# -C by city (U.S. only) +# -s by state (U.S. only) +# -z by ZIP code (U.S. only) +# +# The default is -n. If more than one option is specified, the +# order of dominance is -n -z -s -c -C. +# +############################################################################ +# +# See also: address.doc, adlcheck.icn, adlcount.icn, adlfiltr.icn, +# adlsort,icn, labels.icn +# +# Links: adlutils, options +# +############################################################################ + +link adlutils, options + +procedure main(args) + local item, item_lists, opts, list_method, get_item, add + + item_lists := table() + + list_method := "n" # The default is sorting by name. + get_item := get_lastname + + opts := options(args,"cnszC") + + if \opts["C"] then { # If more than one given, last applies. + list_method := "C" + get_item := get_city + } + if \opts["c"] then { # If more than one given, last applies. + list_method := "c" + get_item := get_country + } + if \opts["s"] then { + list_method := "s" + get_item := get_state + } + if \opts["z"] then { + list_method := "z" + get_item := get_zipcode + } + if \opts["n"] then { + list_method := "n" + get_item := get_lastname + } + + case list_method of { + "s" | "z" | "C": while add := nextadd() do + write(get_item(add)) + "c" : while add := nextadd() do + write(format_country(get_item(add))) + "n" : while add := nextadd() do + write(get_namepfx(add)," ",get_item(add)) + } + +end diff --git a/ipl/progs/adlsort.icn b/ipl/progs/adlsort.icn new file mode 100644 index 0000000..e0ce9b1 --- /dev/null +++ b/ipl/progs/adlsort.icn @@ -0,0 +1,92 @@ +############################################################################ +# +# File: adlsort.icn +# +# Subject: Program to sort address list entries +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program sorts entries in address lists. The options are: +# +# -c by country +# -n by name +# -z by ZIP code +# +# The default is -n. If more than one option is specified, the +# order of dominance is -n -z -c. +# +############################################################################ +# +# See also: address.doc, adlcount.icn, adlfiltr.icn, adllist.icn, +# adlsort,icn, labels.icn +# +# Links: adlutils, options, namepfx +# +############################################################################ + +link adlutils, options, namepfx + +procedure main(args) + local item, item_lists, opts, sort_method, get_item, add, names, prefixes + local prefix + + item_lists := table() + + sort_method := "n" # The default is sorting by name. + get_item := get_lastname + + opts := options(args,"cnz") + + if \opts["c"] then { # If more than one given, last applies. + sort_method := "c" + get_item := get_country + } + if \opts["z"] then { + sort_method := "z" + get_item := get_zipcode + } + if \opts["n"] then { + sort_method := "n" + get_item := get_lastname + } + + while add := nextadd() do { + item := get_item(add) + /item_lists[item] := [] + put(item_lists[item],add) + } + + item_lists := sort(item_lists,3) + + if sort_method == ("c" | "z") then { + while get(item_lists) do + every writeadd(!get(item_lists)) + } + + else if sort_method == "n" then { + while get(item_lists) do { + names := get(item_lists) + if *names = 1 then writeadd(names[1]) # avoid flap for common case + else { + prefixes := table() + every add := !names do { + prefix := namepfx(add.text) + /prefixes[prefix] := [] + put(prefixes[prefix],add) + } + prefixes := sort(prefixes,3) + while get(prefixes) do + every writeadd(!get(prefixes)) + } + } + } + +end diff --git a/ipl/progs/animal.icn b/ipl/progs/animal.icn new file mode 100644 index 0000000..46497ef --- /dev/null +++ b/ipl/progs/animal.icn @@ -0,0 +1,223 @@ +############################################################################ +# +# File: animal.icn +# +# Subject: Program to play "animal" guessing game +# +# Author: Robert J. Alexander +# +# Date: March 2, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This is the familiar ``animal game'' written in Icon. The +# program asks its human opponent a series of questions in an attempt +# to guess what animal he or she is thinking of. It is an ``expert +# system'' that starts out with limited knowledge, knowing only one +# question, 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 saved file +# is an editable text file, so typos entered during the heat of battle +# can be corrected. +# +# The game is not limited to guessing only animals. By simply +# modifying the first two lines of procedure "main" a program can be +# created that will happily build a knowledge base in other categories. +# For example, the lines: +# +# GameObject := "president" +# Tree := Question("Has he ever been known as Bonzo", +# "Reagan","Lincoln") +# +# can be substituted, the program works reasonably well, and could even +# pass as educational. The knowledge files will automatically be kept +# separate, too. +# +# Typing "list" at any yes/no prompt will show an inventory of +# animals known, and there are some other commands too (see procedure +# Confirm). +# +############################################################################ + +global GameObject,Tree,Learn +record Question(question,yes,no) + +# +# Main procedure. +# +procedure main() + GameObject := "animal" + Tree := Question("Does it live in water","goldfish","canary") + Get() # Recall prior knowledge + Game() # Play a game + return +end + +# +# Game() -- Conducts a game. +# +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 + +# +# Confirm() -- Handles yes/no questions and answers. +# +procedure Confirm(q[]) + local answer,s + static ok + initial { + ok := table() + every ok["y" | "yes" | "yeah" | "uh huh"] := "yes" + every ok["n" | "no" | "nope" | "uh uh" ] := "no" + } + while /answer do { + every writes(!q) + write("?") + case s := read() | exit(1) of { + # + # Commands recognized at a yes/no prompt. + # + "save": Save() + "get": Get() + "list": List() + "dump": Output(Tree) + default: { + (answer := \ok[map(s,&ucase,&lcase)]) | + write("This is a \"yes\" or \"no\" question.") + } + } + } + return answer == "yes" +end + +# +# Ask() -- Navigates through the barrage of questions leading to a +# guess. +# +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 + +# +# Article() -- Come up with the appropriate indefinite article. +# +procedure Article(word) + return if any('aeiouAEIOU',word) then "an" else "a" +end + +# +# Save() -- Store our acquired knowledge in a disk file name +# based on the GameObject. +# +procedure Save() + local f + f := open(GameObject || "s","w") + Output(Tree,f) + close(f) + return +end + +# +# Output() -- Recursive procedure used to output the knowledge tree. +# +procedure Output(node,f,sense) + static indent + initial indent := 0 + /f := &output + /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 + +# +# Get() -- Read in a knowledge base from a disk file. +# +procedure Get() + local f + f := open(GameObject || "s","r") | fail + Tree := Input(f) + close(f) + return +end + +# +# Input() -- Recursive procedure used to input the knowledge tree. +# +procedure Input(f) + local nodetype,s + read(f) ? (tab(upto(~' \t')) & =("y" | "n" | "") & + nodetype := move(1) & move(2) & s := tab(0)) + return if nodetype == "Q" then Question(s,Input(f),Input(f)) else s +end + +# +# List() -- Lists the objects in the knowledge base. +# +procedure List() + local lst,line,item + lst := Show(Tree,[]) + line := "" + every item := !sort(lst) do { + if *line + *item > 78 then { + write(trim(line)) + line := "" + } + line ||:= item || ", " + } + write(line[1:-2]) + return +end + +# +# Show() -- Recursive procedure used to navigate the knowledge tree. +# +procedure Show(node,lst) + if type(node) == "Question" then { + lst := Show(node.yes,lst) + lst := Show(node.no,lst) + } + else put(lst,node) + return lst +end diff --git a/ipl/progs/applyfnc.icn b/ipl/progs/applyfnc.icn new file mode 100644 index 0000000..22837e9 --- /dev/null +++ b/ipl/progs/applyfnc.icn @@ -0,0 +1,30 @@ +############################################################################ +# +# File: applyfnc.icn +# +# Subject: Program to apply function to lines of a file +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program applies a function specified on the command line to the +# lines of a file. +# +############################################################################ + +procedure main(args) + local func + + func := args[1] | stop("*** no function specified") + + while args[1] := read() do + every write(func ! args) + +end diff --git a/ipl/progs/banner.icn b/ipl/progs/banner.icn new file mode 100644 index 0000000..429cee1 --- /dev/null +++ b/ipl/progs/banner.icn @@ -0,0 +1,125 @@ +############################################################################ +# +# File: banner.icn +# +# Subject: Program to display banner +# +# Author: Chris Tenaglia +# +# Date: September 21, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Here is a a handy little code fragment called banner. I +# know icon is mostly in the unix world and unix already has a banner +# command. But I'm mostly in the DOS and VMS world so I offer this little +# banner code. It outputs enlarged letters (5x6 matrix) portraite. With a +# little diddling you can change the scale or font since this is the source. +# Maybe it can be made to take an input file as a font, and maybe even from +# xwindows. But this is a simple one. I include a main() procedure that +# calls it so you can test it and build from there. Enjoy! +# +############################################################################ + +procedure main(param) + + if &features == ("MS-DOS" | "MS-DOS/386" | "NT") then system("cls") + else if &features == "UNIX" then system("clear") + + every write(!banner(param[1])) + end + +# +# a bbbb cccc dddd eeeee fffff gggg h h iii jjj k k l m m +# a a b b c d d e f g h h i j k k l mm mm +# a a bbbb c d d eee fff g hhhhh i j kk l m m m +# aaaaa b b c d d e f g gg h h i j k k l m m +# a a b b c d d e f g g h h i j j k k l m m +# a a bbbb cccc dddd eeeee f gggg h h iii jj k k lllll m m +# +# n n ooo pppp qqq rrrr ssss ttttt u u v v w w x x y y zzzzz +# nn n o o p p q q r r s t u u v v w w x x y y z +# n n n o o pppp q q rrrr sss t u u v v w w w x y z +# n nn o o p q q q r r s t u u v v ww ww x x y z +# n n o o p q qq r r s t u u v v w w x x y z +# n n ooo p qqqq r r ssss t uuu v w w x x y zzzzz +# +# +# 1 222 3333 4 4 55555 666 77777 888 999 00000 +# 11 2 2 3 4 4 5 6 7 8 8 9 9 0 0 +# 1 2 3333 44444 5555 6666 7 888 9999 0 00 +# 1 2 3 4 5 6 6 7 8 8 9 0 0 0 +# 1 2 3 4 5 6 6 7 8 8 9 00 0 +# 111 22222 3333 4 5555 666 7 888 999 00000 +# +# +# +# ??? !! ::: +# ? ? !! ::: / +# ? !! // ----- +# ? !! // ----- +# ::: ... // +# ? !! ::: ... // +# +# + procedure banner(str) + local bline, byte, raster, i + static alphabet + initial { + alphabet := table("") + alphabet["a"] := [" A "," A A ","A A ","AAAAA ","A A ","A A "] + alphabet["b"] := ["BBBB ","B B ","BBBB ","B B ","B B ","BBBB "] + alphabet["c"] := [" CCCC ","C ","C ","C ","C "," CCCC "] + alphabet["d"] := ["DDDD ","D D ","D D ","D D ","D D ","DDDD "] + alphabet["e"] := ["EEEEE ","E ","EEE ","E ","E ","EEEEE "] + alphabet["f"] := ["FFFFF ","F ","FFF ","F ","F ","F "] + alphabet["g"] := [" GGGG ","G ","G ","G GG ","G G "," GGGG "] + alphabet["h"] := ["H H ","H H ","HHHHH ","H H ","H H ","H H "] + alphabet["i"] := [" III "," I "," I "," I "," I "," III "] + alphabet["j"] := [" JJJ "," J "," J "," J ","J J "," JJ "] + alphabet["k"] := ["K K ","K k ","KK ","K K ","K K ","K K "] + alphabet["l"] := ["L ","L ","L ","L ","L ","LLLLL "] + alphabet["m"] := ["M M ","MM MM ","M M M ","M M ","M M ","M M "] + alphabet["n"] := ["N N ","NN N ","N N N ","N NN ","N N ","N N "] + alphabet["o"] := [" OOO ","O O ","O O ","O O ","O O "," OOO "] + alphabet["p"] := ["PPPP ","P P ","PPPP ","P ","P ","P "] + alphabet["q"] := [" QQQ ","Q Q ","Q Q ","Q Q Q ","Q QQ "," QQQQ "] + alphabet["r"] := ["RRRR ","R R ","RRRR ","R R ","R R ","R R "] + alphabet["s"] := [" SSSS ","s "," SSS "," S "," S ","SSSS "] + alphabet["t"] := ["TTTTT "," T "," T "," T "," T "," T "] + alphabet["u"] := ["U U ","U U ","U U ","U U ","U U "," UUU "] + alphabet["v"] := ["V V ","V V ","V V ","V V "," V V "," V "] + alphabet["w"] := ["W W ","W W ","W W W ","WW WW ","W W ","W W "] + alphabet["x"] := ["X X "," X X "," X "," X X ","X X ","X X "] + alphabet["y"] := ["Y Y "," Y Y "," Y "," Y "," Y "," Y "] + alphabet["z"] := ["ZZZZZ "," Z "," Z "," Z ","Z ","ZZZZZ "] + alphabet[" "] := [" "," "," "," "," "," "] + alphabet["1"] := [" 1 "," 11 "," 1 "," 1 "," 1 "," 111 "] + alphabet["2"] := [" 222 ","2 2 "," 2 "," 2 "," 2 ","22222 "] + alphabet["3"] := ["3333 "," 3 ","3333 "," 3 "," 3 ","3333 "] + alphabet["4"] := ["4 4 ","4 4 ","44444 "," 4 "," 4 "," 4 "] + alphabet["5"] := ["55555 ","5 ","5555 "," 5 "," 5 ","5555 "] + alphabet["6"] := [" 666 ","6 ","6666 ","6 6 ","6 6 "," 666 "] + alphabet["7"] := ["77777 "," 7 "," 7 "," 7 "," 7 "," 7 "] + alphabet["8"] := [" 888 ","8 8 "," 888 ","8 8 ","8 8 "," 888 "] + alphabet["9"] := [" 999 ","9 9 "," 9999 "," 9 "," 9 "," 999 "] + alphabet["0"] := ["00000 ","0 0 ","0 00 ","0 0 0 ","00 0 ","00000 "] + alphabet[":"] := [" ::: "," ::: "," "," "," ::: "," ::: "] + alphabet["!"] := [" !! "," !! "," !! "," !! "," "," !! "] + alphabet["."] := [" "," "," "," "," ... "," ... "] + alphabet["?"] := [" ??? ","? ? "," ? "," ? "," "," ? "] + alphabet["/"] := [" "," / "," // "," // "," // ","// "] + alphabet["-"] := [" "," ","----- ","----- "," "," "] + } + bline := ["","","","","",""] + every byte := !str do + { + raster := alphabet[map(byte)] + every i := 1 to 6 do bline[i] ||:= raster[i] + } + return bline + end diff --git a/ipl/progs/based.icn b/ipl/progs/based.icn new file mode 100644 index 0000000..518c677 --- /dev/null +++ b/ipl/progs/based.icn @@ -0,0 +1,540 @@ +############################################################################ +# +# File: based.icn +# +# Subject: Program to do BASIC-style editing +# +# Author: Chris Tenaglia +# +# Date: February 18, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program models a line editor for BASIC. +# +############################################################################ + +global chars,program,cmd,token,name + +procedure main(param) + local ff, old + + if find("p",map(param[1])) then ff := "\014" + else ff := "\e[2J\e[H" + chars := &cset -- '\t ' + program := list() + name := &null + write("Basic Line Editor V1.3 by Tenaglia 910104.1700") + write(&host," ",&dateline,"\n") + + repeat + { + writes(">") + (cmd := read()) | { quit() ; next } + if cmd == "!!" then + { + cmd := old + write("> ",cmd) + } + token := parse(cmd) + if integer(token[1]) then + { + entry(token[1]) + token[1] := "" + } + old := cmd +#EJECT + case map(token[1]) of + { + "" : "ignore this case" + "load" : write(load()) + "save" : write(save()) + "resave" : write(resave()) + "read" : write(basread()) + "write" : write(baswrite()) + "merge" : write(merge()) + "new" : write(new()) + "list" : write(print()) + "renum" : write(renum()) + "del" : write(del()) + "dir" : write(dir()) + "size" : write("Buffer contains ",*program," lines.") + "find" : write(search()) + "cls" : write(ff) + "compile": write(compile()) + "build" : write(build()) + "test" : write(build(),run()) + "run" : write(run()) + "ver" : write("Basic Line Editor V1.3 by Tenaglia 910104.1700") + "date" : write(&host," ",&dateline) + "time" : write(&host," ",&dateline) + "help" : write(help()) + "?" : write(help()) + "$" : write(shell()) + "exit" : break + "quit" : break + default : write("\007What ?") + } + } + + write("Returning to operating system") + write(&host," ",&dateline) +end + +procedure quit() # allows CTRL_Z exit under VMS + local test + + writes("QUIT! Are you sure? Y/N :") + (test := read()) | stop("Returning to operating system\n",&host," ",&dateline) + if map(test)[1] == "y" then stop("Returning to operating system\n",&host," ",&dateline) + return + end + +#SUB LOAD, SAVE, AND RESAVE COMMANDS +#EJECT +procedure load() + local file, in, lnum + + if not(token[2]) then + { + writes("_file:") + if (file := string(read())) == "" then return + } else file := token[2] + lnum := 0 + (in := open(file)) | return ("Can't open " || file) + name := file + program := [] + while put(program,((lnum+:=10) || " " || read(in))) do + not(find("00",lnum)) | (writes(".")) + close(in) + return ("\n" || file || " loaded.") +end + +procedure save() + local file, i, line, lnum, out, text + + if not(token[2]) then + { + writes("_file:") + if (file := string(read())) == "" then return + } else file := token[2] + (out := open(file,"w")) | return ("Can't open " || file) + name := file + every line := !program do + { + i := upto(' \t',line) + lnum := line[1:i] + text := line[i+1:0] + write(out,text) + not(find("00",lnum)) | (writes(".")) + } + close(out) + return ("\n" || file || " saved.") +end + +procedure resave() + local i, line, lnum, out, text + + if not(string(name)) then return("Nothing LOADed to resave.") + (out := open(name,"w")) | return ("Can't open " || name) + every line := !program do + { + i := upto(' \t',line) + lnum := line[1:i] + text := line[i+1:0] + write(out,text) + not(find("00",lnum)) | (writes(".")) + } + close(out) + return ("\n" || name || " resaved.") +end +#SUB READ, WRITE, AND MERGE COMMANDS +#EJECT +procedure basread() + local file, in, line, lnum, test + + if not(token[2]) then + { + writes("_file:") + if (file := string(read())) == "" then return + } else file := token[2] + lnum := 0 + (in := open(file)) | return ("Can't open " || file) + name := file + program := [] + while line := read(in) do + { + test := (line[1:upto(' \t',line)]) | "" + if integer(test) then put(program,line) + not(find("00",(lnum+:=10))) | (writes(".")) + } + close(in) + return ("\n" || file || " read in.") +end + +procedure baswrite() + local file, lnum, out + + if not(token[2]) then + { + writes("_file:") + if (file := string(read())) == "" then return + } else file := token[2] + (out := open(file,"w")) | return ("Can't open " || file) + name := file ; lnum := 0 + every write(out,!program) do + not(find("00",(lnum+:=10))) | (writes(".")) + close(out) + return ("\n" || file || " writen out.") +end + +procedure merge() + local file, i, in, line, lnum + + if not(token[2]) then + { + writes("_file:") + if (file := string(read())) == "" then return + } else file := token[2] + (in := open(file)) | return ("Can't open " || file) + every line := !in do + { + (lnum := integer(line[1:(i:=upto(' \t',line))])) | next + cmd := line + entry(lnum) + not(find("00",lnum)) | writes(".") + } + close(in) + return (file || " merged in current buffer.") +end +#SUB DIR, DEL, AND NEW COMMANDS +#EJECT +procedure dir() + local spec + + spec := (token[2]) | ("") + if &host == "MS-DOS" then + { + system(("dir/w " || spec)) + return "" + } + if find("nix",map(&host)) then + system(("ls -l " || spec || " | more")) else + system(("dir " || spec)) + return "" +end + +procedure del() + local From, To, element, lnum, num, other + + if (From := integer(token[2])) & (To := integer(token[3])) then + { + other := [] + every element := !program do + { + lnum := element[1:upto(' \t',element)] + if (lnum >= From) & (lnum <= To) then next + put(other,element) + } + program := copy(other) + return ("Lines " || From || " - " || To || " deleted.") + } + + if not(num := integer(token[2])) then + { + writes("_line:") + (num := integer(read())) | (return ("Not a line number.")) + } + other := [] + every element := !program do + { + lnum := element[1:upto(' \t',element)] + if lnum = num then next + put(other,element) + } + program := copy(other) + return ("Line " || num || " deleted.") +end + +procedure new() + program := [] + name := &null + return ("Buffer cleared.") +end +#SUB FIND COMMAND +#EJECT +procedure search() + local From, To, delta, diff, i, item, j, k, l, line, lnum + + if (From := token[2]) & (To := token[3]) then + { + diff := (*token[3]) - (*token[2]) + every i := 1 to *program do + { + line := program[i] + l := upto(' \t',line) + 1 + delta:= 0 + every j := find(From,line,l) do + { + k := j + delta + line[k+:*From] := "" + line[((k-1)|(1))] ||:= To + delta +:= diff + writes(".") + } + program[i] := line + } + return "" + } + + if not(item := token[2]) then + { + writes("_string:") + if (item := read()) == "" then return "" + } + every i := 1 to *program do + { + line := program[i] + l := upto(' \t',line) + 1 + if find(item,line,l) then + { + lnum := line[1:l-1] + writes(lnum,",") + } + } + return "" +end +#SUB COMPILATION AND RUNNING ROUTINES +#EJECT +procedure compile() # compile only + local fid, opt + local i, ext, command, val + + find(".",name) | return "Can't compile! Language &or Filename not recognized" + i := last(".",name) + fid := map(name[1:i]) + ext := map(name[i:0]) + command := case ext of + { + ".icn" : "icont -c " || name + ".c" : "cc " || opt || " " || name + ".f" : "f77 "|| opt || " " || name + ".asm" : "asm "|| opt || " " || name + ".p" : "pc " || opt || " " || name + ".for" : "fortran " || name + ".bas" : "basic " || name + ".cob" : "cobol " || name + ".mar" : "macro " || name + ".pas" : "pascal " || name + default: return "Can't compile! Language &or Filename not recognized" + } + write("Issuing -> ",command) + val := system(command) + return " Completion Status = " || val + end + +procedure build() # compile and link + local i, ext, command, val1, val2, fid + + find(".",name) | return "Can't compile! Language &or Filename not recognized" + i := last(".",name) + fid := map(name[1:i]) + ext := map(name[i:0]) + command := case ext of + { + ".icn" : ["icont " || name] + ".c" : ["cc " || name] + ".f" : ["f77 " || name] + ".asm" : ["asm " || name] + ".p" : ["pc " || name] + ".for" : ["fortran " || name, "link " || fid] + ".bas" : ["basic " || name, "link " || fid] + ".cob" : ["cobol " || name, "link " || fid] + ".mar" : ["macro " || name, "link " || fid] + ".pas" : ["pascal " || name, "link " || fid] + default: return "Can't compile! Language &or Filename not recognized" + } + write("Issuing -> ",command[1]) + val1 := system(command[1]) + val2 := if *command = 2 then + { + write("And Issuing -> ",command[2]) + system(command[2]) + } else -1 + return " Completion status = " || val1 || " and " || val2 + end + +procedure run() # run built ware + local i, ext, command, val, fid + + find(".",name) | return "Can't compile! Language &or Filename not recognized" + i := last(".",name) + fid := map(name[1:i]) + ext := map(name[i:0]) + command := case ext of + { + ".icn" : "iconx " || fid + ".c" : fid + ".f" : fid + ".asm" : fid + ".p" : fid + ".com" : "@" || name + ".for" : "run " || fid + ".bas" : "run " || fid + ".cob" : "run " || fid + ".mar" : "run " || fid + ".pas" : "run " || fid + default: return "Can't Run ! Language &or Filename not recognized" + } + write("Issuing -> ",command) + val := system(command) + return " Completion status = " || val + end +#SUB LIST AND RENUM COMMANDS +#EJECT +procedure print() + local From, To, items, line + + if *token = 1 then + { + every write(!program) + return "" + } + if not(numeric(token[2])) then return proc_list() + From := integer(token[2]) + To := integer(token[3]) + if not(integer(To)) then + { + every line := !program do + { + items := parse(line) + if items[1] > From then return "" + if items[1] = From then + { + write(line) + return "" + } + } + return "" + } + every line := !program do + { + items := parse(line) + if items[1] < From then next + if items[1] > To then return "" + write(line) + } + return "" +end +# +procedure proc_list() + local flag, line + + flag := 0 + every line := !program do + { + if find("procedure",line) & find(token[2],line) then flag := 1 + if flag = 1 then write(line) + if (parse(line)[2] == "end") & (flag = 1) then + { + write("") + flag := 0 + } + } + return "" + end +# +procedure renum() + local inc, line, lnum, other + + (lnum := integer(token[2])) | (lnum := 10) + (inc := integer(token[3])) | (inc := 10) + other := list() + every line := !program do + { + line[1:upto(' \t',line)] := lnum + put(other,line) + not(find("00",lnum)) | (writes(".")) + lnum +:= inc + } + program := copy(other) + return ("\nProgram renumbered.") +end +#SUB ON LINE HELP DISPLAY +#EJECT +procedure help() + write("Basic Line Editor V1.3 by Tenaglia") + write(" This editor works on the same principle as basic interpreter") + write(" environments. The lines are all prefixed with line numbers.") + write(" These line numbers are used to reference lines in the file.") + write(" The line numbers are not written to, or read from the file.") + write(" This editor is designed to work on a hard copy terminal like") + write(" a teletype or decwriter as well as a crt.") + write("Command Summary : (parameters are space delimited)") + write(" NEW - erase buffer | CLS - clear screen or form feed") + write(" LOAD file - load file | SAVE file - save file") + write(" READ file - read w/line numbers | WRITE file - write w/line numbers") + write(" RESAVE - resave current file | MERGE file - insert w/line numbers") + write(" DIR [spec]- list directory | SIZE - lines in editing buffer") + write(" RENUM - renumber the lines | VER - current version number") + write(" COMPILE - current source | BUILD - compile & link") + write(" TEST - compile,link, & run | RUN - run last compiled") + write(" $ - command to system (shell) | HELP or ? - this help screen") + write(" TIME or DATE - displays time | !! - repeat last command") + write("*---------------------------------+--------------------------------------*") + write(" LIST or DEL [from [to]] - list or delete line(s)") + write(" FIND str [repl] - find or replace string") + return " EXIT or QUIT - return to operating system" +end +#SUB LINE ENTRY AND HANDY PARSER PROCEDURE +#EJECT +procedure entry(stuff) + local element, finish, flag, lnum, other + + other := list() + flag := "i" + finish := 9999999 + every element := !program do + { + lnum := integer(element[1:upto(' \t',element)]) + if stuff = lnum then + { + put(other,cmd) + stuff := finish + next + } + if stuff < lnum then + { + put(other,cmd) + stuff := finish + } + put(other,element) + } + if stuff ~= finish then put(other,cmd) + program := copy(other) + end + +procedure shell() + local command + command := cmd[find(" ",cmd):0] + if trim(detab(command))=="" then return "No shell command" + system(command) + return "\nReturn to editor" + end + +procedure parse(line) + local tokens + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end + +procedure last(substr,str) + local i + every i := find(substr,str) + return i + end diff --git a/ipl/progs/bfd.icn b/ipl/progs/bfd.icn new file mode 100644 index 0000000..4015848 --- /dev/null +++ b/ipl/progs/bfd.icn @@ -0,0 +1,120 @@ +############################################################################ +# +# File: bfd.icn +# +# Subject: Program to compute best-fit-descending bin packing +# +# Author: Gregg M. Townsend +# +# Date: December 4, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: bpack binsize [options] [file] +# +# Input: one entry per line, size in decimal followed by anything else +# (anything else presumably being a file name or something) +# +# Output: all the input lines, unchanged but reordered, +# with an empty line before each bin and a total afterward +# +# Options: +# -t don't output anything except unannotated totals +# -n don't output anything except the *number* of bins +# -b i don't output anything except the details from bin i +# +############################################################################ +# +# Links: options +# +############################################################################ + +# possible options to add later: optional quantization and padding values +# (e.g. to use with tar(1) you'd need it to round up to the next +# 128 bytes and add 128 bytes for each file header -- or whatever) + + +link options + +record obj(size,detail) + +global opts, binsize + +procedure main(args) + local ifile, line, n, d + local objlist, bins, o, b + + opts := options(args, "tnb+") + + binsize := integer(args[1]) | stop("usage: ", &progname, " binsize") + + if *args > 1 then + ifile := open(args[2]) | stop("can't open ", args[2]) + else + ifile := &input + + objlist := [] + while line := read(ifile) do line ? { + tab(many(' \t')) + n := integer(tab(many(&digits))) | next + tab(many(' \t')) + d := trim(tab(0), ' \t') + put(objlist, obj(n, d)) + } + + objlist := sortf(objlist, 1) + + bins := [] + while o := pull(objlist) do { + n := bestfit(bins, o.size) + put(bins[n].detail, o) + bins[n].size +:= o.size + } + + if \opts["n"] then { + write(*bins) + return + } + + if \opts["t"] then { + every write((!bins).size) + return + } + + if n := \opts["b"] then { + b := bins[n] | stop("no bin ", n, "; only " *bins, " bins") + every write((!b.detail).detail) + return + } + + while b := get(bins) do { + write() + while o := get(b.detail) do + write(right(o.size, 12), "\t", o.detail) + write(right(b.size, 12), "\t--total--") + } +end + +procedure bestfit(bins, sz) + local b, i, n, d, best + + every i := 1 to *bins do { + b := bins[i] + d := binsize - b.size - sz + if d < 0 | d > \best then + next + best := d + n := i + } + + if \n then + return n + else { + put(bins, obj(0, [])) + return *bins + } +end diff --git a/ipl/progs/bj.icn b/ipl/progs/bj.icn new file mode 100644 index 0000000..7a24206 --- /dev/null +++ b/ipl/progs/bj.icn @@ -0,0 +1,363 @@ +############################################################################ +# +# File: bj.icn +# +# Subject: Program to play blackjack game +# +# Author: Chris Tenaglia (modified by Richard L. Goerwitz) +# +# Date: December 12, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.7 +# +############################################################################ +# +# Simple but fun blackjack game. The original version was for an ANSI +# screen. This version has been modified to work with the UNIX termcap +# database file. +# +############################################################################ +# +# Links: itlib, random +# +# Requires: UNIX +# +############################################################################ + +link itlib +link random + +global deck, message, lookup, + user_money, host_money, + user_hand, host_hand + +procedure main(param) + local bonus, user_points, host_points + user_money := integer(param[1]) | 3 ; host_money := user_money + write(screen("cls")) +# Most terminals don't do oversize characters like this. +# write(screen("cls")," ",screen("top"),screen("hinv"), +# "BLACK JACK",screen("norm")) +# write(" ",screen("bot"),screen("hinv"), +# "BLACK JACK",screen("norm")) + write(screen("high")," ---- BLACK JACK ----",screen("norm")) + bonus := 0 + repeat + { + if not any('y',(map(input(at(1,3) || " " || screen("under") || + "Play a game? y/n :"|| screen("norm") || " " || + screen("eeol")))[1])) then break + every writes(at(1,3|4),screen("eeos")) + display_score() + deck := xshuffle() + message := "" + user_hand := [] ; host_hand := [] + put(user_hand,pop(deck)) ; put(host_hand,pop(deck)) + put(user_hand,pop(deck)) ; put(host_hand,pop(deck)) + user_points := first(host_hand[1]) + if user_points > 21 then + { + writes(at(1,13),user_points," points. You went over. You lose.") + user_money -:= 1 ; host_money +:= 1 + bonus ; bonus := 0 + display_score() + next + } + display_host(2) + host_points := second(user_points) + if host_points > 21 then + { + writes(at(48,22), right(host_points || " points. " || + (&host ? tab(find(" ")|0)) || " went over.", 28)) + writes(at(1,13),screen("hiblink"),"You win.",screen("norm")) + host_money -:= 1 ; user_money +:= 1 + bonus ; bonus := 0 + display_score() + next + } + if host_points = user_points then + { + writes(at(1,22),screen("hiblink"),"It's a draw at ",user_points, + ". The ANTY goes to bonus.",screen("norm")) + bonus +:= 2 ; host_money -:= 1 ; user_money -:= 1 + display_score() + next + } + writes(at(1,12),user_points," points for user.") + writes(at(1,14),host_points," points for ",&host ? tab(find(" ")|0)) + if user_points < host_points then + { + write(at(1,22),screen("hiblink"),&host ? tab(find(" ")|0)," wins.", + screen("norm"),screen("eeol")) + user_money -:= 1 ; host_money +:= 1 + bonus ; bonus := 0 + display_score() + next + } else { + writes(at(1,12),screen("hiblink"),"You win.",screen("norm"), + screen("eeol")) + user_money +:= 1 + bonus ; host_money -:= 1 ; bonus := 0 + display_score() + next + } + } + write(screen("clear")) + end + +# +# THIS PROCEDURE ALLOWS THE USER TO PLAY AND TAKE HITS +# +procedure first(host_card) + local points + + display_user() + display_host(1) + points := value(user_hand) # just in case + writes(at(1,9),"(",points,") ") + repeat + if any('hy',map(input(at(1,23) || "Hit ? y/n : " || screen("eeol")))) then + { + put(user_hand,pop(deck)) + display_user() + if (points := value(user_hand)) > 21 then return points + writes(at(1,9),"(",points,") ") + } else break + (points > 0) | (points := value(user_hand)) + writes(at(1,9),"(",points,") ") + write(at(55,11),right("You stay with "||points,20)) + return points + end + +# +# THIS SECOND PROCEDURE IS THE HOST PLAYING AGAINST THE USER +# +procedure second(ceiling) + local stop_at, points + + static limits + initial limits := [14,14,15,15,19,16,17,18] + stop_at := ?limits ; points := 0 + until (points := value(host_hand)) > stop_at do + { + if points > ceiling then return points + writes(at(1,19),"(",points,") ") +# write(at(1,22),screen("eeol"),&host," will take a hit.",screen("eeol")) + write(at(1,22),screen("eeol"),&host ? tab(find(" ")|0), + " will take a hit.",screen("eeol")) + put(host_hand,pop(deck)) + display_host(2) + } + (points > 0) | (points := value(host_hand)) + writes(at(1,19),"(",points,") ") + return points + end + +# +# THIS ROUTINE DISPLAYS THE CURRENT SCORE +# +procedure display_score() + writes(screen("nocursor")) + writes(screen("dim"),at(1,7),"Credits",screen("norm")) + writes(screen("high"),at(1,8),right(user_money,7),screen("norm")) + writes(screen("dim"),at(1,17),"Credits",screen("norm")) + writes(screen("high"),at(1,18),right(host_money,7),screen("norm")) + end +# +# THIS PROCEDURE EVALUATES THE POINTS OF A HAND. IT TRIES TO MAKE THEM +# AS HIGH AS POSSIBLE WITHOUT GOING OVER 21. +# +procedure value(sample) + local hand, possible, sum, card, i, best_score, gone_over_score, score + + hand := copy(sample) + possible := [] + repeat + { + sum := 0 + every card := !hand do sum +:= lookup[card[1]] + put(possible,sum) + if not ("A" == (!hand)[1]) then break else + every i := 1 to *hand do { + if hand[i][1] == "A" then { + hand[i][1] := "a" + break + } + } + } + best_score := 0 + gone_over_score := 100 + every score := !possible do { + if score > 21 + then gone_over_score >:= score + else best_score <:= score + } + return (0 ~= best_score) | gone_over_score + end + +# +# THIS ROUTINE DISPLAYS THE USER HAND AND STATUS +# +procedure display_user() + local x, y, card + + writes(screen("nocursor"),at(1,6),screen("hinv"),"USER",screen("norm")) + x := 10 ; y := 4 + every card := !user_hand do + { + display(card,x,y) + x +:= 7 + } + end + +# +# THIS ROUTINE DISPLAYS THE HOST HAND AND STATUS +# +procedure display_host(flag) + local x, y, card + + writes(screen("nocursor"),at(1,16),screen("hinv"), + &host ? tab(find(" ")|0),screen("norm")) + x := 10 ; y := 14 ; /flag := 0 + every card := !host_hand do + { + if (flag=1) & (x=10) then card := "XX" + display(card,x,y) + x +:= 7 + } + end + +# +# THIS ROUTINE DISPLAYS A GIVEN CARD AT A GIVEN X,Y SCREEN LOCATION +# +procedure display(card,x,y) + local all, j, shape + + all := [] ; j := y + if find(card[2],"CS") then card := screen("hinv") || card || screen("norm") +# shape := [at(x,(j+:=1)) || screen("gchar") || "lqqqqqqqk"] + shape := [at(x,(j+:=1)) || screen("inv") || " " || screen("norm")] + put(shape,at(x,(j+:=1)) || screen("inv") || " " || screen("norm") || + " " || card || " " || screen("inv") || " " || screen("norm")) + put(shape,at(x,(j+:=1)) || screen("inv") || " " || screen("norm") || + " " || screen("inv") || " " || screen("norm")) + put(shape,at(x,(j+:=1)) || screen("inv") || " " || screen("norm") || + " " || screen("inv") || " " || screen("norm")) + put(shape,at(x,(j+:=1)) || screen("inv") || " " || screen("norm") || + " " || screen("inv") || " " || screen("norm")) +# put(shape,at(x,(j+:=1)) || "x x") +# put(shape,at(x,(j+:=1)) || "x x") + put(shape,at(x,(j+:=1)) || screen("inv") || " " || screen("norm") || + " " || card || " " || screen("inv") || " " || screen("norm")) +# put(shape,at(x,(j+:=1)) || "mqqqqqqqj" || screen("nchar")) + put(shape,at(x,(j+:=1)) || screen("inv") || " " || screen("norm")) + put(all,shape) + x +:= 14 + while shape := pop(all) do every writes(!shape) + end + +# +# THIS ROUTINE SHUFFLES THE CARD DECK +# +procedure xshuffle() + static faces, suits + local cards, i + initial { + randomize() + faces := ["2","3","4","5","6","7","8","9","T","J","Q","K","A"] + suits := ["D","H","C","S"] + lookup := table(0) + every i := 2 to 9 do insert(lookup,string(i),i) + insert(lookup,"T",10) + insert(lookup,"J",10) + insert(lookup,"Q",10) + insert(lookup,"K",10) + insert(lookup,"A",11) + insert(lookup,"a",1) + } + cards := [] + every put(cards,!faces || !suits) + every i := *cards to 2 by -1 do cards[?i] :=: cards[i] + return cards + end + +# +# THIS ROUTINE PARSES A STRING WITH RESPECT TO SOME DELIMITER +# +procedure parse(line,delims) + local tokens + + static chars + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end + +# +# THIS ROUTINE PROMPTS FOR INPUT AND RETURNS A STRING +# +procedure input(prompt) + writes(screen("cursor"),prompt) + return read() + end + + +# +# THIS ROUTINE SETS THE VIDEO OUTPUT ATTRIBUTES FOR VT102 OR LATER +# COMPATIBLE TERMINALS. +# +procedure screen(attr) + initial if getval("ug"|"mg"|"sg") > 0 then + er("screen","oops, magic cookie terminal!",34) + return { + case attr of + { + "cls" : getval("cl") + "clear": getval("cl") + # HIGH INTENSITY & INVERSE + "hinv" : (getval("md") | "") || getval("so") + "norm" : (getval("se") | "") || (getval("me") | "") || (getval("ue")|"") + # LOW INTENSITY VIDEO + "dim" : getval("mh"|"me"|"se") + "blink": getval("mb"|"md"|"so") + # HIGH INTENSITY BLINKING + "hiblink": (getval("md") | "") || getval("mb") | getval("so") + "under": getval("us"|"md"|"so") + "high" : getval("md"|"so"|"ul") + "inv" : getval("so"|"md"|"ul") + # ERASE TO END OF LINE + "eeol" : getval("ce") + # ERASE TO START OF LINE + "esol" : getval("cb") + # ERASE TO END OF SCREEN + "eeos" : getval("cd") + # MAKE CURSOR INVISIBLE + "cursor": getval("vi"|"CO") | "" + # MAKE CURSOR VISIBLE + "nocursor": getval("ve"|"CF") | "" +# # START ALTERNATE FONT <- very non-portable +# "gchar": getval("as") | "" +# # END ALTERNATE FONT +# "nchar": getval("ae") | "" +# "light": return "\e[?5h" # LIGHT COLORED SCREEN +# "dark" : return "\e[?5l" # DARK COLORED SCREEN +# "80" : return "\e[?3l" # 80 COLUMNS ON SCREEN +# "132" : return "\e[?3h" # 132 COLUMNS ON SCREEN +# "smooth": return "\e[?4h" # SMOOTH SCREEN SCROLLING +# "jump" : return "\e[?4l" # JUMP SCREEN SCROLLING + default : er("screen",attr||" is just too weird for most terminals",34) + } | er("screen","I just can't cope with your terminal.",35) + } + end + +# +# THIS ROUTINE SETS THE CURSOR TO A GIVEN X (COL) Y(ROW) SCREEN LOCATION +# +procedure at(x,y) +# return "\e[" || y || ";" || x || "f" + return igoto(getval("cm"),x,y) + end + diff --git a/ipl/progs/blnk2tab.icn b/ipl/progs/blnk2tab.icn new file mode 100644 index 0000000..8d34706 --- /dev/null +++ b/ipl/progs/blnk2tab.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: blnk2tab.icn +# +# Subject: Program to convert strings of 2 or more blanks to tabs +# +# Author: Ralph E. Griswold +# +# Date: August 13, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program converts strings of two or more blanks to tabs. It +# reads from standard input and writes to standard output. +# +############################################################################ + +procedure main(args) + local line + + while line := read() do + line ? { + while writes(tab(find(" ")), "\t") do + tab(many(' ')) + write(tab(0)) + } + +end diff --git a/ipl/progs/c2icn.icn b/ipl/progs/c2icn.icn new file mode 100644 index 0000000..f192670 --- /dev/null +++ b/ipl/progs/c2icn.icn @@ -0,0 +1,87 @@ +############################################################################ +# +# File: c2icn.icn +# +# Subject: Program to assist C-to-Icon porting +# +# Author: Robert J. Alexander +# +# Date: March 11, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Filter to do some of the mundane work involved in porting a C +# program to Icon. +# +# - Reformats comments, moving embedded comments to end of line +# - Removes the ";" from ends of lines +# - Reformats line-continued strings +# - Changes = to := +# - Changes -> to . +# +############################################################################ + +procedure main(arg) + local c, comment, line, tline + + while line := trim(read(),' \t') do line ? { + line := comment := "" + while line ||:= tab(upto('\'"/=-')) do { + case c := move(1) of { + "\"" | "'": { + line ||:= c + repeat { + until line ||:= tab(find(c) + 1) do { + line ||:= tab(0) + if line[-1] == "\\" then line[-1] := "_" + else stop("unbalanced quotes") + Out(line) + line := "" + &subject := read() + } + if not (line[-2] == "\\" & not (line[-3] == "\\")) then break + } + } + "/": { + if ="*" then { + until comment ||:= trim(tab(find("*/")),' \t') do { + comment ||:= trim(tab(0),' \t') + Out(line,comment) + line := comment := "" + &subject := trim(read(),' \t') + } + move(2) + } + } + "=": { + if ="=" then line ||:= "==" + else if any('<>!',line[-1]) then line ||:= c + else line ||:= ":=" + } + "-": { + if =">" then line ||:= "." + else line ||:= c + } + default: line ||:= c + } + } + line ||:= tab(0) + tline := trim(line) + if tline[-1] == ";" then { + line := tline[1:-1] || line[*tline + 1:0] + } + Out(line,comment) + } +end + + +procedure Out(line,comment) + line ||:= "#" || ("" ~== \comment) + line := trim(line,' \t') + write(line) + return +end diff --git a/ipl/progs/calc.icn b/ipl/progs/calc.icn new file mode 100644 index 0000000..fa39bea --- /dev/null +++ b/ipl/progs/calc.icn @@ -0,0 +1,117 @@ +############################################################################ +# +# File: calc.icn +# +# Subject: Program to simulate desk calculator +# +# Author: Ralph E. Griswold +# +# Date: January 3, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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) as well as an empty line for the null value. +# +# Other lines of input are interpreted as operations. These may be Icon +# operators, functions, or the commands 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 commands are: +# +# clear remove all values from the calculator's stack +# dump write out the contents of the stack +# quit exit from the calculator +# +# Example: the input lines +# +# "abc" +# 3 +# repl +# write +# +# writes abcabcabc and leaves this as the top value on the stack. +# +# Failure and most errors are detected, but in these cases, arguments are +# consumed and not restored to the stack. +# +############################################################################ +# +# Links: ivalue, usage +# +############################################################################ + +invocable all + +link ivalue, usage + +global stack + +procedure main() + local line + + stack := [] + + while line := read() do + (operation | value | command)(line) | + Error("erroneous input ", image(line)) + +end + +procedure command(line) + + case line of { + "clear": stack := [] + "dump": every write(image(!stack)) + "quit": exit() + default: fail + } + + return + +end + +procedure operation(line) + local p, n, arglist + + if p := proc(line, 2 | 1 | 3) then { # function or operation? + n := abs(args(p)) + arglist := stack[-n : *stack + 1] | { + Error("too few arguments") + fail + } + stack := stack[1 : -n] + &error := 1 # anticipate possible error + put(stack, p ! arglist) | { # invoke + if &error = 0 then + Error("error ", &errornumber, " evaluating ", image(line)) + else + Error("failure evaluating ", image(line)) + stack |||:= arglist # restore unused arguments + } + &error := 0 + return + } + + else fail + +end + +procedure value(line) + + put(stack,ivalue(line)) | fail + + return + +end diff --git a/ipl/progs/catlines.icn b/ipl/progs/catlines.icn new file mode 100644 index 0000000..026808e --- /dev/null +++ b/ipl/progs/catlines.icn @@ -0,0 +1,31 @@ +############################################################################ +# +# File: catlines.icn +# +# Subject: Program to concatenate lines of a file +# +# Author: Ralph E. Griswold +# +# Date: January 14, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program concatenates all the lines from standard input and +# writes the result to standard output. +# +############################################################################ + +procedure main() + local line + + line := "" + + while line ||:= read() + + write(line) + +end diff --git a/ipl/progs/chars.icn b/ipl/progs/chars.icn new file mode 100644 index 0000000..a58dcd1 --- /dev/null +++ b/ipl/progs/chars.icn @@ -0,0 +1,31 @@ +############################################################################ +# +# File: chars.icn +# +# Subject: Program to list the different characters in a file +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists all the different characters in a file. image() +# is used to show printable representations. +# +############################################################################ + +procedure main() + local chars + + chars := '' + + while chars ++:= read() + + every write(image(!chars)) + +end diff --git a/ipl/progs/chkhtml.icn b/ipl/progs/chkhtml.icn new file mode 100644 index 0000000..dc4bbf7 --- /dev/null +++ b/ipl/progs/chkhtml.icn @@ -0,0 +1,634 @@ +############################################################################ +# +# File: chkhtml.icn +# +# Subject: Program to check HTML files +# +# Author: Robert J. Alexander +# +# Date: November 15, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to check an HTML file. +# +# Errors detected: +# +# - Reference to undefined anchor name. +# - Duplicated anchor name. +# - Warning for unreferenced anchor name. +# - Unknown tag. +# - Badly formed tag. +# - Improper tag nesting. +# - Unescaped <, >, ", or &. +# - Bad escape string. +# - Improper embedding of attributes. +# - Bad (non-ascii) characters +# +# Advises on: +# - Use of <HTML>, <HEAD, <BODY> tags. +# + +procedure Usage(s) + write(&errout,\s) + stop( + "Usage: ChkHTML -options file..._ + \n -u supress warnings for unreferenced anchor names_ + \n -q supress errors for \"\\\"\" (quote) character in open text_ + \n -g supress errors for \">\" character in open text_ + \n -l n level of HTML (default 2)") +end + +global SupressUnrefNames,SupressOpenQuot,SupressOpenGT,HTMLLevel + +procedure Init(arg) + local opt,f + ListTypes := ["UL","OL","MENU","DIR"] + + opt := options(arg,"uqgl+",Usage) + if *arg = 0 then Usage() + SupressUnrefNames := opt["u"] + SupressOpenQuot := opt["q"] + SupressOpenGT := opt["g"] + HTMLLevel := \opt["l"] | 2 + return opt +end + +link options + +global FileName,LineNbr,TagStack,HRefList,NameSet,NameRefSet,ErrorCount, + SeenSet,PlainText,Tagless,Msg,ListTypes + +procedure main(arg) + SetMsg() + Init(arg) + every CheckHTML(!arg) +end + +procedure CheckHTML(fn) + local f,line,c + static badChars,scanChars + initial { + badChars := ~(&cset[33:128] ++ '\t') + scanChars := '<>"&' ++ badChars + } + # + # Open the input file. + # + f := open(fn) | { + write(&errout,"Can't open \"",fn,"\"") + fail + } + FileName := fn + write(&errout) + Msg("Checking HTML format...") + ErrorCount := 0 + LineNbr := 0 + TagStack := [] + NameSet := set() + NameRefSet := set() + HRefList := [] + SeenSet := set() + PlainText := &null + while line := read(f) do line ? { + LineNbr +:= 1 + while tab(upto(scanChars)) do { + case c := move(1) of { + "<": ProcessTag(f) | break + ">": if /Tagless & /SupressOpenGT then Error("\">\" in open text") + "\"": if /Tagless & /SupressOpenQuot then Error("\"\\\"\" (quote) in open text") + "&": if /Tagless then ProcessEscape() | Error("\"&\" in open text") + default: Error("Bad character: ",image(c)) + } + } + } + close(f) + CheckStack() + CheckHRefs() + FileName := fn + LineNbr := &null + GiveAdvice() + Msg((if ErrorCount > 0 then string(ErrorCount) else "No") + ," error",(if ErrorCount = 1 then "" else "s"), + " detected") + return +end + +procedure CheckHRefs() + local x + every x := !HRefList do { + if not member(NameSet,x.value) then { + FileName := x.fileName + LineNbr := x.lineNbr + Error("Anchor name referenced but not defined: ",image(x.value)) + } + } + if /SupressUnrefNames then { + LineNbr := &null + every x := !(NameSet -- NameRefSet) do { + Msg("Warning: Anchor name not referenced: ",image(x)) + } + } + return +end + +procedure CheckStack() +local tag + every tag := pop(TagStack) do + Error(pop(TagStack),"Unterminated tag: <",tag,">") + return +end + +procedure ProcessTag(f) + local tag,subLine,upTag,endFlag,popCount,tagLines,listType + # + # Scan to the end of the tag (which might be multiple lines). + # + tag := "" + tagLines := 0 + if ="!--" then { + # + # Comment tag. + # + until tab(find("-->") + 3) do { + &subject := read(f) | { + Error("Unclosed HTML comment (\"<!--\")") + LineNbr +:= tagLines + fail + } + tagLines +:= 1 + } + LineNbr +:= tagLines + return + } + until tag ||:= tab(find(">")) do { + (*tag < 1000 & subLine := read(f)) | { + Error("Unclosed \"<\"") + LineNbr +:= tagLines + fail + } + tagLines +:= 1 + tag ||:= tab(0) || " " + &subject := subLine + } + move(1) + # + # Scan the tag contents. + # + tag ? { + Space() + endFlag := ="/" + tag := tab(upto(' \t>') | 0) + upTag := Up(tag) + Space() + if \endFlag then { + # + # Process closer tag </...>. + # + if tag == "PLAINTEXT" then { + Error("<PLAINTEXT> should not have a </PLAINTEXT> tag") + PlainText := Tagless := &null + } + else { + # + # Check that the tag closes a matching opening tag. + # + CheckTag(upTag,,"no/") + if tag == ("LISTING" | "PRE") then Tagless := &null + popCount := 2 + if not (TagStack[1] == upTag) then { + Error("Mismatched closing tag </",upTag,"> pairs with <", + TagStack[1],"> in line ",TagStack[2]) + # + # Try to minimize cascading errors. + # + popCount := + if TagStack[3] == upTag then 4 + else if TagStack[5] == upTag then 6 + else 0 + } + every 1 to popCount do pop(TagStack) + } + } + else { + # + # Process non-closing tag. + # + insert(SeenSet,upTag) + if HTMLLevel = 1 then case upTag of { + # + # Tags for HTML 1. + # + # Tags handled specially. + # + "A": ProcessATag() + "IMG": CheckTag(upTag,"SRC*ALIGN+(TOP,BOTTOM,MIDDLE)ALT+ISMAP-","no/") + "NEXTID": CheckTag(upTag,"N+","no/") + "DL": CheckTag(upTag,"COMPACT-") + "LINK": CheckTag(upTag,"REL+REV+HREF+","no/") + "FORM": CheckTag(upTag,"FORM#ACTION*METHOD+(POST,GET)") + "INPUT": CheckTag(upTag, + "FORM@TYPE+(TEXT,CHECKBOX,RADIO,SUBMIT,RESET)NAME+VALUE+CHECKED-_ + SIZE+MAXLENGTH+","no/") + "SELECT": CheckTag(upTag,"FORM@NAME+SIZE+MULTIPLE-") + "OPTION": CheckTag(upTag,"FORM@SELECTED-","no/") + "TEXTAREA": CheckTag(upTag,"FORM@NAME+ROWS+COLS+") + "DT" | "DD": CheckTag(upTag,"DL@","no/") + "LI": CheckTag(upTag,"list@","no/") + # + # Things that can't be inside character style tags or <A>. + # + "HTML" | "HEAD" | "TITLE" | "BODY" | + "H1" | "H2" | "H3" | "H4" | "H5" | "H6" | + "DL" | "UL" | "OL" | "MENU" | "DIR" | + "ADDRESS" | "BLOCKQUOTE" | "PRE" | "PRE" | + "FORM" | "SELECT" | "TEXTAREA": CheckTag(upTag,"char#A#") + "LISTING" | "XMP": {CheckTag(upTag,"char#A#"); Tagless := "true"} + # + # Character style tags. + # + "EM" | "STRONG" | "B" | "I" | "U" | + "VAR" | "CODE" | "DFN" | "CITE" | "KBD" | "SAMP" | "TT": + CheckTag(upTag,"char#") + # + # Valueless tags that can appear anywhere. + # + "P" | "BR" | "HR" | "OPTION" | "ISINDEX": CheckTag(upTag,,"no/") + "PLAINTEXT": { + CheckTag(upTag,,"no/") + PlainText := Tagless := "true" + } + default: Error("Unknown tag: <",upTag,if pos(0) then "" else " ", + tab(0),">") + } + else case upTag of { + # + # Tags for HTML 2. + # + # Tags handled specially. + # + "A": ProcessATag() + "IMG": CheckTag(upTag, + "SRC*_ + ALIGN+(LEFT,RIGHT,TOP,TEXTTOP,MIDDLE,ABSMIDDLE,BASELINE,_ + BOTTOM,ABSBOTTOM)_ + WIDTH+HEIGHT+BORDER+VSPACE+HSPACE+ALT+ISMAP-","no/") + + "NEXTID": CheckTag(upTag,"N+","no/") + "DL": CheckTag(upTag,"COMPACT-") + "LINK": CheckTag(upTag,"REL+REV+HREF+","no/") + "ISINDEX": CheckTag(upTag,"PROMPT-","no/") + "FORM": CheckTag(upTag,"FORM#ACTION*METHOD+(POST,GET)") + "INPUT": CheckTag(upTag, + "FORM@TYPE+(TEXT,CHECKBOX,RADIO,SUBMIT,RESET)NAME+VALUE+CHECKED-_ + SIZE+MAXLENGTH+","no/") + "SELECT": CheckTag(upTag,"FORM@NAME+SIZE+MULTIPLE-") + "OPTION": CheckTag(upTag,"FORM@SELECTED-","no/") + "TEXTAREA": CheckTag(upTag,"FORM@NAME+ROWS+COLS+") + "DT" | "DD": CheckTag(upTag,"DL@","no/") + "LI": { + listType := !TagStack == !ListTypes + CheckTag(upTag,case listType of { + "UL": "list@TYPE+(DISC,CIRCLE,SQUARE)" + "OL": "list@TYPE+(A,I,1)VALUE+" + default: "list@" + },"no/") + } + "HR": CheckTag(upTag,"SIZE+WIDTH+ALIGN+(LEFT,RIGHT,CENTER)NOSHADE-","no/") + "UL": CheckTag(upTag,"TYPE+(DISC,CIRCLE,SQUARE)") + "OL": CheckTag(upTag,"TYPE+(A,I,1)START+") + "BR": CheckTag(upTag,"CLEAR+(LEFT,RIGHT,ALL)","no/") + "NOBR" | "CENTER": CheckTag(upTag) + "WBR": CheckTag(upTag,"NOBR@","no/") + "FONT": CheckTag(upTag,"SIZE+") + "BASEFONT": CheckTag(upTag,"SIZE+","no/") + # + # Things that can't be inside character style tags or <A>. + # + "HTML" | "HEAD" | "TITLE" | "BODY" | + "H1" | "H2" | "H3" | "H4" | "H5" | "H6" | + "DL" | "MENU" | "DIR" | + "ADDRESS" | "BLOCKQUOTE" | "PRE" | "PRE" | + "FORM" | "SELECT" | "TEXTAREA": CheckTag(upTag,"char#A#") + "LISTING" | "XMP": {CheckTag(upTag,"char#A#"); Tagless := "true"} + # + # Character style tags. + # + "EM" | "STRONG" | "B" | "I" | "U" | + "VAR" | "CODE" | "DFN" | "CITE" | "KBD" | "SAMP" | "TT": + CheckTag(upTag) + # + # Valueless tags that can appear anywhere. + # + "P" | "OPTION": CheckTag(upTag,,"no/") + "PLAINTEXT": { + CheckTag(upTag,,"no/") + PlainText := Tagless := "true" + } + default: Error("Unknown tag: <",upTag,if pos(0) then "" else " ", + tab(0),">") + } + } + } + LineNbr +:= tagLines + return +end + +record HRefRec(fileName,lineNbr,value) + +procedure ProcessATag() + local attrTable,value,ok + if attrTable := CheckTag("A","HREF+NAME+REL+REV+URN+TITLE+METHODS") then { + if value := \attrTable["HREF"] then { + if match("#",value) then { + value := Up(value[2:0]) + insert(NameRefSet,value) + if not member(NameSet,value) then { + put(HRefList,HRefRec(FileName,LineNbr,value)) + } + } + ok := "yes" + } + if value := \attrTable["NAME"] then { + value := Up(value) + if member(NameSet,value) then { + Error("Duplicate anchor name: ",image(value)) + } + else { + insert(NameSet,value) + } + ok := "yes" + } + if /ok then Error("Either \"HREF\" or \"NAME\" attribute required for <A> tag") + } + return +end + +procedure CheckTag(tag,template,noCloser) + # + # separators: + # + optional, with value + # - optional, no value + # * required, with value + # @ must be in specified context + # # must not be inspecified context + # + local attrTable,attr,origAttrs,c,error,value,valueList,valueString + attrTable := ScanAttrs() + origAttrs := copy(attrTable) + \template ? { + while attr := tab(upto('+-*@#')) do { + case c := move(1) of { + !"+*": { + # + # Process an attribute with a value. + # Scan allowed value set, if any. + # + if ="(" then { + valueList := [] + repeat { + put(valueList,tab(upto(',)'))) + c := move(1) + if c == ")" then break + } + } + else valueList := &null + # + # See if an attribute of the specified name (with a value) + # exists. + # + if value := \attrTable[attr] then { + delete(attrTable,attr) + if \valueList then { + if not (Up(value) == !valueList) then { + valueString := "" + every valueString ||:= " " || image(!valueList) + Error("Invalid value for attribute ",image(attr)," of tag <", + tag,">: ",image(value), + "\n # must be one of: ",valueString) + } + } + } + else if c == "*" then { + # + # Attr not there -- see if it is required. + # + Error("Attribute ",image(attr),", required for tag <",tag,">, is missing") + error := "yes" + } + } + "-": { + # + # Process an atribute with no value. + # + if member(attrTable,attr) then { + delete(attrTable,attr) + if \attrTable[attr] then { + Error("A value not expected for attribute: ",image(attr), + "of tag <",tag,">") + error := "yes" + } + } + } + "@": CheckContext(attr,tag) + "#": CheckContext(attr,tag,"notInContext") + } + } + } + every attr := key(attrTable) do { + Error("Unknown attribute ",image(attr)," of tag <",tag,">") + error := "yes" + } + if /noCloser then push(TagStack,LineNbr,tag) + return if /error then origAttrs +end + +procedure ScanAttrs() + local attr,value,attrTable + attrTable := table() + until pos(0) do { + attr := Up(tab(upto(' \t=') | 0)) + Space() + if ="=" then { + Space() + (="\"" & value := tab(find("\"")) & move(1)) | + (value := tab(upto(' \t') | 0)) + Space() + } + else value := &null + attrTable[attr] := value + } + return attrTable +end + +procedure CheckContext(context,tag,notInContext) + local tags,inContext,sep + static canned + initial { + canned := table() + canned["list"] := ListTypes + canned["char"] := ["EM","STRONG","B","I","U", + "VAR","CODE","DFN","CITE","KBD","SAMP","TT"] + + } + inContext := + (if context := \canned[context] then !context else context) == !TagStack + if \notInContext then inContext := if \inContext then &null else "true" + if \inContext then return + else { + if type(context) ~== "string" then { + tags := sep := "" + every tags ||:= sep || !canned do sep := " or " + context := tags + } + if \notInContext then + Error("<",tag,"> should not be inside <",context,">") + else + Error("<",tag,"> out of context; should be inside <",context,">") + } +end + +procedure ProcessEscape() + local escape + static escSet,escChars + initial { + escChars := &letters ++ &digits + escSet := set([ + "quot", + "lt", + "gt", + "amp", + "nbsp", + "reg", + "copy", + + "AElig", + "Aacute", + "Acirc", + "Agrave", + "Aring", + "Atilde", + "Auml", + "Ccedil", + "ETH", + "Eacute", + "Ecirc", + "Egrave", + "Euml", + "Iacute", + "Icirc", + "Igrave", + "Iuml", + "Ntilde", + "Oacute", + "Ocirc", + "Ograve", + "Oslash", + "Otilde", + "Ouml", + "THORN", + "Uacute", + "Ucirc", + "Ugrave", + "Uuml", + "Yacute", + "aacute", + "acirc", + "aelig", + "agrave", + "aring", + "atilde", + "auml", + "ccedil", + "eacute", + "ecirc", + "egrave", + "eth", + "euml", + "iacute", + "icirc", + "igrave", + "iuml", + "ntilde", + "oacute", + "ocirc", + "ograve", + "oslash", + "otilde", + "ouml", + "szlig", + "thorn", + "uacute", + "ucirc", + "ugrave", + "uuml", + "yacute", + "yuml"]) + if HTMLLevel = 1 then every delete(escSet,"reg" | "copy") + } + (escape := tab(many(escChars)) & =";") | fail + (escape ? (="#",tab(many(&digits)),pos(0))) | member(escSet,escape) | { + Error("Unknown escape string: &",escape,";") + } + return +end + +procedure GiveAdvice() + if not member(SeenSet,"HTML") then + Msg("Advice: File should be bracketed with <HTML>...</HTML> tags") + if not (member(SeenSet,"HEAD"),member(SeenSet,"BODY")) then { + if member(SeenSet,"HEAD") then + Error("<HEAD>, but no <BODY>") + else if member(SeenSet,"BODY") then + Error("<BODY>, but no <HEAD>") + else + Msg("Advice: Consider using <HEAD>...</HEAD> <BODY>...</BODY>") + } + return +end + +link shquote + +procedure SetMsg() + return Msg := (if &host == "Macintosh MPW" then MPWMsg else UnixMsg) +end + +procedure UnixMsg(s[]) + local lineNbr + lineNbr := if type(s[1]) == "integer" then get(s) else LineNbr + writes(&errout,"\"",FileName,"\"",":" || \lineNbr | "",": ") + every writes(&errout,!s) + write(&errout) + return +end + +procedure MPWMsg(s[]) + local lineNbr + lineNbr := if type(s[1]) == "integer" then get(s) else LineNbr + writes(&errout,"File ",mpwquote(FileName),"; Line ",\lineNbr | "¤"," # ") + every writes(&errout,!s) + write(&errout) + return +end + +procedure Error(s[]) + ErrorCount +:= 1 + return Msg!s +end + +procedure Space() + suspend tab(many(' \t')) +end + +procedure Up(s) + static lcase,ucase + initial { + lcase := string(&lcase) + ucase := string(&ucase) + } + return map(s,lcase,ucase) +end diff --git a/ipl/progs/choose.icn b/ipl/progs/choose.icn new file mode 100644 index 0000000..3d715a5 --- /dev/null +++ b/ipl/progs/choose.icn @@ -0,0 +1,73 @@ +############################################################################ +# +# File: choose.icn +# +# Subject: Program to pick lines from a file +# +# Author: Gregg M. Townsend +# +# Date: January 14, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# usage: choose [-N] [file...] +# +# This program randomly selects N lines from the input stream and +# outputs them in order. If N is omitted, one line is chosen. +# If the input stream supplies fewer than N lines, all are output. +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +global wanted # number of lines wanted +global seen # number of lines read so far + +record chosen( # one tentatively chosen input line + lnum, # line number + text) # data + +global llist # list of tentatively chosen lines + +procedure main(args) + local fname + + if wanted := abs(integer(args[1])) then + get(args) + else + wanted := 1 + + llist := [] + seen := 0 + randomize() + + if *args = 0 then + dofile(&input) + else while fname := get(args) do + dofile(open(fname)) | stop("cannot open ", fname) + + llist := sortf(llist, 1) + every write((!llist).text) +end + +procedure dofile(f) + local line + + while line := read(f) do { + seen +:= 1 + if seen <= wanted then + put(llist, chosen(seen, line)) + else if ?0 < wanted / real(seen) then + ?llist := chosen(seen, line) + } + close(f) + return +end diff --git a/ipl/progs/chop.icn b/ipl/progs/chop.icn new file mode 100644 index 0000000..73eb4aa --- /dev/null +++ b/ipl/progs/chop.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: chop.icn +# +# Subject: Program to restrict numerical values +# +# Author: Ralph E. Griswold +# +# Date: January 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program limits the numerical values in a sequence +# visualization stream. The limit is given on the command line; +# default 200. +# +############################################################################ + +procedure main(args) + local max, line, i + + max := \args[1] | 200 + + while line := read() do { + line ? { + i := tab(upto(' \t') | 0) + if i > max then i := max + write(i, tab(0)) + } + } + +end diff --git a/ipl/progs/colm.icn b/ipl/progs/colm.icn new file mode 100644 index 0000000..d1ac42c --- /dev/null +++ b/ipl/progs/colm.icn @@ -0,0 +1,131 @@ +############################################################################ +# +# File: colm.icn +# +# Subject: Program to arrange data into columns +# +# Author: Robert J. Alexander +# +# Date: December 5, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/comfiles.icn b/ipl/progs/comfiles.icn new file mode 100644 index 0000000..faabc61 --- /dev/null +++ b/ipl/progs/comfiles.icn @@ -0,0 +1,46 @@ +############################################################################ +# +# File: comfiles.icn +# +# Subject: Program to list common files in two directories +# +# Author: Ralph E. Griswold +# +# Date: March 21, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists common file names in two directories given as +# command-line arguments. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main(args) + local dir1, dir2, set1, set2, set3, input1, input2 + + dir1 := args[1] | stop("*** no directories specified") + dir2 := args[2] | stop("*** no second directory specified") + + set1 := set() + set2 := set() + + input1 := open("ls " || dir1, "p") + input2 := open("ls " || dir2, "p") + + every insert(set1, !input1) + every insert(set2, !input2) + + set3 := set1 ** set2 + + if *set3 = 0 then write("no common file names") + else every write(!set3) + +end diff --git a/ipl/progs/compare.icn b/ipl/progs/compare.icn new file mode 100644 index 0000000..9356dad --- /dev/null +++ b/ipl/progs/compare.icn @@ -0,0 +1,60 @@ +############################################################################ +# +# File: compare.icn +# +# Subject: Program to look for duplicates in a collection of files +# +# Author: Ralph E. Griswold +# +# Date: January 7, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program compares files to locate ones that have the same content. +# +# The file names are given on the command line. +# +# This program has impossible time complexity if there are many files +# of the same size. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main(args) + local filesets, filelist, file, xfile, size, line, input + + filesets := table() + + # The strategy is to divide the files into equivalence classes by size. + + every file := !args do { + input := open("wc " || image(file), "p") + line := read(input) + close(input) + line ? { + move(20) + tab(many(' ')) + size := integer(tab(many(&digits))) | stop("bogus size") + } + /filesets[size] := [] + put(filesets[size], file) + } + + filesets := sort(filesets, 3) + + while get(filesets) do { # don't need size for anything + filelist := get(filesets) # just the files of that size + while file := get(filelist) do # for every file + every xfile := !filelist do # compare against the rest + if system("cmp -s " || image(file) || " " || image(xfile) || + ">/dev/null") = 0 then write(file, "==", xfile) + } + +end diff --git a/ipl/progs/comply83.icn b/ipl/progs/comply83.icn new file mode 100644 index 0000000..0d43c0f --- /dev/null +++ b/ipl/progs/comply83.icn @@ -0,0 +1,60 @@ +############################################################################ +# +# File: comply83.icn +# +# Subject: Program to check compliance with MS-DOS name restrictions +# +# Author: Ralph E. Griswold +# +# Date: October 4, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program checks the file names given on standard input and reports +# any that are not valid MS-DOS file names. +# +# It is designed handle output UNIX ls -R, but it will handle a list +# of file names, one per line. +# +############################################################################ + +procedure main() + local line, base, ext, dir, forbid + + forbid := &cset -- &letters -- &digits -- '._^$~!#%&-{}()@\'`' + + while line := read() do { + if *line = 0 then next # skip blank lines + line ? { + if upto(forbid, line) then { # contains forbidden character + write(dir, line) + next + } + if = "." then { # directory header + dir := tab(-1) || "/" + next + } + if base := tab(upto('.')) then { + move(1) + ext := tab(0) + ext ? { + if upto('.') then { # period in "extension" + write(dir, line) + next + } + } + } + else { + base := tab(0) + ext := "" + } + if (*base > 8) | (*ext > 3) then # check sizes + write(dir, line) + } + } + +end diff --git a/ipl/progs/concord.icn b/ipl/progs/concord.icn new file mode 100644 index 0000000..d1c0ad3 --- /dev/null +++ b/ipl/progs/concord.icn @@ -0,0 +1,123 @@ +############################################################################ +# +# File: concord.icn +# +# Subject: Program to produce concordance +# +# Author: Ralph E. Griswold +# +# Date: October 9, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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, pad, i, j, fill + + opts := options(args, "l+w+") # process options + colmax := \opts["l"] | 72 + namewidth := \opts["w"] | 15 + + pad := repl(" ", namewidth) + uses := table() + lineno := 0 + + every tabulate(item(), lineno) # tabulate all the citations + + uselist := sort(uses, 3) # sort by uses + while fill := left(get(uselist), namewidth) do { + line := format(get(uselist)) # line numbers + while (*line + namewidth) > colmax do { # handle long lines + line ?:= { + i := j := 0 + every i := upto(' ') do { + if i > (colmax - namewidth) then break + else j := i + } + write(fill, tab(j)) + move(1) + fill := pad + tab(0) # new value of line + } + } + if *line > 0 then write(fill, trim(line)) + } + +end + +# Add to count of line number to citations for name. +# +procedure tabulate(name, lineno) + + /uses[name] := table(0) + uses[name][lineno] +:= 1 + + return + +end + +# Format the line numbers, breaking long lines as necessary. +# +procedure format(linenos) + local i, line + + linenos := sort(linenos, 3) + line := "" + + while line ||:= get(linenos) do + line ||:= ("(" || (1 < get(linenos)) || ") ") | " " + + return line + +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 diff --git a/ipl/progs/conman.icn b/ipl/progs/conman.icn new file mode 100644 index 0000000..01dbb83 --- /dev/null +++ b/ipl/progs/conman.icn @@ -0,0 +1,427 @@ +############################################################################ +# +# File: conman.icn +# +# Subject: Program to convert units +# +# Author: William E. Drissel +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Conman is a toy I used to teach myself elementary Icon. I +# once vaguely heard of a program which could respond to queries +# like "? Volume of the earth in tbsp". +# +# The keywords of the language (which are not reserved) are: +# +# load +# save +# print +# ? (same as print) +# list +# is and are which have the same effect +# +# "Load" followed by an optional filename loads definitions of +# units from a file. If filename is not supplied, it defaults to +# "conman.sav" +# +# "Save" makes a file for "load". Filename defaults to +# "conman.sav". "Save" appends to an existing file so a user +# needs to periodically edit his save file to prune it back. +# +# "Print" and "?" are used in phrases like: +# +# ? 5 minutes in seconds +# +# Conman replies: +# +# 5 minutes in seconds equals 300 +# +# List puts up on the screen all the defined units and the +# corresponding values. Format is same as load/store format. +# +# "Is" and "are" are used like this: +# +# 100 cm are 1 meter +# +# The discovery of is or are causes the preceding token (in +# this case "cm") to be defined. The load/store format is: +# +# unitname "is" value +# +# Examples: +# +# 8 furlongs is 1 mile +# furlong is 1 / 8 mile +# +# These last two are equivalent. Note spaces before and after +# "/". Continuing examples: +# +# 1 fortnight is 14 days +# furlong/fortnight is furlong / fortnight +# inches/hour is inch / hour +# +# After this a user might type: +# +# ? 1 furlong/fortnight in inches/hour +# +# Conman will reply: +# +# 1 furlong/fortnight in inches/hour equals 23.57 +# +# Note: the following feature of Conman: his operators have no +# precedence so the line above gets the right answer but +# +# 1 furlong/fortnight in inches / hour +# +# gets the wrong answer. (One definition of a feature is a flaw we're +# not going to fix). +# +############################################################################ +# +# Program Notes: +# +# The procedure, process, parses the user's string to see if it +# begins with a keyword. If so, it acts accordingly. If not, +# the user string is fed to isare. +# +# Isare attempts to find "is" or "are" in the users string. +# Failing to, isare feeds the string to conman which can +# interpret anything. If "is" or "are" is found, the tokens +# (delimited by blanks) before the "is" or "are" are stacked in +# foregoing; those after are stacked in subsequent. Then the +# name to be defined is popped off the foregoing and used as +# the "index" into a table named values. The corresponding +# number is computed as eval(subsequent) / eval(foregoing). +# +# The procedure, stack, is based on Griswold and Griswold, "The +# Icon Programming Language", p122. +# +# The procedure, eval, unstacks the tokens from a stack one by +# one until all have been considered. First, the tokens which +# signify division by the next token are considered and used to +# set a switch named action. Then depending on action, the +# token is used to multiply the accumulator or divide it. If +# eval can make the token into a number, the number is used, +# failing that the token is looked up in the table named values +# and the corresponding number is used. Failing both of those, +# conman gripes to the user and does nothing (in effect +# multiplying or dividing by 1). Finally, eval returns the +# number accumulated by the operations with the tokens. +# +# Load defaults the filename to conman.sav if the user didn't +# supply one. Each line read is fed to isare. We will see +# that save prepares the lines so isare can define the units. +# +# Save uses Icon's sort to go thru the table "values". The +# unit name is the left of a pair and the number stored is the +# right of the pair. The word " is " is stuck between them so +# isare will work. +# +# Finally, we consider the procedure conman. During initial +# design, this was perceived to be the largest part of the +# effort of conman. It is a real tribute to the power of Icon +# that only one non-trivial line of code is required. The +# user's string is reproduced then the word "equals" followed +# the result produced by eval after the user's string is +# stacked. +# +############################################################################ +# +# Requires: conman.sav +# +############################################################################ +# +# Links: io +# +############################################################################ + +link io + +global values, blank, nonblank + +procedure main (args) + local line + + if map(args[1]) == "-t" then &trace := -1 + + init() + + while line := prompt() do { + process(line || " ") # pad with a blank to make life easy + } + windup() +end +############################################################################ +# +# windup +# +procedure windup() + write(&errout,"windup") +end +############################################################################ +# +# process +# +procedure process(str) + + case parse(str) of { + "load" : load(str) + "save" : save(str) + "print" : conman(butfirst(str)) # strip first token + "list" : zlist() + default : isare(str) # didn't start with a kw, try is or are + } +end +############################################################################ +# +# parse +# +procedure parse(str) + local token + + token := first(str) + case token of { + "?" : return "print" # only special case at present + default : return token + } +end +############################################################################ +# +# conman +# +# compute and write result - During initial design, this was perceived to +# require 50 lines of complicated lookup etc.! +# +procedure conman(strn) + + write (strn , " equals ", eval(stack(strn, 1, *strn))) +end +############################################################################ +# +# isare - routine to define values - tries to evaluate if not a definition +# +# locate is,are - delete +# backup one word - save, delete +# compute foregoing +# compute subsequent +# store word, subsequent/foregoing in values +# +procedure isare(str) + local after, before, foregoing, subsequent + +# locate blank-delimited is or are - early (?clumsy) Icon code replaced at +# the suggestion of one of REG's students + + if (str ? (before := tab(find(" is ")) & move(4) & + after := \tab(0))) then { } # is + + else if (str ? (before := tab(find(" are ")) & move(5) & + after := \tab(0))) then { } # are + + else { # found nothing - try to eval anyhow + conman(str) + return + } +# +# here if is or are +# + foregoing := stack(before) # so we can look back one token + subsequent := stack(after) # might as well stack this too + + name := singular(pop(foregoing)) # define token before is or are +# +# next line so we can support "100 cms are 1 meter" +# + values[name] := eval(subsequent) / eval(foregoing) + return +end +############################################################################ +# +# stack - stack tokens - based on IPL section 12.1 p122 +# +# stack the "words" in str - needs cset nonblank +# +procedure stack(str) + local i, j, words + + words := [] ; i := 1 + + while j := upto(nonblank, str, i) do { + i := many(nonblank, str, j) + push(words, str[i:j]) + } + return words +end +############################################################################ +# +# eval - evaluate a stack +# +# while more remain +# unstack a token +# if "in" or "over" or "/", set to divide next time +# else if number multiply/divide it +# else if in values, multiply/divide value +# else gripe and leave accum alone +# +procedure eval(stk) + local accum, action, token + + accum := 1.0 ; action := "multiply" + + while token := singular(pull(stk)) do { + + if token == ("in" | "over" | "/" )then action := "divide" + else if action == "multiply" then { + +# write("multiplying by ", token, " ", (real(token) | + # real(values[token]) | + # "unknown")) + + if not (accum *:= \(real(token) | real(values[token]))) then + write (&errout, + "Can't evaluate ", token, " - using 1.0 instead") + } + else if action == "divide" then { + action := "multiply" + if not (accum /:= \(real(token) | real(values[token]))) then + write (&errout, + "Can't evaluate ", token, " - using 1.0 instead") + } + }#........................................ # end of while more tokens + return accum +end +############################################################################ +# +# init +# +procedure init() + write(&errout, "Conman version 1.1, 7/24/87") + values := table(&null) + nonblank := &ascii -- ' ' + blank := ' ' + values["times"] := 1.0 + values["by"] := 1.0 + values["of"] := 1.0 + values["at"] := 1.0 + values["print"] := 1.0 + values["?"] := 1.0 + values["meter"] := 1.0 + values["kilogram"] := 1.0 + values["second"] := 1.0 + +end +############################################################################ +# +# prompt +# +procedure prompt() + return read() +end +############################################################################ +# +# load - loads table from a file - assumes save format compatible +# with isare +# +procedure load(str) + local intext, line, filnam + + filnam := (\second(str) | "conman.sav") + write (&errout, "Load from ", filnam, ". May take a minute or so.") + intext := dopen(filnam,"r") | { write(&errout, "can't open ", filnam) + fail} + while line := read(intext) do { + isare(line || " ") # pad with a blank to make life easy + } + close(intext) + return +end +############################################################################ +# +# save - saves table to file in format compatible with isare +# +procedure save(str) + local i, outtext, pair, wlist, filnam + + filnam := (\second(str) | "conman.sav") + write (&errout, "Save into ", filnam) + outtext := open(filnam,"a") | { write(&errout, "can't save to ", filnam) + fail} + wlist := sort(values) + i := 0 + every pair := !wlist do { + write(outtext, pair[1], " is ", pair[2]) + } + close(outtext) +end +############################################################################ +# +# zlist - lists the table +# +procedure zlist() + local i, pair, wlist + + i := 0 + wlist := sort(values) + every pair := !wlist do { + write(&errout, pair[1], " is ", pair[2]) + } +end +############################################################################ +# +# first - returns first token in a string - needs cset nonblank +# +procedure first(s) + local stuff + + s? (tab(upto(nonblank)) , (stuff := tab(many(nonblank)))) + return \stuff +end +############################################################################ +# +# second - returns second token in a string - needs cset nonblank +# +procedure second(s) + local stuff + + s? (tab(upto(nonblank)) , (tab(many(nonblank)) & tab(upto(nonblank)) & + (stuff := tab(many(nonblank))))) + return \stuff +end +############################################################################ +# +# butfirst - returns all butfirst token in a string - needs cset nonblank +# +procedure butfirst(s) + local stuff + + s? (tab(upto(nonblank)) , tab(many(nonblank)) & tab(upto(nonblank)) & + (stuff := tab(0))) + return \stuff +end +############################################################################ +# +# singular - returns singular of a unit of measure - add special cases in +# an obvious way. Note: singulars ending in "e" should be handled +# here also "per second" units which end in "s". +# +procedure singular(str) + local s + + s := str + if s == "fps" then return "fps" + if s == "feet" then return "foot" + if s == "minutes" then return "minute" + if s == "miles" then return "mile" +# +## otherwise strip "es" or "s". Slick code by Icon grad student +# + return s? (1(tab(-2), ="es") | 1(tab(-1), ="s" ) | tab(0)) +end +############################################################################ diff --git a/ipl/progs/countlst.icn b/ipl/progs/countlst.icn new file mode 100644 index 0000000..6153588 --- /dev/null +++ b/ipl/progs/countlst.icn @@ -0,0 +1,69 @@ +############################################################################ +# +# File: countlst.icn +# +# Subject: Program to count items in a list +# +# Author: Ralph E. Griswold +# +# Date: December 30, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program counts the number times each line of input occurs and +# writes a summary. +# +# With no option, the output is sorted first by decreasing count and within +# each count, alphabetically. With the option -a, the output is sorted +# alphabetically. +# +# The option -t prints a total at the end. +# +############################################################################ +# +# Links: adlutils, options +# +############################################################################ + +link adlutils, options + +procedure main(args) + local line_count, counter, lines, opts, sort_method, line, total, count + + line_count := table(0) # counts for each line + counter := table() # lists of lines for each count + total := 0 # total number of lines + + opts := options(args,"at") + sort_method := opts["a"] + + while line_count[read()] +:= 1 do + total +:= 1 + + if \sort_method then { # alphabetical sort + line_count := sort(line_count,3) + while write(get(line_count),"\t",get(line_count)) + } + else { # numerical sort, then alpha + line_count := sort(line_count,4) + + while count := pull(line_count) do { + /counter[count] := [] + put(counter[count],pull(line_count)) + } + + counter := sort(counter,3) + + while lines := sort(pull(counter)) do { + count := pull(counter) + every write(!lines,"\t",count) + } + } + + if \opts["t"] then write("\ntotal\t",total) + +end diff --git a/ipl/progs/cross.icn b/ipl/progs/cross.icn new file mode 100644 index 0000000..6886ac7 --- /dev/null +++ b/ipl/progs/cross.icn @@ -0,0 +1,196 @@ +############################################################################ +# +# File: cross.icn +# +# Subject: Program to display intersection of words +# +# Author: William P. Malloy +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/crypt.icn b/ipl/progs/crypt.icn new file mode 100644 index 0000000..086a5f1 --- /dev/null +++ b/ipl/progs/crypt.icn @@ -0,0 +1,59 @@ +############################################################################ +# +# File: crypt.icn +# +# Subject: Program to encrypt file +# +# Authors: Phil Bewig and Phillip Lee Thomas +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Do *not* use this in the face of competent cryptanalysis. +# +# Usage: [iconx] icrypt [key] < infile > outfile +# +############################################################################ +# +# As written, uses UNIX-style console I/O. +# +############################################################################ + +procedure main(args) + local i, k, ky, l, con + local fin, fout, infile, outfile + + if *args = 3 then { + ky := get(args) + infile := get(args) + outfile := get(args) + } + + else { + writes("Enter password: ") + # Note - password is visible + ky := read() + writes("Enter input file: ") + infile := read() + writes("Enter output file: ") + outfile := read() + } + + fin := open(infile, "ur") + fout := open(outfile,"uw") + + i := 1 + l := 0 + k := [] + every put(k, ord(!ky)) do + l +:= 1 + + while writes(fout, char(ixor(ord(reads(fin)), k[i]))) do { + i := (i % l) + 1 + } +end diff --git a/ipl/progs/csgen.icn b/ipl/progs/csgen.icn new file mode 100644 index 0000000..5736798 --- /dev/null +++ b/ipl/progs/csgen.icn @@ -0,0 +1,153 @@ +############################################################################ +# +# File: csgen.icn +# +# Subject: Program to generate context-sensitive sentences +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 +# +# One option is supported: +# +# -g i number of derivations; overrides the number specified +# in the grammar +# +# 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, random +# +############################################################################ + +link options +link random + +global xlist + +procedure main(args) + local line, goal, count, s, opts + + opts := options(args, "g+") + + randomize() + + 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 := (1 < integer(tab(0)))) + break + } + + if /count then stop("no goal specification") + + count := \opts["g"] + if count < 1 then stop("*** invalid number of derivations specified") + + every 1 to count do { # generate sentences + s := goal + repeat { + if not upto(&ucase,s) then break # text for nonterminal + # quit on deadlock + if not(s ? subst(!xlist)) then break next + until s ?:= subst(?xlist) # make replacement + } + write(s) + } +end + +# replace left hand side by right hand side +# +procedure subst(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 diff --git a/ipl/progs/cstrings.icn b/ipl/progs/cstrings.icn new file mode 100644 index 0000000..56d62ca --- /dev/null +++ b/ipl/progs/cstrings.icn @@ -0,0 +1,93 @@ +############################################################################ +# +# File: cstrings.icn +# +# Subject: Program to print strings in C files +# +# Author: Robert J. Alexander +# +# Date: September 17, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to print all strings (enclosed in double quotes) in C source +# files. +# + +procedure main(arg) + local c,f,fn,line,lineNbr,s + if *arg = 0 then stop("Usage: cstrings file...") + every fn := !arg do { + f := open(fn) | stop("Can't open \"",fn,"\"") + lineNbr := 0 + while line := read(f) do line ? { + lineNbr +:= 1 + while tab(upto('/"\'')) do { + case move(1) of { + # + # Comment -- handled because it could contain something that + # looks like a string. + # + "/": { + if ="*" then { + while not tab(find("*/") + 2) do { + &subject := read(f) | stop("Unexpected EOF in comment") + lineNbr +:= 1 + } + } + } + # + # String + # + "\"": { + s := "\"" + while s ||:= tab(upto('"\\')) do { + s ||:= c := move(1) + case c of { + "\\": { + if not (s ||:= move(1)) then { + s[-1] := "" + &subject := read(f) | + stop("Unexpected EOF in string") + lineNbr +:= 1 + } + } + "\"": { + break + } + } + } + write("+",lineNbr," ",fn," ",s) + } + # + # Character constant -- handled because it might contain + # a double quote, which could be mistaken for the start + # of a string. + # + "'": { + while tab(upto('\'\\')) do { + c := move(1) + case c of { + "\\": { + if not move(1) then { + &subject := read(f) | + stop("Unexpected EOF in character constant") + lineNbr +:= 1 + } + } + "'": { + break + } + } + } + } + } + } + } + close(f) + } +end diff --git a/ipl/progs/cwd.icn b/ipl/progs/cwd.icn new file mode 100644 index 0000000..04ca09c --- /dev/null +++ b/ipl/progs/cwd.icn @@ -0,0 +1,41 @@ +############################################################################ +# +# File: cwd.icn +# +# Subject: Program to write current working directory +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program write the current working directory, shorn of it's +# path specification. +# +# For appropriately named directories, it can be used as, for example, +# +# ftp `cwd` +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main() + local i + + read(open("pwd", "p")) ? { + i := 0 # for safety + every i := upto('/') # expect full path + tab(i + 1) + write(tab(0)) + } + +end + diff --git a/ipl/progs/datmerge.icn b/ipl/progs/datmerge.icn new file mode 100644 index 0000000..56b703f --- /dev/null +++ b/ipl/progs/datmerge.icn @@ -0,0 +1,141 @@ +############################################################################ +# +# File: datmerge.icn +# +# Subject: Program to merge data files +# +# Author: Gregg M. Townsend +# +# Date: November 16, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Datmerge reads and combines arbitrary text-based data files that +# contain whitespace-separated data. For each data field, a single +# value is written to standard output after applying a selected +# operator (such as median or minimum) to the corresponding values +# from all the input files. +# +# Usage: datmerge [-operator] filename... +# +# Operators: +# -min or -minimum +# -max or -maximum +# -med or -median (this is the default) +# -mean +# +# Values convertible to numeric are treated as such. +# All others are treated as strings. +# +############################################################################ +# +# Links: numbers, strings +# +############################################################################ + +link numbers, strings + + + +procedure main(args) + local a, opr, files, lines + + if args[1][1] == '-' then { + a := get(args) + opr := case a of { + "-min" | "-minimum": minimum + "-max" | "-maximum": maximum + "-med" | "-median": median + "-mean": mean + default: stop(&progname, ": unrecognized operator: ", a) + } + } + else + opr := median + + if *args < 1 then + stop("usage: ", &progname, " [-operator] filename...") + + files := [] + while a := get(args) do + put(files, open(a)) | stop("cannot open ", a) + + repeat { + lines := [] + every put(lines, read(!files)) + if *lines = 0 then break + merge(lines, opr) + } + +end + + + +# merge(lines, opr) -- output the result of merging a list of lines. + +procedure merge(lines, opr) + local a, s, w, fields, ws + + fields := [] + every s := !lines do { + put(fields, a := []) + every w := words(s) do + put(a, numeric(w) | w) + } + + ws := "" + repeat { + a := [] + every put(a, get(!fields)) + if *a = 0 then break + writes(ws, opr(a)) + ws := " " + } + + write() +end + + + +# Operator Procedures +# +# These procedures take a list and return a value. +# They must always return something regardless of the data. +# Those that involve arithmetic need to tolerate string data somehow. + +procedure minimum(a) + a := sort(a) + return a[1] +end + +procedure maximum(a) + a := sort(a) + return a[-1] +end + +procedure mean(a) + return (amean ! nsubset(a)) | median(a) +end + +procedure median(a) + a := sort(a) + return a[(*a + 1) / 2] +end + + + +# nsubset(a) -- return subset of array a that contains numeric values + +procedure nsubset(a) + local b + b := [] + every put(b, numeric(!a)) + if *b > 0 then + return b + else + fail +end diff --git a/ipl/progs/daystil.icn b/ipl/progs/daystil.icn new file mode 100644 index 0000000..848542c --- /dev/null +++ b/ipl/progs/daystil.icn @@ -0,0 +1,230 @@ +############################################################################ +# +# File: daystil.icn +# +# Subject: Program to calculate the number of days until a given date +# +# Author: Nevin Liber +# +# Date: June 29, 1994 +# +########################################################################### +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: daystil sMonth iDay +# +# Returns: +# 0 number of days written on &output +# 1 Usage message on &errout (bad parameters) +# +# Revision History: +# <1> njl 6/29/94 9:50 PM First written +# +# This program calculates the number of days between the current date +# and the date specified on the command line, and writes this number to +# &output. This is useful if you want to know how many days it is +# until a birthday, wedding day, etc. +# +# The date on the command line can be specified in a variety of ways. +# For instance, if you wanted to know how many days it is until +# August 12 (my birthday), you could specify it as "August 12", "Aug 12", +# "12 August", or "12 aUGuS", among others. The match is case +# insensitive, and the arguments will be accepted as long as exactly +# one of them is an integer, and if there are exactly two arguments. +# +########################################################################### +# +# NumberOfDays(sMonth, iDay, iYear) : iNumberOfDays +# +# NumberOfDays() returns the number of days into iYear that sMonth/iDay +# occurs. For instance, NumberOfDays("February", 28) returns 59, since +# it is the 59th day into any year. Leap years from 1901 until 2099 +# are taken into account. It fails if any parameters are bad. +# +# Defaults: +# sMonth current month +# iDay current day of the current month +# iYear current year +# +############################################################################ + +procedure NumberOfDays(sMonth, iDay, iYear) + + static LMonths + static LDays + static sThisMonth + static iThisDay + static iThisYear + local iDays + local i + + initial { + LMonths := [ + "january", + "february", + "march", + "april", + "may", + "june", + "july", + "august", + "september", + "october", + "november", + "december" + ] + + LDays := [ + 31, + 28, + 31, + 30, + 31, + 30, + 31, + 31, + 30, + 31, + 30 + ] + + &dateline ? { + &pos := find(" ") + 1 + sThisMonth := tab(find(" ")) + &pos +:= 1 + iThisDay := integer(tab(find(","))) + &pos +:= 2 + iThisYear := integer(move(4)) + } + } + + /sMonth := sThisMonth + /iDay := iThisDay + /iYear := iThisYear + + sMonth := string(sMonth) | fail + iDay := integer(iDay) | fail + iYear := integer(iYear) | fail + + if 0 ~= iYear % 4 then { + LDays[2] := 28 + } else { + LDays[2] := 29 + } + + iDays := iDay + every i := 1 to *LMonths do { + if CaselessMatch(sMonth, LMonths[i]) then { + return iDays + } + iDays +:= LDays[i] + } + +end + + +############################################################################ +# +# CaselessMatch(s1, s2, i1, i2) : i3 caseless match of initial string +# +# CaselessMatch(s1, s2, i1, i2) produces i1 + *s1 if +# map(s1) == map(s2[i1+:*s1]) but fails otherwise. +# +# This is the same as the built-in function match(), except the +# comparisons are done without regard to case. +# +# Defaults: +# s2 &subject +# i1 &pos if s2 is defaulted, otherwise 1 +# i2 0 +# +# Errors: +# 101 i1 or i2 not integer +# 103 s1 or s2 not string +# +############################################################################ + +procedure CaselessMatch(s1, s2, i1, i2) + + s1 := map(string(s1)) + /i1 := (/s2 & &pos) + s2 := map(string(s2) | (/s2 & &subject)) + + return match(s1, s2, i1, i2) + + +end + + +############################################################################ +# +# Usage(fErrout, iStatus) write usage message to fErrout and exit +# +# Usage(fErrout, iStatus) writes the usage message to file fErrout +# and exits with exit status code iStatus +# +# Defaults: +# fErrout &errout +# iStatus 1 +# +############################################################################ + +procedure Usage(fErrout, iStatus) + + /fErrout := &errout + iStatus := (integer(iStatus) | 1) + + write(fErrout, "Usage: DaysTil sMonth iDay") + exit(iStatus) + +end + + +############################################################################ +# +# main(LArguments) +# +# main(LArguments) checks to make sure there are two arguments, exactly +# one of which is an integer. If so, it tries to calculate the number +# of days between the current date and the date specified, taking into +# account if the specified date occurs after today's date only in the +# following year. On a parameter error, it writes the usage message +# to &errout and exits with status 1. Otherwise, it writes the number +# of days to &output and exits with status 0. +# +############################################################################ + +procedure main(LArguments) + + local sArgument + local sMonth + local iDay + local iToday + local iNumberOfDays + + + if 2 ~= *LArguments then { + Usage() + } + + every sArgument := !LArguments do { + (iDay := integer(sArgument)) | (sMonth := sArgument) + } + + if /iDay | /sMonth then { + Usage() + } + + iToday := NumberOfDays() + iNumberOfDays := NumberOfDays(sMonth, iDay) | Usage() + if iNumberOfDays < iToday then { + iNumberOfDays := NumberOfDays("december", 31) + NumberOfDays(sMonth, iDay, integer(&date[1+:4]) + 1) + } + + write(iNumberOfDays - iToday) + +end + diff --git a/ipl/progs/ddfdump.icn b/ipl/progs/ddfdump.icn new file mode 100644 index 0000000..38989c8 --- /dev/null +++ b/ipl/progs/ddfdump.icn @@ -0,0 +1,94 @@ +############################################################################ +# +# File: ddfdump.icn +# +# Subject: Program to print the contents of an ISO 8211 DDF file +# +# Author: Gregg M. Townsend +# +# Date: August 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: ddfdump [file...] +# +# Ddfdump prints the contents of Data Descriptive Files (DDF). +# DDF is an incredibly complex file format enshrined by the +# ISO 8211 standard and used by the United States Geological +# Survey (USGS) for digital data. +# +############################################################################ +# +# Links: ddfread +# +############################################################################ + +link ddfread + + +$define RecSep "\x1E" # ASCII Record Separator +$define UnitSep "\x1F" # ASCII Unit Separator +$define ShowRecSep "\xB6" # show record separator as paragraph mark +$define ShowUnitSep "\xA7" # show unit separator as section mark + + + +procedure main(args) + local f, nbytes + + if *args > 0 then + every dofile(!args) + else + dofile() + +end + +procedure dofile(fname) + local f, dda, d, e, s + + write("\n", \fname, ":") + if /fname then + f := ddfopen(&input) | stop("standard input is not a DDF file") + else + f := ddfopen(fname) | stop("can't open ", fname, " as DDF file") + write() + + dda := ddfdda(f) + every e := !dda do { + write(e.tag, ": ", img(e.control), " ", img(e.name), " ", img(e.format)) + every write(" ", img(!e.labels)) + } + + while d := ddfread(f) do { + write() + every e := !d do { + writes(get(e), ":") + while s := get(e) do + if type(s) == "string" then + writes(" ", img(s)) + else + writes(" ", image(s)) + write() + } + } + + ddfclose(f) +end + +procedure img(s, n) + static s1, s2 + initial { + s1 := s2 := string(&cset) + every !s2[1+:32] := "." # show unprintables as "." + every !s2[128+:33] := "." + s2[1+ord(RecSep)] := ShowRecSep # show record sep (1E) as section mark + s2[1+ord(UnitSep)] := ShowUnitSep # show unit sep (1F) as paragraph mark + } + if *s > \n then + s := s[1+:n] + return "<" || map(s, s1, s2) || ">" +end diff --git a/ipl/progs/deal.icn b/ipl/progs/deal.icn new file mode 100644 index 0000000..dc9d9a2 --- /dev/null +++ b/ipl/progs/deal.icn @@ -0,0 +1,121 @@ +############################################################################ +# +# File: deal.icn +# +# Subject: Program to deal bridge hands +# +# Author: Ralph E. Griswold +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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, random +# +############################################################################ + +link options +link random + +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 + disphand() + +end + +# Display the hands +# +procedure disphand() + 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 diff --git a/ipl/progs/declchck.icn b/ipl/progs/declchck.icn new file mode 100644 index 0000000..6b88ce5 --- /dev/null +++ b/ipl/progs/declchck.icn @@ -0,0 +1,91 @@ +############################################################################ +# +# File: declchck.icn +# +# Subject: Program to detect possible declaration errors +# +# Author: Ralph E. Griswold +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program examines ucode files and reports declared identifiers +# that may conflict with function names. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main(args) + local fset, u1, u2, line, name, base, flag, proc, files, file + + fset := set() + every insert(fset,function()) + + files := open("ls *.icn", "p") + + while file := read(files) do { + system("cp " || file || " xxxxxx.icn") + system("icont -c -s xxxxxx.icn") + write(base := (file ? tab(upto('.')))) + write(" locals") + u1 := open("xxxxxx.u1") | { + write("cannot open .u1 file for ", image(file)) + next + } + u2 := open("xxxxxx.u2") | { + write("cannot open .u1 file for ", image(file)) + next + } + while line := read(u1) do { + line ? { + if ="proc " then { + proc := tab(0) + write("\t", proc) + while line := read(u1) do { + line ? { + if ="\tdeclend" then break next + else if ="\tlocal\t" then { + move(2) + flag := tab(many(&digits)) + if flag == ("001000" | "000020") then { + move(1) + name := tab(0) + if member(fset, name) then + write("\t\tpotential local conflict: ", name) + } + } + } + } + } + } + } + write(" globals") + while line := read(u2) do { + line ? { + if ="global" then break + } + } + while line := read(u2) do { + line ? { + if tab(upto(',') + 1) & ="000001," then { + name := tab(upto(',')) + if member(fset, name) then + write("\t\tpotential global conflict: ", name) + } + } + } + system("rm -f xxxxxx.*") + close(u1) + close(u2) + write() + } + +end diff --git a/ipl/progs/delam.icn b/ipl/progs/delam.icn new file mode 100644 index 0000000..3258c49 --- /dev/null +++ b/ipl/progs/delam.icn @@ -0,0 +1,182 @@ +############################################################################ +# +# File: delam.icn +# +# Subject: Program to delaminate file +# +# Author: Thomas R. Hicks +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/delamc.icn b/ipl/progs/delamc.icn new file mode 100644 index 0000000..e6c6909 --- /dev/null +++ b/ipl/progs/delamc.icn @@ -0,0 +1,118 @@ +############################################################################ +# +# File: delamc.icn +# +# Subject: Program to delaminate file using tab characters +# +# Author: Thomas R. Hicks +# +# Date: May 28, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/dellines.icn b/ipl/progs/dellines.icn new file mode 100644 index 0000000..9292aff --- /dev/null +++ b/ipl/progs/dellines.icn @@ -0,0 +1,56 @@ +############################################################################ +# +# File: dellines.icn +# +# Subject: Program to delete lines from a file +# +# Author: Ralph E. Griswold +# +# Date: December 28, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to delete a few specified lines from a file. +# The line numbers are given on the command line, the file is read from +# standard input and the lines that are not deleted are written to standard +# output as in +# +# dellines 46 23 119 <infile >outfile +# +# which writes all lines but 23, 46, and 119 of infile (if it contains that +# many lines) to outfile. +# +# Line numbers do not have to be given in order. Numbers less than 1 are +# ignored, but a nonnumerical argument is treated as an error. +# +############################################################################ + +procedure main(lines) + local i, line + + if *lines = 0 then stop("*** no lines specified") + + every i := 1 to *lines do + lines[i] := integer(lines[i]) | + stop("*** nonnumeric argument: ", image(lines[i])) + + lines := set(lines) # inefficient method but easy + + i := 0 + + while line := read() do { + i +:= 1 + if not member(lines, i) then { + write(line) + delete(lines, i) # so trailing lines aren't tested + if *lines = 0 then break + } + } + + while write(read()) + +end diff --git a/ipl/progs/delta.icn b/ipl/progs/delta.icn new file mode 100644 index 0000000..f65dcc9 --- /dev/null +++ b/ipl/progs/delta.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: delta.icn +# +# Subject: Program to list differences between successive numbers +# +# Author: Ralph E. Griswold +# +# Date: January 22, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads a stream of numbers from standard input and write +# a stream of their first differences to standard output. +# +############################################################################ + +procedure main() + local i, j + + i := read() | exit() + + while j := read() do { + write(j - i) + i := j + } + +end diff --git a/ipl/progs/diffn.icn b/ipl/progs/diffn.icn new file mode 100644 index 0000000..c98d48b --- /dev/null +++ b/ipl/progs/diffn.icn @@ -0,0 +1,92 @@ +############################################################################ +# +# File: diffn.icn +# +# Subject: Program to show differences among files +# +# Author: Robert J. Alexander +# +# Date: January 3, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program shows the differences between n files. Is is invoked as +# +# diffn file1 file2 ... filen +# +############################################################################ +# +# Links: dif +# +############################################################################ +# +# Most of the work is done by an external procedure, dif(). This +# program analyzes the command line arguments, sets up a call to +# dif(), and displays the results. +# + + +link dif +global f1,f2 +record dfile(file,linenbr) + +invocable all + +procedure main(arg) + local f, i, files, drec, status + # + # Analyze command line arguments, open the files, and output + # some initial display lines. + # + 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]) + } + # + # Invoke dif() and display its generated results. + # + 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 + + +# +# listrange() -- List a range of differing lines, each preceded by its +# line number. +# +procedure listrange(dlist,linenbr) + local x + every x := !dlist do { + write(x); linenbr +:= 1 + } + return +end + + +# +# myread() -- Line-reading procedure to pass to dif(). +# +procedure myread(x) + return x.linenbr <- x.linenbr + 1 & read(x.file) +end + diff --git a/ipl/progs/diffsort.icn b/ipl/progs/diffsort.icn new file mode 100644 index 0000000..470ac30 --- /dev/null +++ b/ipl/progs/diffsort.icn @@ -0,0 +1,72 @@ +############################################################################ +# +# File: diffsort.icn +# +# Subject: Program to reorder "diff" output +# +# Author: Gregg M. Townsend +# +# Date: May 31, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: diffsort [file] +# +# Diffsort reorders the output from the Unix "diff" program by moving +# one-line entries such as "Common subdirectory ..." and "Only in ..." +# to the front of the output file and sorting them. Actual difference +# records then follow, in the original order, separated by lines of +# equal signs. +# +############################################################################ + + +global clines # comment lines +global dlines # diff lines + + +## main program + +procedure main(args) + clines := [] + dlines := [] + + if *args > 0 then + every dofile(!args) + else + dofile() + + every write(!sort(clines)) + every write(!dlines) +end + + +## dofile(fname) - process one named file, or standard input if unnamed + +procedure dofile(fname) + local f, separator + + if /fname then + f := &input + else + f := open(fname) | stop("can't open ", fname) + + separator := "\n\n" || repl("=", 78) || "\n\n" + + every !f ? { + if any(&ucase) then + put(clines, &subject) + else { + if ="diff " then + put(dlines, separator) + put(dlines, &subject) + } + } + + close(f) + return +end diff --git a/ipl/progs/diffsum.icn b/ipl/progs/diffsum.icn new file mode 100644 index 0000000..3414922 --- /dev/null +++ b/ipl/progs/diffsum.icn @@ -0,0 +1,97 @@ +############################################################################ +# +# File: diffsum.icn +# +# Subject: Program to count lines affected by a diff +# +# Author: Gregg M. Townsend +# +# Date: May 31, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: diffsum [file] +# +# Diffsum reads a file containing output from a run of the Unix "diff" +# utility. Diffsum handles either normal diffs or context diffs. For +# each pair of files compared, diffsum reports two numbers: +# 1. the number of lines added or changed +# 2. the net change in file size +# The first of these indicates the magnitude of the changes and the +# second the net effect on file size. +# +############################################################################ + +global oldname, newname +global added, deleted, chgadd, chgdel + +procedure main(args) + local f, line + + if *args > 0 then + f := open(args[1]) | stop("can't open ", args[1]) + else + f := &input + + added := deleted := 0 + oldname := newname := "" + chgadd := chgdel := 0 + + while line := read(f) do line ? { + if =" " then + next + else if ="***" then { + chgadd := 0 + chgdel := +1 + } + else if ="---" then { # n.b. must precede tests below + chgadd := +1 + chgdel := 0 + } + else if any('+>') then + added +:= 1 + else if any('-<') then + deleted +:= 1 + else if ="!" then { + added +:= chgadd + deleted +:= chgdel + } + else if ="diff" then { + report() + while =" -" do tab(upto(' ')) + tab(many(' ')) + oldname := tab(upto(' ')) | "???" + tab(many(' ')) + newname := tab(0) + } + else if ="Only " then + only() + } + report() +end + +procedure report() + local net + + if added > 0 | deleted > 0 then { + net := string(added - deleted) + if net > 0 then + net := "+" || net + write(right(added, 6) || right(net, 8), "\t", oldname, " ", newname) + } + added := deleted := 0 + chgadd := chgdel := 0 + return +end + +procedure only() + report() + if tab(-2) & ="." & any('oa') then + return + tab(1) + write("#\t", tab(0)) +end diff --git a/ipl/progs/diffu.icn b/ipl/progs/diffu.icn new file mode 100644 index 0000000..48a5e2e --- /dev/null +++ b/ipl/progs/diffu.icn @@ -0,0 +1,88 @@ +############################################################################ +# +# File: diffu.icn +# +# Subject: Program to show differences in files +# +# Author: Rich Morin +# +# Date: January 3, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program exercises the dif() procedure, making it act like the +# UNIX diff(1) file difference command. +# +# Usage: diffu f1 f2 +# +# 3d2 +# < c +# 7,8c6,7 +# < g +# < h +# --- +# > i +# > j +# +############################################################################ +# +# Links: dif +# +############################################################################ + +link dif + +invocable all + +procedure main(arg) + local f1, f2, ldr, n1, p1, n2, p2, h + + if *arg ~= 2 then + zot("usage: diffu f1 f2") + + f1 := open(arg[1]) | zot("cannot open " || arg[1]) + f2 := open(arg[2]) | zot("cannot open " || arg[2]) + + every ldr := dif([f1,f2]) do { + n1 := *ldr[1].diffs; p1 := ldr[1].pos + n2 := *ldr[2].diffs; p2 := ldr[2].pos + + if n1 = 0 then { # add lines + h := p1-1 || "a" || p2 + if n2 > 1 then + h ||:= "," || (p2 + n2 - 1) + write(h) + every write("> " || !ldr[2].diffs) + } + else if n2 = 0 then { # delete lines + h := p1 + if n1 > 1 then + h ||:= "," || (p1 + n1 - 1) + h ||:= "d" || p2-1 + write(h) + every write("< " || !ldr[1].diffs) + } + else { # change lines + h := p1 + if n1 > 1 then + h ||:= "," || (p1 + n1 - 1) + h ||:= "c" || p2 + if n2 > 1 then + h ||:= "," || (p2 + n2 - 1) + write(h) + every write("< " || !ldr[1].diffs) + write("---") + every write("> " || !ldr[2].diffs) + } + } +end + + +procedure zot(msg) # exit w/message + write(&errout, "diff: " || msg) + exit(1) +end diff --git a/ipl/progs/diffword.icn b/ipl/progs/diffword.icn new file mode 100644 index 0000000..8f94818 --- /dev/null +++ b/ipl/progs/diffword.icn @@ -0,0 +1,31 @@ +############################################################################ +# +# File: diffword.icn +# +# Subject: Program to list different words +# +# Author: Ralph E. Griswold +# +# Date: May 9, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/digcol.icn b/ipl/progs/digcol.icn new file mode 100644 index 0000000..b56688b --- /dev/null +++ b/ipl/progs/digcol.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: digcol.icn +# +# Subject: Program to produce nth column of digit data +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program filters input to produce the nth column of digit date. +# +############################################################################ + +procedure main(args) + local n, line, s + + n := (0 < integer(args[1])) | stop("*** invalid specification") + + while line := read() do + line ? { + every 1 to n do { + tab(upto(&digits)) | stop("*** column ", n, " does not exist") + s := tab(many(&digits)) + } + + write(s) + } + +end diff --git a/ipl/progs/diskpack.icn b/ipl/progs/diskpack.icn new file mode 100644 index 0000000..3456c40 --- /dev/null +++ b/ipl/progs/diskpack.icn @@ -0,0 +1,95 @@ +############################################################################ +# +# File: diskpack.icn +# +# Subject: Program to produce packing list for diskettes +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to produce a list of files to fit onto +# diskettes. It can be adapted to other uses. +# +# This program uses a straightforward, first-fit algorithm. +# +# The options supported are: +# +# -s i diskette capacity, default 360000 +# -r i space to reserve on first diskettes, default 0 +# -n s UNIX-style file name specification for files to +# be packed, default "*.lzh" +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(argl) + local files, disksize, reserve, firstsize, thissize, file, size, flist + local disk, left, opts, spec, wc, used, number + + + files := table() # table of files + + opts := options(argl, "s+r+n:") + disksize := \opts["s"] | 360000 # diskette size + reserve := \opts["r"] | 0 # reserved space on 1st + firstsize := disksize - reserve # available space on 1st + spec := \opts["n"] | "*.lzh" # files to pack + + wc := open("wc " || spec, "p") # pipe to get sizes + + every !wc ? { # analyze wc output + tab(upto(&digits)) + tab(many(&digits)) + tab(upto(&digits)) + tab(many(&digits)) + tab(upto(&digits)) + size := integer(tab(many(&digits))) # 3rd field has bytes + tab(many(' ')) + file := tab(0) # file name + if file == "total" then break # exit on summary line + files[file] := size # add information to table + } + + number := 0 # diskette number + thissize := firstsize # space on this diskette + + while *files > 0 do { # while files remain + number +:= 1 # next diskette + flist := sort(files, 4) # list of files and sizes + disk := [] # empty diskette + left := thissize # space left + used := 0 # space used + while size := pull(flist) do { # get largest remaining size + file := pull(flist) # file name + if size < left then { # if it fits + put(disk, file) # put it on disk + left -:= size # decrement remaining space + used +:= size # increment space used + delete(files, file) # delete file from table + } + } + # if nothing on disk, can't do + if *disk = 0 then stop("*** can't fit on disks") + # write heading information + write("\ndiskette ", number, ": ", used, "/", disksize - thissize + left) + every write(!disk) # write file names + thissize := disksize # space on next diskette + } + +end diff --git a/ipl/progs/duplfile.icn b/ipl/progs/duplfile.icn new file mode 100644 index 0000000..5bcdd9c --- /dev/null +++ b/ipl/progs/duplfile.icn @@ -0,0 +1,70 @@ +############################################################################ +# +# File: duplfile.icn +# +# Subject: Program to find directories with same files +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists the file names that occur in more than one +# subdirectory and the subdirectories in which the names occur. +# +# This program should be used with caution on large directory +# structures. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main(args) + local ext, posit, files, names, name, dir, temp, dirs + + ext := args[1] | "" + posit := -*ext + + names := table() + + files := open("ls -R", "p") + + while name := read(files) do + name ? { + if dir <- tab(-1) & =":" then { + next + } + else if tab(posit) & =ext then { + /names[name] := [] + put(names[name], dir) + } + } + + names := sort(names, 3) + + while name := get(names) do { + dirs := get(names) + if *name = 0 then next + if *dirs > 1 then { + write("file: ", image(name), " occurs in the following directories") + every write("\t", image(fix(!sort(dirs)))) + write() + } + } + +end + +procedure fix(s) + + /s := "." + + return s + +end diff --git a/ipl/progs/duplproc.icn b/ipl/progs/duplproc.icn new file mode 100644 index 0000000..f6a3787 --- /dev/null +++ b/ipl/progs/duplproc.icn @@ -0,0 +1,325 @@ +############################################################################ +# +# File: duplproc.icn +# +# Subject: Program to find duplicate declarations +# +# Author: Richard L. Goerwitz +# +# Date: December 30, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.8 +# +############################################################################ +# +# Use this if you plan on posting utility procedures suitable for +# inclusion in someone's Icon library directories. +# +# duplproc.icn compiles into a program which will search through +# every directory in your ILIBS environment variable (and/or in the +# directories supplied as arguments to the program). If it finds any +# duplicate procedure or record identifiers, it will report this on +# the standard output. +# +# It is important to try to use unique procedure names in programs +# you write, especially if you intend to link in some of the routines +# contained in the IPL. Checking for duplicate procedure names has +# been somewhat tedious in the past, and many of us (me included) +# must be counted as guilty for not checking more thoroughly. Now, +# however, checking should be a breeze. +# +# BUGS: Duplproc thinks that differently written names for the same +# directory are in fact different directories. Use absolute path +# names, and you'll be fine. +# +############################################################################ +# +# Requires: UNIX (MS-DOS will work if all files are in MS-DOS format) +# +############################################################################ + +record procedure_stats(name, file, lineno) + +procedure main(a) + + local proc_table, fname, elem, lib_file, tmp, too_many_table + + # usage: duplproc [libdirs] + # + # Where libdirs is a series of space-separated directories in + # which relevant library files are to be found. To the + # directories listed in libdirs are added any directories found in + # the ILIBS environment variable. + + proc_table := table() + too_many_table := table() + + # Put all command-line option paths, and ILIBS paths, into one sorted + # list. Then get the names of all .icn filenames in those paths. + every fname := !get_icn_filenames(getlibpaths(a)) do { + # For each .icn filename, open that file, and find all procedure + # calls in it. + if not (lib_file := open(fname, "r")) then + write(&errout,"Can't open ",fname," for reading.") + else { + # Find all procedure calls in lib_file. + every elem := !get_procedures(lib_file,fname) do { + /proc_table[elem.name] := set() + insert(proc_table[elem.name],elem) + } + close(lib_file) + } + } + + every elem := key(proc_table) do { + if *proc_table[elem] > 1 then { + write("\"", elem, "\" is defined in ",*proc_table[elem]," places:") + every tmp := !proc_table[elem] do { + write(" ",tmp.file, ", line ",tmp.lineno) + } + } + } + +end + + + +procedure getlibpaths(ipl_paths) + + # Unite command-line args and ILIBS environment variable into one + # path list. + + local i, path + + # Make sure all paths have a consistent format (one trailing slash).a + if *\ipl_paths > 0 then { + every i := 1 to *ipl_paths do { + ipl_paths[i] := fixup_path(ipl_paths[i]) + } + ipl_paths := set(ipl_paths) + } + else ipl_paths := set() + + # If the ILIBS environment variable is set, read it into + # ipl_paths. Spaces - NOT COLONS - are used as separators. + getenv("ILIBS") ? { + while path := tab(find(" ")) do { + insert(ipl_paths, fixup_path(path)) + tab(many(' ')) + } + insert(ipl_paths, fixup_path(tab(0))) + } + + return sort(ipl_paths) + +end + + + +procedure fixup_path(s) + # Make sure paths have a consistent format. + return "/" ~== (trim(s,'/') || "/") +end + + + +procedure get_procedures(intext,fname) + + # Extracts the names of all procedures declared in file f. + # Returns them in a list, each of whose elements have the + # form record procedure_stats(procedurename, filename, lineno). + + local psl, f_pos, line_no, line + static name_chars + initial { + name_chars := &ucase ++ &lcase ++ &digits ++ '_' + } + + # Initialize procedure-name list, line count. + psl := list() + line_no := 0 + + # Find procedure declarations in intext. + while line := read(intext) & line_no +:= 1 do { + take_out_comments(line) ? { + if tab(match("procedure")) then { + tab(many(' \t')) & + put(psl, procedure_stats( + "main" ~== tab(many(name_chars)), fname, line_no)) + } + } + } + + return psl # returns empty list if no procedures found + +end + + + +procedure take_out_comments(s) + + # Commented-out portions of Icon code - strip 'em. Fails on lines + # which, either stripped or otherwise, come out as an empty string. + # + # BUG: Does not handle lines which use the _ string-continuation + # notation. Typically take_out_comments barfs on the next line. + + local i, j, c, c2, s2 + + s ? { + tab(many(' \t')) + pos(0) & fail + find("#") | (return trim(tab(0),' \t')) + match("#") & fail + (s2 <- tab(find("#"))) ? { + c2 := &null + while tab(upto('\\"\'')) do { + case c := move(1) of { + "\\" : { + if match("^") + then move(2) + else move(1) + } + default: { + if \c2 + then (c == c2, c2 := &null) + else c2 := c + } + } + } + /c2 + } + return "" ~== trim((\s2 | tab(0)) \ 1, ' \t') + } + +end + + + +procedure get_icn_filenames(lib_paths) + + # Return the names of all .icn files in all of the paths in the + # list lib_paths. The dir routine used depends on which OS we + # are running under. + + local procedure_stat_list + static get_dir + initial get_dir := set_getdir_by_os() + + procedure_stat_list := list() + # Run through every possible path in which files might be found, + # and get a list of procedures contained in those files. + every procedure_stat_list |||:= get_dir(!lib_paths) + + return procedure_stat_list + +end + + + +procedure set_getdir_by_os() + + if find("UNIX", &features) + then return unix_get_dir + else if find("MS-DOS", &features) + then return msdos_get_dir + else stop("Your operating system is not (yet) supported.") + +end + + + +procedure msdos_get_dir(dir) + local temp_name, filename + + # Returns a sorted list of all filenames (full paths included) in + # directory "dir." The list is sorted. Fails on invalid or empty + # directory. Aborts if temp file cannot be opened. + # + # Temp files can be directed to one or another directory either by + # manually setting the variable temp_dir below, or by setting the + # value of the environment variable TEMPDIR to an appropriate + # directory name. + + local in_dir, filename_list, line + static temp_dir + initial { + temp_dir := + (trim(map(getenv("TEMPDIR"), "/", "\\"), '\\') || "\\") | + ".\\" + } + + # Get name of tempfile to be used. + temp_name := get_dos_tempname(temp_dir) | + stop("No more available tempfile names!") + + # Make sure we have an unambiguous directory name, with backslashes + # instead of UNIX-like forward slashes. + dir := trim(map(dir, "/", "\\"), '\\') || "\\" + + # Put dir listing into a temp file. + system("dir "||dir||" > "||temp_name) + + # Put tempfile entries into a list, removing blank- and + # space-initial lines. Exclude directories (i.e. return file + # names only). + in_dir := open(temp_name,"r") | + stop("Can't open temp file in directory ",temp_dir,".") + filename_list := list() + every filename := ("" ~== !in_dir) do { + match(" ",filename) | find(" <DIR>", filename) & next + filename ?:= trim(trim(tab(10)) || "." || tab(13), '. ') + if filename ? (tab(find(".ICN")+4), pos(0)) + then put(filename_list, map(dir || filename)) + } + + # Clean up. + close(in_dir) & remove(temp_name) + + # Check to be sure we actually managed to read some files. + if *filename_list = 0 then fail + else return sort(filename_list) + +end + + + +procedure get_dos_tempname(dir) + local temp_name, temp_file + + # Don't clobber existing files. Get a unique temp file name for + # use as a temporary storage site. + + every temp_name := dir || "icondir." || right(string(1 to 999),3,"0") do { + temp_file := open(temp_name,"r") | break + close(temp_file) + } + return \temp_name + +end + + + +procedure unix_get_dir(dir) + local filename_list, in_dir, filename + + dir := trim(dir, '/') || "/" + filename_list := list() + in_dir := open("/bin/ls -F "||dir, "pr") + every filename := ("" ~== !in_dir) do { + match("/",filename,*filename) & next + if filename ? (not match("s."), tab(find(".icn")+4), pos(0)) + then put(filename_list, trim(dir || filename, '*')) + } + close(in_dir) + + if *filename_list = 0 then fail + else return filename_list + +end diff --git a/ipl/progs/edscript.icn b/ipl/progs/edscript.icn new file mode 100644 index 0000000..ae7beb0 --- /dev/null +++ b/ipl/progs/edscript.icn @@ -0,0 +1,85 @@ +############################################################################ +# +# File: edscript.icn +# +# Subject: Program to produce script for ed(1) +# +# Author: Ralph E. Griswold +# +# Date: March 7, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/empg.icn b/ipl/progs/empg.icn new file mode 100644 index 0000000..5920c2f --- /dev/null +++ b/ipl/progs/empg.icn @@ -0,0 +1,119 @@ +############################################################################ +# +# File: empg.icn +# +# Subject: Program to make expression-evaluation programs +# +# Author: Ralph E. Griswold +# +# Date: December 16, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces a program for evaluating Icon expressions. The +# input to this program has three forms, depending on the first character +# of each line: +# +# : the remainder of the line is an expression to be evaluated +# only once +# +# % the remainder of the line is part of a declaration +# +# # the remainder of the line is a comment and is ignored +# +# Anything else is an expression to be evaluated in a loop. +# +# For example, the input +# +# # Time record access +# %record complex(r, i) +# :z := complex(1.0, 3.5) +# z.r +# +# produces a program to time z.r in a loop. + +# The following options are supported: +# +# -l i use i for the number of loop iterations, default 100000 +# -d i use i for the "delta" to adjust timings; otherwise it +# is computed when the expression-evaluation program +# is run +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +global decls + +procedure main(args) + local line, opts, limit, delcomp + + opts := options(args, "d+l+") + + write("link empgsup") + write("link options") + write("procedure main(args)") + write(" local opts") + write(" opts := options(args, \"d+l+\")") + write(" _Limit := ", \opts["l"] | " \\opts[\"l\"] | 100000") + write(" _Delta := ", \opts["d"] | " \\opts[\"d\"] | _Initialize(_Limit)") + + decls := [] + + while line := read() do + line ? { + if =":" then evaluate(tab(0)) + else if ="%" then declare(tab(0)) + else if ="#" then next + else timeloop(tab(0)) + } + + write("end") + + every write(!decls) + +end + +# Save a declaration line. + +procedure declare(line) + + put(decls, line) + + return + +end + +# Produce code to just evaluate an expression. + +procedure evaluate(expr) + + write(" ", expr) + + return + +end + +# Produce code to evaluate an expression in a loop and time it. + +procedure timeloop(expr) + + write(" write(", image(expr), ")") + write(" _Itime := &time") + write(" every 1 to _Limit do {") + write(" &null & (", expr, ")") + write(" }") + write(" write(real(&time - _Itime -_Delta) / _Limit, \" ms.\")") + write(" write()") + + return + +end diff --git a/ipl/progs/envelope.icn b/ipl/progs/envelope.icn new file mode 100644 index 0000000..c209a11 --- /dev/null +++ b/ipl/progs/envelope.icn @@ -0,0 +1,191 @@ +############################################################################ +# +# File: envelope.icn +# +# Subject: Program to address envelopes +# +# Author: Ronald Florence +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.1 +# +############################################################################ +# +# This program addresses envelopes on a Postscript or HP-LJ printer, +# including barcodes for the zip code. A line beginning with `#' or +# an optional alternate separator can be used to separate multiple +# addresses. The parser will strip the formatting commands from an +# address in a troff or LaTeX letter. +# +# usage: envelope [options] < address(es) +# +# Typically, envelope is used from inside an editor. In emacs, mark +# the region of the address and do +# M-| envelope +# In vi, put the cursor on the first line of the address and do +# :,+N w !envelope +# where N = number-of-lines-in-address. +# +# The barcode algorithm is adapted from a perl script by Todd Merriman +# <todd@toolz.uucp>, Dave Buck <dave@dlb.uucp>, and Andy Rabagliati +# <andyr@wizzy.com>. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options +global Printertype + +procedure main(arg) + local opts, lp, separator, printerinit, printerclear, + hpinit, hppos, xorigin, yorigin, rotate, font, + prn, addr, psprefix, preface, optstr, usage, goodline + + usage := ["usage: envelope [options] < address(es)", + "\t-p | -postscript", + "\t-h | -hplj", + "\t-l | -printer spooler-program", + "\t-s | -separator string", + "\t-i | -init printer-init", + "\t-c | -clear printer-clear", + "\t-f | -font fontname [Postscript only]", + "\t-x | -xorigin xorigin [Postscript only]", + "\t-y | -yorigin yorigin [Postscript only]", + "\t-r | -rotate rotation [Postscript only]", + "\t-hpinit string [hplj only]", + "\t-hppos string [hplj only]" ] + psprefix := ["%! Postscript", + "/adline { 10 y moveto show /y y 13 sub def } def", + "/barcode {", + " /y y 13 sub 0.72 div def", + " 0.72 dup scale 2 setlinewidth", + " /x 100 def", + " /next { x y moveto /x x 5 add def } def", + " /S { next 0 5 rlineto stroke } def", + " /L { next 0 12 rlineto stroke } def } def", + "/newenvelope {", + " /y 80 def" ] + optstr := "hpl:f:r+i:c:x+y+s:?" + optstr ||:= "-help!-printer:-hpinit:-hppos:-postscript!:-font:-hplj!" + optstr ||:= "-rotate+-xorigin+-yorigin+-init:-clear:-separator:" + opts := options(arg, optstr) + \opts["?"|"help"] | arg[1] == "?" & { + every write (!usage) + exit (-1) + } + # change defaults below as needed + Printertype := "hplj" + lp := \opts["l"|"printer"] | "lpr" + separator := \opts["s"|"separator"] | "#" + printerinit := \opts["i"|"init"] | "" + printerclear := \opts["c"|"clear"] | "" + # the next four are Postscript-only + xorigin := \opts["x"|"xorigin"] | 200 + yorigin := \opts["y"|"yorigin"] | 400 + rotate := \opts["r"|"rotate"] | 90 + font := \opts["f"|"font"] | "Palatino-Bold" + # these two are hplj-only + # comm. env., manual feed, landscape + hpinit := \opts["hpinit"] | "\33&k2G\33&l81a3h1O" + hppos := \opts["hppos"] | "\33&a40L\33*p550Y" + + \opts["h"|"hplj"] & Printertype := "hplj" + \opts["p"|"postscript"] & Printertype := "postscript" + if "pipes" == &features then prn := open(lp, "pw") + else if "MS-DOS" == &features then prn := open ("PRN", "w") + else stop ("envelope: please configure printer") + writes(prn, printerinit) + + if map(Printertype) == "postscript" then { + every write(prn, !psprefix) + write(prn, " ", xorigin, " ", yorigin, " translate ", rotate, " rotate") + write(prn, " /", font, " findfont 12 scalefont setfont } def") + preface := "newenvelope\n" + } + else preface := hpinit || hppos + addr := [] + every !&input ? { + # filter troff junk + =(".DE" | ".fi") & break + if =(".DS" | ".nf") then tab(0) + # multiple addresses with separators + if =separator then { + (*addr > 0) & address(addr, prn, preface) + addr := [] + tab(0) + } + # filter LaTeX junk + else { + if ="\\begin" then { + every tab(upto('{')+1) \2 + goodline := clean(tab(0), '\\') + } + else goodline := clean(tab(0), '\\') + put(addr, trim(goodline, ' }')) + } + } + (*addr > 0) & address(addr, prn, preface) + writes(prn, printerclear) +end + + +procedure address(addr, prn, preface) + local zip, zline + + zip := "" + writes(prn, preface) + every !addr ? + if map(Printertype) == "postscript" then + write(prn, "(", tab(0), ") adline") + else write(prn, tab(0)) + # scan for zipcode + while *(zline := trim(pull(addr))) = 0 + reverse(zline) ? if many(&digits++'-') = (6|11) then + while tab(upto(&digits)) do zip ||:= tab(many(&digits)) + (*zip = (5|9)) & barcode(reverse(zip), prn) + if map(Printertype) == "postscript" then write(prn, "showpage") + else writes(prn, "\33E") +end + + +procedure barcode(zip, prn) + local z, zipstring, cksum, bar + + cksum := 0 + every cksum +:= !zip + zip := zip || (100 - cksum) % 10 + bar := ["LLSSS", "SSSLL", "SSLSL", "SSLLS", "SLSSL", + "SLSLS", "SLLSS", "LSSSL", "LSSLS", "LSLSS" ] + # The barcode is wrapped in long marks + zipstring := "L" + # Icon lists are indexed from 1 + every z := !zip do zipstring ||:= bar[z + 1] + zipstring ||:= "L" + if map(Printertype) == "postscript" then write(prn, "barcode") + else writes(prn, "\33*p990y1575X\33*c6A") + every !zipstring ? + if map(Printertype) == "postscript" then write(prn, tab(0)) + else { + if =("S") then writes(prn, "\33*p+21Y\33*c15b0P\33*p-21Y") + else writes(prn, "\33*c36b0P") + writes(prn, "\33*p+15X") + } +end + + +procedure clean(s, c) + local i + + while i := upto(c, s) do s[i:many(c,s,i)] := "" + return s +end diff --git a/ipl/progs/evaluate.icn b/ipl/progs/evaluate.icn new file mode 100644 index 0000000..0137e9f --- /dev/null +++ b/ipl/progs/evaluate.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: evaluate.icn +# +# Subject: Program to evaluate Icon expressions +# +# Author: Ralph E. Griswold +# +# Date: March 4, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program evaluates Icon operations given from standard input in +# functional form. It cannot handle nested expressions or control +# structures. See eval.icn for more details. +# +# There is one option: +# +# -l i limit on number of results from a generator; default 2 ^ 30 +# +############################################################################ +# +# Links: eval, options +# +############################################################################ + +link eval +link options + +procedure main(args) + local expr, opts, limit + + opts := options(args, "l+") + limit := \opts["l"] | 2 ^ 30 + + while expr := read() do + every write(eval(expr)) \ limit + +end diff --git a/ipl/progs/extweave.icn b/ipl/progs/extweave.icn new file mode 100644 index 0000000..577318c --- /dev/null +++ b/ipl/progs/extweave.icn @@ -0,0 +1,145 @@ +############################################################################ +# +# File: extweave.icn +# +# Subject: Program to extract weaving specifications from weave file +# +# Author: Ralph E. Griswold +# +# Date: September 17, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program extracts the weaving specifications from a Macintosh +# Painter 5 weave file in MacBinary format. (It might work on Painter 4 +# weave files; this has not been tested.) +# +# The file is read from standard input. +# +# The output consists of seven lines for each weaving specification in the +# file: +# +# wave name +# warp expression +# warp color expression +# weft expression +# weft color expression +# tie-up +# blank separator +# +# The tie-up is a 64-character string of 1s and 0s in column order. That +# is, the first 8 character represent the first column of the tie-up. A +# 1 indicates selection, 0, non-selection. +# +# This program does not produce the colors for the letters in color +# expressions. We know where they are located but haven't yet figured +# out how to match letters to colors. +# +# See Advanced Weaving, a PDF file on the Painter 5 CD-ROM. +# +############################################################################ + +$define Offset 401 # offset to the first expression + +procedure main(args) + local hex, tieup, i, binary, expr, name, namechars, tartans_list + + namechars := &letters ++ &digits ++ ' -&' + + tartans_list := [] + + binary := "" + + while binary ||:= reads(, 10000) # read the whole file + + # Get names. + + binary ? { + tab(find("FSWI") + 4) # find names + while tab(upto(namechars)) do { # not robust + name := tab(many(namechars)) + if (*name > 3) | (name == "Op") then # "heuristic" + put(tartans_list, name) + tab(upto(namechars)) | break + tab(many(namechars)) + } + } + + binary ? { + move(400) | stop("delta move error") + hex := move(4400) | stop("short file") + write(get(tartans_list)) | stop("short name list") + hex ? { # get the four expressions + every i := (0 to 3) do { + tab(i * 2 ^ 10 + 1) + expr := tab(upto('\x00')) | stop("no null character") + if *expr = 0 then stop("no expression") # no expression + write(expr) + } + tieup := "" + tab(4101) # now the tie-up + every 1 to 8 do { + tieup ||:= map(move(8), "\x0\x1", "01") + move(24) + } + write(decol(tieup)) + write() + } + } + + binary ? { + while tab(find(".KWROYL")) do { + move(4908) | stop("delta move error") + hex := move(4400) | break + write(get(tartans_list)) | stop("short name list") + hex ? { # get the four expressions + every i := (0 to 3) do { + tab(i * 2 ^ 10 + 1) + expr := tab(upto('\x00')) | stop("no null character") + if *expr = 0 then break break # no expression + write(expr) + } + tieup := "" + tab(4101) # now the tie-up + every 1 to 8 do { + tieup ||:= map(move(8), "\x0\x1", "01") + move(24) + } + write(decol(tieup)) + write() + } + } + } + + if *tartans_list > 0 then { + write("Unresolved tartans:") + write() + while write(get(tartans_list)) + } + +end + +procedure decol(s) + local parts, j, form + + parts := list(8, "") + + s ? { + repeat { + every j := 1 to 8 do { + (parts[j] ||:= move(1)) | break break + } + } + } + + form := "" + + every form ||:= !parts + + return form + +end diff --git a/ipl/progs/farb.icn b/ipl/progs/farb.icn new file mode 100644 index 0000000..ae16675 --- /dev/null +++ b/ipl/progs/farb.icn @@ -0,0 +1,1080 @@ +############################################################################ +# +# File: farb.icn +# +# Subject: Program to generate Farberisms +# +# Author: Ralph E. Griswold +# +# Date: June 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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.'' +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +procedure main(arg) + local farb + local count + + randomize() + count := integer(arg[1]) | 1 + + farb := [ + "A buck in the hand is worth two on the books.", + "A carpenter's son doesn't have shoes.", + "A chain is only as strong as its missing link.", + "A dog under any other coat is still a dog.", + "A hand in the bush is worth two anywhere else.", + "A lot of these arguments are fetious.", + "A lot of things are going to be bywashed.", + "A lot of water has gone over the bridge since then.", + "A problem swept under the table occasionally comes home to roost.", + "A rocky road is easier to travel than a stone wall.", + "A shoe in time saves nine.", + "A stop-gap measure is better than no gap at all.", + "A whole hog is better than no hole at all.", + "Abandon ship all you who enter here!", + "After that, we'll break our gums on the computer.", + "All the hills of beans in China don't matter.", + "All the lemmings are coming home to roost.", + "All the lemmings are going home to roost.", + "All you have to do is fill in the missing blanks.", + "An avalanche is nipping at their heels.", + "An enigma is only as good as it's bottom line.", + "An ounce of prevention is better than pounding the table.", + "And I take the blunt of it!", + "Another day, a different dollar.", + "Any kneecap of yours is a friend of mine.", + "Any storm in a port.", + "Anybody who marries her would stand out like a sore thumb.", + "Anything he wants is a friend of mine.", + "Are there any problems we haven't beat out to death?", + "As a token of my unfliching love ... .", + "As long as somebody let the cat out of the bag, we might as well spell it correctly.", + "At the end of every pot of gold, there's a rainbow.", + "Before they made him they broke the mold.", + "Better to toil in anonymity than to have that happen.", + "Beware a Trojan bearing a horse.", + "Boulder dash!", + "By a streak of coincidence, it really happened.", + "By the time we unlock the bandages, he will have gone down the drain.", + "Cheapness doesn't come free.", + "Clean up or fly right.", + "Clean up your own can of worms!", + "Come down off your charlie horse.", + "Conceptual things are in the eye of the beholder.", + "Cut bait and talk turkey.", + "Deep water runs still.", + "Dig a hole and bury it.", + "Dig yourself a hole and bury it.", + "Do it now, before the worm turns.", + "Do it now; don't dingle-dally over it.", + "Do not fumble with a woman's logic.", + "Does it joggle any bells?", + "Don't bite the hand that stabs you in the back.", + "Don't burn your bridges until you come to them.", + "Don't cash in your chips until the shill is down.", + "Don't cast a gander upon the water.", + "Don't cast an eyeball on the face of the water.", + "Don't cast any dispersions.", + "Don't cast doubts on troubled waters.", + "Don't count your chickens until the barn door is closed.", + "Don't criticize him for lack of inexperience.", + "Don't cut off the limb you've got your neck strung out on.", + "Don't do anything I wouldn't do standing up in a hammock.", + "Don't eat with your mouth full.", + "Don't get your eye out of joint.", + "Don't jump off the gun.", + "Don't jump off the handle.", + "Don't jump on a ship that's going down in flames.", + "Don't just stand there like a sitting duck.", + "Don't lead them down the garden path and cut them off at the knees.", + "Don't leave the nest that feeds you.", + "Don't let the camels get their feet in the door.", + "Don't look a gift horse in the face.", + "Don't look a mixed bag in the mouth.", + "Don't look a sawhorse in the mouth.", + "Don't look for a gift in the horse's mouth.", + "Don't make a molehill out of a can of beans.", + "Don't make a tempest out of a teapot.", + "Don't muddle the waters.", + "Don't open Pandora's can of worms.", + "Don't pull a panic button.", + "Don't pull an enigma on me.", + "Don't put all you irons on the fire in one pot.", + "Don't rattle the boat.", + "Don't rattle the cage that rocks the cradle.", + "Don't rock the boat that feeds you.", + "Don't roll up your nostrils at me.", + "Don't stick your oar in muddy waters.", + "Don't strike any bells while the fire is hot.", + "Don't talk to me with your clothes on.", + "Don't talk with your mouth open.", + "Don't throw a monkey wrench into the apple cart.", + "Don't throw the baby out with the dishwasher.", + "Don't throw the dog's blanket over the horse's nose.", + "Don't twiddle your knee-caps at me!", + "Don't upset the apple pie.", + "Dot your t's and cross your i's.", + "Drop the other foot, for Christ's sake!", + "Each day I never cease to be amazed.", + "Each of us sleazes by at our own pace.", + "Erase that indelibly from your memory.", + "Every cloud has a blue horizon.", + "Every rainbow has a silver lining.", + "Everything is going all bananas.", + "Everything is ipso facto.", + "Everything is mutually intertangled.", + "Everything's all ruffled over.", + "Fade out in a blaze of glory.", + "Familiarity breed strange bed linen.", + "Feather your den with somebody else's nest.", + "Fellow alumni run thicker than water.", + "Fish or get off the pot!", + "Float off into several individual conferees.", + "For a change, the foot is on the other sock.", + "For all intensive purposes, the act is over.", + "From here on up, it's down hill all the way.", + "Gander your eye at that!", + "Gee, it must have fallen into one of my cracks.", + "Get off the stick and do something.", + "Get that albatross off his back!", + "Get the hot poop right off the vine.", + "Getting him to do anything is like pulling hen's teeth.", + "Give him a project to get his teeth wet on.", + "Give him a square shake.", + "Give him an inch and he'll screw you.", + "Give him enough rope and he will run away with it.", + "Go fly your little red wagon somewhere else.", + "Good grace is in the eye of the beholder.", + "Good riddance aforethought.", + "Half a loaf is better than two in the bush.", + "Half a worm is better than none.", + "Hands were made before feet.", + "Have it prepared under my signature.", + "Have more discretion in the face of valor.", + "Have the seeds we've sown fallen on deaf ears?", + "Have we been cast a strange eye at?", + "Have we gone too fast too far?", + "He and his group are two different people.", + "He came in on my own volition.", + "He can't hack the other can of worms.", + "He choked on his own craw.", + "He deserves a well-rounded hand of applause.", + "He didn't even bat an eyebrow.", + "He didn't flinch an eyelid.", + "He disappeared from nowhere.", + "He doesn't have the brain to rub two nickels together.", + "He doesn't know A from Z.", + "He doesn't know which side his head is buttered on.", + "He drinks like a sieve.", + "He flipped his cork.", + "He gave me a blanket check.", + "He got taken right through the nose.", + "He got up on his highheels.", + "He grates me the wrong way.", + "He has a dire need, actually it's half-dire, but he thinks it's double-dire.", + "He has a marvelous way of extruding you.", + "He has a very weak indigestion.", + "He has a wool of steel.", + "He has feet of molasses.", + "He has his ass on the wrong end of his head.", + "He has his crutches around her throat.", + "He has his foot in the pie.", + "He has his neck out on a limb.", + "He has his pot in too many pies.", + "He has the character of navel lint.", + "He has the courage of a second-story man.", + "He hit the nose right on the head.", + "He is as dishonest as the day is long.", + "He just sat there like a bump on a wart.", + "He keeps his ear to the vine.", + "He knows which side his pocketbook is buttered on.", + "He knows which side of his bread his goose is buttered on.", + "He may be the greatest piece of cheese that ever walked down the plank.", + "He needs to get blown out of his water.", + "He popped out of nowhere like a jack-in-the-bean-box.", + "He pulled himself up on top of his own bootstraps.", + "He puts his heads on one neck at a time.", + "He rammed it down their ears.", + "He reads memos with a fine tooth comb.", + "He rules with an iron thumb.", + "He said it thumb in cheek.", + "He should be gracious for small favors.", + "He smokes like a fish.", + "He takes to water like a duck takes to tarmac.", + "He wants to get his nose wet in several areas.", + "He was hoisted by a skyhook on his own petard!", + "He was hoisted by his own canard.", + "He was hung by his own bootstraps.", + "He was left out on the lurch.", + "He was putrified with fright.", + "He was running around like a person with his chicken cut off.", + "He waxed incensive.", + "He wears his finger on his sleeve.", + "He would forget his head if it weren't screwed up.", + "He'll get his neck in hot water.", + "He'll grease any palm that will pat his ass.", + "He's a bulldog in a china shop.", + "He's a child progeny.", + "He's a fart off the old block.", + "He's a lion in a den of Daniels.", + "He's a little clog in a big wheel.", + "He's a shirking violet.", + "He's a wolf in sheep's underware.", + "He's a young peeksqueek.", + "He's as crazy as a bloody loon!", + "He's as crazy as a fruitcake.", + "He's as happy as a pig at high tide.", + "He's as quick as an eyelash.", + "He's as ugly as Godzilla the Hun.", + "He's bailing him out of the woods.", + "He's been living off his laurels for years.", + "He's being pruned for the job.", + "He's being shifted from shuttle to cock.", + "He's biting the shaft and getting the short end of the problem.", + "He's breathing down my throat.", + "He's casting a red herring on the face of the water.", + "He's clam bait.", + "He's cornered on all sides.", + "He's faster than the naked eye.", + "He's foot sure and fancy free.", + "He's fuming at the seams.", + "He's going to fall flat on his feet.", + "He's got a rat's nest by the tail.", + "He's got a tough axe to hoe.", + "He's got bees in his belfry.", + "He's got four sheets in the wind.", + "He's got his intentions crossed.", + "He's got so much zap he can barely twitch.", + "He's guilty of obfuscation of justice.", + "He's king bee.", + "He's letting ground grow under his feet.", + "He's like Godzilla the Hun.", + "He's like a wine glass in a storm.", + "He's like sheep in a bullpen.", + "He's lying through his britches.", + "He's not breathing a muscle.", + "He's off in a cloud of ``hearty heigh-ho Silver''.", + "He's on the back of the pecking order.", + "He's one of the world's greatest flamingo dancers.", + "He's paying through the neck.", + "He's procrastinating like a bandit.", + "He's reached the crescent of his success.", + "He's restoring order to chaos.", + "He's running around like a bull with his head cut off.", + "He's running around like a chicken with his ass cut off.", + "He's running around with his chicken cut off.", + "He's running from gamut to gamut.", + "He's running off at the seams.", + "He's salivating at the chops.", + "He's seething at the teeth.", + "He's sharp as a whip.", + "He's singing a little off-keel.", + "He's so far above me I can't reach his bootstraps.", + "He's so mad he is spitting wooden nickels.", + "He's somewhere down wind of the innuendo.", + "He's spending a lot of brunt on the task.", + "He's splitting up at the seams.", + "He's taking his half out of our middle.", + "He's the best programmer east of the Mason-Dixon line.", + "He's the king of queens.", + "He's the last straw on the camel's back to be called.", + "He's too smart for his own bootstraps.", + "He's tossing symbols around like a percussionist in a John Philip Sousa band.", + "He's up a creek with his paddles leaking.", + "He's within eyeshot of shore.", + "He's working like a banshee.", + "Heads are rolling in the aisles.", + "His eyeballs perked up.", + "His feet have come home to roost.", + "His foot is in his mouth up to his ear.", + "His head's too big for his britches.", + "His limitations are limitless.", + "His position is not commiserate with his abilities.", + "History is just a repetition of the past.", + "Hold on real quick.", + "Hold your cool!", + "How old is your 2-year old?", + "I accept it with both barrels.", + "I apologize on cringed knees.", + "I came within a hair's breathe of it.", + "I can do it with one eye tied behind me.", + "I can meet your objections.", + "I can remember everything \(em I have a pornographic mind.", + "I can't hum a straight tune.", + "I case my ground very well before I jump into it.", + "I come to you on bended bootstrap.", + "I contributed to the charity of my cause.", + "I could count it on the fingers of one thumb.", + "I could tell you stories that would curdle your hair.", + "I did it sitting flat on my back.", + "I don't always play with a full house of cards.", + "I don't give a Ricardo's Montalban what you think.", + "I don't know which dagger to clothe it in.", + "I don't like the feel of this ball of wax.", + "I don't want to be the pie that upset the applecart.", + "I don't want to cast a pall on the water.", + "I don't want to start hurdling profanity.", + "I don't want to stick my hand in the mouth that's feeding me.", + "I don't want to throw a wrench in the ointment.", + "I enjoy his smiling continence.", + "I flew it by ear.", + "I gave him a lot of rope and he took it, hook, line, and sinker.", + "I got you by the nap of your neck.", + "I guess I'd better get my duff on the road.", + "I guess I'm putting all my birds in one pie.", + "I guess that muddled the waters.", + "I had her by the nap of the neck.", + "I had to make a split decision.", + "I had to scratch in the back recesses of my memory.", + "I had to throw in the white flag.", + "I have a green thumb up to my elbow.", + "I have a rot-gut feeling about that.", + "I have feedback on both sides of the coin.", + "I have my neck hung out on an open line.", + "I have no personal bones to grind about it.", + "I have people crawling out of my ears.", + "I have post-naval drip.", + "I have reasonably zero desire to do it.", + "I have the self-discipline of a mouse.", + "I have to get my guts up.", + "I have too many cooks in the pot already.", + "I haven't bitten off an easy nut.", + "I haven't gotten the knack down yet.", + "I hear the handwriting on the wall.", + "I heard it out of the corner of my eye.", + "I heard it out of the corner of my eyes.", + "I just got indicted into the Hall of Fame.", + "I just pulled those out of the seat of my pants.", + "I keep stubbing my shins.", + "I know what we have to do to get our feet off the ground.", + "I listen with a very critical eye.", + "I looked at it with some askance.", + "I march to a different kettle of fish.", + "I need to find out where his head is coming from.", + "I only hear half of what I believe.", + "I only hope your every wish is desired.", + "I only mentioned it to give you another side of the horse.", + "I only read it in snips and snabs.", + "I owe you a great gratitude of thanks.", + "I pulled my feet out from under my rug.", + "I put all my marbles in one basket.", + "I read the sign, but it went in one ear and out the other.", + "I reject it out of the whole cloth.", + "I resent the insinuendoes.", + "I rushed around like a chicken out of my head.", + "I said it beneath my breath.", + "I see several little worms raising their heads around the corner.", + "I smell a needle in the haystack.", + "I speak only with olive branches dripping from the corners of my mouth.", + "I think I've committed a fore paw.", + "I think I've lost my bonkers.", + "I think he's gone over the bend.", + "I think that we are making an out-and-out molehill of this issue.", + "I think the real crux is the matter.", + "I thought I'd fall out of my gourd.", + "I want half a cake and eat it too.", + "I want to embark upon your qualms.", + "I want to get more fire into the iron.", + "I want to get to know them on a face-to-name basis.", + "I want to go into that at short length.", + "I want to see him get a good hands-on feel.", + "I want to see the play like a hole in the head.", + "I was working my balls to the bone.", + "I wish somebody could drop the other foot.", + "I won't do it if it's the last thing I do!", + "I won't hang my laurels on it.", + "I won't kick a gift horse in the mouth.", + "I worked my toes to the bonenail.", + "I would imagine he chafes a bit.", + "I wouldn't do it for a ton of bricks.", + "I wouldn't give it to a wet dog.", + "I wouldn't marry her with a twenty-foot pole.", + "I wouldn't take him on a ten foot pole.", + "I wouldn't take it for granite, if I were you.", + "I wouldn't want to be sitting in his shoes.", + "I'd better get my horse on it's ass.", + "I'd better jack up my bootstraps and get going.", + "I'd have been bent out of shape like spades.", + "I'd kill a dog to bite that man.", + "I'd like to intersperse a comment.", + "I'd like to put another foot into the pot.", + "I'd like to strike while the inclination is hot.", + "I'd rather be tight than right.", + "I'll be ready just in case a windfall comes down the pike.", + "I'll be there in the next foreseeable future.", + "I'll be there with spades one.", + "I'll bet there's one guy out in the woodwork.", + "I'll descend on them to the bone.", + "I'll fight him hand and nail.", + "I'll fight to the nail.", + "I'll hit him right between the teeth.", + "I'll procrastinate when I get around to it.", + "I'll reek the benefits.", + "I'll see it when I believe it.", + "I'll stay away from that like a 10-foot pole.", + "I'll take a few pegs out of his sails.", + "I'll take any warm body in a storm.", + "I'm a mere fragment of my imagination.", + "I'm all ravelled up.", + "I'm as happy as a pig in a blanket.", + "I'm basking in his shadow.", + "I'm burning my bridges out from under me!", + "I'm casting the dye on the face of the water.", + "I'm collapsing around the seams.", + "I'm creaking at the seams.", + "I'm creaming off the top of my head.", + "I'm deathly curious.", + "I'm flapping at the gills.", + "I'm going off tangentially.", + "I'm going right out of my bonker.", + "I'm going right over the bend.", + "I'm going to blow their socks out of the water.", + "I'm going to cast my rocks to the wind.", + "I'm going to down-peddle that aspect.", + "I'm going to feel it out by the ear.", + "I'm going to litigate it to the eyeballs.", + "I'm going to put a little variety in your spice of life.", + "I'm going to put my horn in.", + "I'm going to read between your lines.", + "I'm going to resolve it by ear.", + "I'm going to scatter them like chaff before the wind.", + "I'm going to scream right out of my gourd.", + "I'm going to take my vendetta out on them.", + "I'm going to take my venom out on you.", + "I'm going to throw myself into the teeth of the gamut.", + "I'm ground up to a high pitch.", + "I'm having a hard time getting my handles around that one.", + "I'm in my reclining years.", + "I'm in transit on that point.", + "I'm just a cog in the wheel.", + "I'm listening with baited ears.", + "I'm looking at it with a jaundiced ear.", + "I'm not going to bail him out of his own juice.", + "I'm not going to beat a dead horse to death.", + "I'm not going to get side tracked onto a tangent.", + "I'm not going to stand for this lying down.", + "I'm not sure it's my bag of tea.", + "I'm not sure we're all speaking from the same sheet of music.", + "I'm not trying to grind anybody's axes.", + "I'm out of my bloomin' loon.", + "I'm over the hilt.", + "I'm parked somewhere in the boondoggles.", + "I'm pulling something over on you.", + "I'm ready to go when the bell opens.", + "I'm running around like a one-armed paper bandit.", + "I'm signing my own death knell.", + "I'm sitting on the edge of my ice.", + "I'm smarting at the seams.", + "I'm soaked to the teeth.", + "I'm standing over your shoulder.", + "I'm sticking my neck out on a ledge.", + "I'm stone cold sane.", + "I'm talking up a dead alley.", + "I'm throwing those ideas to you off the top of my hat.", + "I'm too uptight for my own bootstraps.", + "I'm up a wrong alley.", + "I'm up against a blind wall.", + "I'm up to my earballs in garbage.", + "I'm walking on cloud nine.", + "I'm walking on thin water.", + "I'm weighted down with baited breath.", + "I'm willing to throw my two cents into the fire.", + "I'm working my blood up into a fervor.", + "I'm wound up like a cork.", + "I'm your frontface in this matter.", + "I's as finished as I'm going to take.", + "I've been burning the midnight hours.", + "I've been eating peanuts like they were coming out of my ears.", + "I've built enough fudge into that factor.", + "I've got applicants up to the ears.", + "I've got to put my duff to the grindstone.", + "I've had it up to the hilt.", + "I've had more girls than you've got hair between your teeth.", + "I've milked that dead end for all it's worth.", + "I've worked my shins to the bone.", + "If Calvin Coolidge were alive today, he'd turn over in his grave.", + "If anything, I bend over on the backwards side.", + "If not us, when?", + "If the onus fits, wear it.", + "If the shoe fits, put it in your mouth.", + "If the shoe is on the other foot, wear it.", + "If there's no fire, don't make waves.", + "If they do it there won't be a living orgasm left.", + "If they do that, they'll be committing suicide for the rest of their lives.", + "If they had to stand on their own two feet, they would have gone down the drain a long time ago.", + "If we keep going this way, somebody is going to be left standing at the church with his pants on.", + "If you ask him he could wax very quickly on that subject.", + "If you don't want words put in your mouth, don't leave it hanging open.", + "If you listen in the right tone of voice, you'll hear what I mean.", + "If you see loose strings that have to be tied down that are not nailed up, see me about it.", + "If you want something bad enough, you have to pay the price.", + "If you want to be heard, go directly to the horse's ear.", + "If you want to get your jollies off, watch this!", + "If you'd let me, I'd forget the shirt off my back.", + "If you're going to break a chicken, you have to scramble a few eggs.", + "In one follicle, out the other.", + "In one mouth and out the other.", + "In this period of time, its getting very short.", + "In this vein I will throw out another item for Pandoras' box.", + "Indiscretion is the better part of valor.", + "Is he an Amazon!", + "Is there any place we can pull a chink out of the log jam?", + "It cuts like a hot knife through solid rock.", + "It drove me to no wits end.", + "It fills a well-needed gap.", + "It floated right to the bottom.", + "It flows like water over the stream.", + "It gets grained into you.", + "It goes from one gamut to another.", + "It goes from tippy top to tippy bottom.", + "It goes in one era and out the other.", + "It goes out one ear and in the other.", + "It got left out in the lurch.", + "It has more punch to the unch.", + "It hit me to the core.", + "It hit the epitome of it.", + "It is better to have tried and failed than never to have failed at all.", + "It leaks like a fish.", + "It looks like it's going to go on ad infinitum for a while.", + "It looks real enough to be artificial.", + "It may seem incredulous, but it's true.", + "It might break the straw that holds the camel's back.", + "It might have been a figment of my illusion.", + "It peaked my interest.", + "It rolls off her back like a duck.", + "It runs the full width of the totem pole.", + "It sounds like roses to my ears.", + "It sure hits the people between the head.", + "It was a heart-rendering decision.", + "It was a maelstrom around his neck.", + "It was deja vu all over again.", + "It was oozing right out of the lurches.", + "It was really amazing to see the spectra of people there.", + "It went through the palm of my shoe.", + "It will spurn a lot of furious action.", + "It will take a while to ravel down.", + "It' not an easy thing to get your teeth around.", + "It's a Byzantine thicket of quicksand.", + "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 hairy banana.", + "It's a hairy can of worms.", + "It's a hiatus on the face of the void.", + "It's a home of contention.", + "It's a lot like recumbent DNA.", + "It's a lot of passed water under the bridge.", + "It's a mare's nest in sheep's clothing.", + "It's a mecca of people.", + "It's a monkey wrench in your ointment.", + "It's a new high in lows.", + "It's a road of hard knocks.", + "It's a sight for sore ears.", + "It's a slap in the chaps.", + "It's a tempest in a teacup.", + "It's a terrible crutch to bear.", + "It's a tough nut to hoe.", + "It's a tough road to haul.", + "It's a travesty to the human spirit.", + "It's a typical case of alligator mouth and hummingbird ass.", + "It's a useful ace in the pocket.", + "It's a vigin field pregrant with possibilities.", + "It's a white elephant around my neck.", + "It's a white herring.", + "It's about 15 feet as the eye flies.", + "It's about as satisfactory as falling off a log.", + "It's all above and beyond board.", + "It's all in knowing when to let a dead horse die.", + "It's all water under the dam.", + "It's always better to be safe than have your neck out on a limb.", + "It's an ill wind that doesn't blow somebody.", + "It's another millstone in the millpond of life.", + "It's as dry as dish water.", + "It's as easy as falling off a piece of cake.", + "It's as flat as a door knob.", + "It's as predictable as cherry pie.", + "It's been ubiquitously absent", + "It's bouncing like a greased pig.", + "It's burned to shreds.", + "It's crumbling at the seams.", + "It's enough to make you want to rot your socks.", + "It's going to bog everybody up.", + "It's going to fall on its ass from within.", + "It's got all the bugs and whistles.", + "It's hanging out like a sore tongue.", + "It's just a small kink in the ointment.", + "It's like a greased pig in a wet blanket.", + "It's like a knife through hot butter.", + "It's like a raft on roller skates.", + "It's like asking a man to stop eating in the middle of a starvation diet.", + "It's like harnessing a hare to a tortoise.", + "It's like pulling hen's teeth.", + "It's like talking to a needle in a haystack.", + "It's like the flood of the Hesperis.", + "It's like trying to light a fire under a lead camel.", + "It's like trying to squeeze blood out of a stone.", + "It's more than the mind can boggle.", + "It's music to your eyes.", + "It's no chip off my clock.", + "It's no skin off my stiff upper lip.", + "It's no sweat off my nose.", + "It's not an easy thing to get your teeth wet on.", + "It's not completely an unblessed advantage.", + "It's not his bag of tea.", + "It's not my Diet of Worms.", + "It's not my cup of pie.", + "It's not really hide nor hair.", + "It's one more cog in the wheel.", + "It's perfect, but it will have to do.", + "It's raining like a bandit.", + "It's right on the tip of my head.", + "It's sloppy mismanagement.", + "It's so unbelievable you wouldn't believe it.", + "It's something you're all dying to wait for.", + "It's the blind leading the deaf.", + "It's the greatest little seaport in town.", + "It's the old Paul Revere bit . . . one if by two and two if by one.", + "It's the old chicken-in-the-egg problem.", + "It's the other end of the kettle of fish.", + "It's the screws of progress.", + "It's the straw that broke the ice.", + "It's the the highest of the lows.", + "It's the vilest smell I ever heard.", + "It's time to take off our gloves and talk from the heart.", + "It's under closed doors.", + "It's within the pall of reason.", + "It's wrought with problems.", + "It's your ball of wax, you unravel it.", + "Its coming down like buckets outside.", + "Jesus died to save our sins.", + "Judas Proust!", + "Judge him by his actions, not his deeds.", + "Just because it's there, you don't have to mount it.", + "Just cut a thin slither of it.", + "Just remember that, and then forget it.", + "Just remember, this too will come to pass", + "Just say whatever pops into your mouth.", + "Keep the water as firm as possible until a fellow has his feet on the ground.", + "Keep this under your vest.", + "Keep your ear peeled!", + "Keep your eyes geared to the situation.", + "Keep your nose to the mark.", + "Keep your nose to the plow.", + "Lay a bugaboo to rest.", + "Let a dead horse rest.", + "Let he who casts the first stone cast it in concrete.", + "Let him be rent from limb to limb.", + "Let him fry in his own juice.", + "Let him try this in his own petard!", + "Let it slip between the cracks.", + "Let me clarify my fumbling.", + "Let me feast your ears.", + "Let me flame your fan.", + "Let me say a word before I throw in the reins.", + "Let me take you under my thumb.", + "Let me throw a monkey into the wrench.", + "Let me throw a monkey wrench in the ointment.", + "Let sleeping uncertainties lie.", + "Let them fry in their socks.", + "Let them hang in their own juice.", + "Let's bend a few lapels.", + "Let's get down to brass facts.", + "Let's go outside and commiserate with nature.", + "Let's grab the initiative by the horns.", + "Let's kick the bucket with a certain amount of daintiness.", + "Let's kill two dogs with one bone.", + "Let's look at it from the other side of the view.", + "Let's lurch into the next hour of the show.", + "Let's not drag any more dead herrings across the garden path.", + "Let's not get ahead of the bandwagon.", + "Let's not hurdle into too many puddles at once.", + "Let's not open the skeleton in that closet.", + "Let's play the other side of the coin.", + "Let's pour some holy water on the troubled feathers.", + "Let's put out a smeller.", + "Let's raise our horizons.", + "Let's roll up our elbows and get to work.", + "Let's set up a straw vote and knock it down.", + "Let's shoot holes at it.", + "Let's skin another can of worms.", + "Let's solve two problems with one bird.", + "Let's strike the fire before the iron gets hot.", + "Let's talk to the horse's mouth.", + "Let's wreck havoc!", + "Like the shoemaker's children, we have computers running out of our ears.", + "Look at the camera and say `bird'.", + "Look before you turn the other cheek.", + "Look up that word in your catharsis!", + "Man cannot eat by bread alone.", + "May I inveigle on you?", + "May the wind at your back never be your own.", + "Men, women, and children first!", + "Mind your own petard!", + "My antipathy runneth over.", + "My chicken house has come home to roost.", + "My dog was pent up all day.", + "My ebb is running low.", + "My foot is going out of its mind.", + "My head is twice its size.", + "My laurels have come home to roost.", + "My mind is a vacuum of information.", + "My mind slipped into another cog.", + "My mind went blank and I had to wait until the dust cleared.", + "My off-the-head reaction is negative.", + "My steam is wearing down.", + "My stomach gets all knotted up in rocks.", + "My train of thought went out to lunch.", + "Necessity is the invention of strange bedfellows.", + "Necessity is the mother of reality.", + "Necessity is the mother of strange bedfellows.", + "Never accept an out-of-state sanity check.", + "Never feed a hungry dog an empty loaf of bread.", + "Never the twixt should change.", + "No Californian will walk a mile if possible.", + "No crumbs gather under his feet.", + "No dust grows under her feet.", + "No loaf is better than half a loaf at all.", + "No moss grows on his stone.", + "No moss grows under Charlie's rock.", + "No one can predict the wheel of fortune as it falls.", + "No problem is so formidable that you can't just walk away from it.", + "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.", + "Nobody's going to put his neck out on a limb.", + "Nostalgia just isn't what it used to be.", + "Not all the irons in the fire will bear fruit or even come home to roost.", + "Not by the foggiest stretch of the imagination!", + "Not in a cocked hat, you don't!", + "Not in a pig's bladder you don't!", + "Not me, I didn't open my peep.", + "Not on your bootstraps!", + "Now he's sweating in his own pool.", + "Now the laugh is on the other foot!", + "Now we have some chance to cut new water.", + "One back scratches another.", + "One doesn't swallow the whole cake at the first sitting.", + "One man's curiosity is another man's Pandora's box.", + "Our backs are up the wall.", + "Our deal fell through the boards.", + "Peanut butter jelly go together hand over fist.", + "People in glass houses shouldn't call the kettle black.", + "Picasso wasn't born in a day.", + "Pick them up from their bootstraps.", + "Pictures speak louder than words.", + "Please come here ipso pronto.", + "Pour sand on troubled waters.", + "Prices are dropping like flies.", + "Put all your money where your marbles are.", + "Put it in a guinea sack.", + "Put it on the back burner and let it simper.", + "Put it on the back of the stove and let it simper.", + "Put that in your pocket and smoke it!", + "Put the onus on the other foot.", + "Put your mouth where your money is.", + "Put yourself in his boat.", + "Right off the top of my cuff, I don' know what to say.", + "Right off the top of my hand, I'd say no.", + "Roll out the Ouija ball.", + "Rome wasn't built on good intentions alone.", + "Row, row, row your boat, gently down the drain.", + "See the forest through the trees.", + "She had a missed conception.", + "She had an aurora of goodness about her.", + "She has eyes like two holes in a burnt blanket.", + "She hit the nail on the nose.", + "She looks like she's been dead for several years, lately.", + "She makes Raquel Welch look like Twiggy standing backwards.", + "She stepped full-face on it.", + "She was sitting there with an insidious look on her face.", + "She'll fight it tooth and toenail.", + "She'll show up if she cares which side her ass is buttered on.", + "She's a virgin who has never been defoliated.", + "She's flying off the deep end.", + "She's got a bee in her bonnet and just won't let it go.", + "She's melting out punishment.", + "She's steel wool and a yard wide.", + "She's trying to feather her own bush.", + "Shoot it up the flag pole.", + "Somebody is going to have to take a forefront here.", + "Somebody pushed the panic nerve.", + "Somebody's flubbing his dub.", + "Someone is going to be left in the church with his pants on.", + "Sometimes I don't have both sails in the water.", + "Speaking off the hand, I'd advise you to quit.", + "Straighten up or fly right.", + "Strange bedfellows flock together.", + "Take care of two stones with one bird.", + "Take it with a block of salt.", + "Take this timeline with a large grain of salt.", + "That aspect permutes the whole situation.", + "That curdles my toes.", + "That curdles the milk of human kindness.", + "That didn't amount to a hill of worms.", + "That doesn't cut any weight with him.", + "That job is at the bottom of the rung.", + "That makes me as mad as a wet hatter.", + "That old witch gave me the eagle eye.", + "That opens up a whole other kettle of songs.", + "That problem is getting pushed into the horizon.", + "That puts me up a worse creek.", + "That really throws a monkey into their wrench.", + "That really uprooted the apple cart.", + "That restaurant is so crowded no one goes there anymore.", + "That solves two stones with one bird.", + "That took the edge off the pumpkin.", + "That was a mere peanut in the bucket.", + "That was almost half done unconsciously.", + "That was like getting the horse before the barn.", + "That was the corker in the bottle.", + "That was the pan he was flashed in.", + "That would drive him right out of his banana.", + "That would have been right up Harry's meat.", + "That would pry the socks off a dead cat.", + "That'll take the steam out of their sails.", + "That's a ball of another wax.", + "That's a bird of a different color.", + "That's a camel's eye strained through a gnat's tooth.", + "That's a different cup of fish.", + "That's a different jar of worms.", + "That's a horse of a different feather.", + "That's a matter for sore eyes.", + "That's a measle-worded statement if I ever heard one.", + "That's a sight for deaf ears.", + "That's a tough nut to carry on your back.", + "That's a two-edged circle.", + "That's a whole new ballpark.", + "That's an unexpected surprise.", + "That's getting to the crotch of the matter.", + "That's just putting the gravy on the cake.", + "That's no sweat off my back.", + "That's not my sack of worms.", + "That's obviously a very different cup of fish.", + "That's pushing a dead horse.", + "That's the other end of the coin.", + "That's the straw that broke the camel's hump.", + "That's the wart that sank the camel's back.", + "That's the way the old ball game bounces.", + "That's the whole ball of snakes.", + "That's the whole kettle of fish in a nutshell.", + "That's the whole kit and caboose.", + "That's their applecart, let them choke on it.", + "That's water under the dam.", + "That's way down in the chicken feed.", + "That's when I first opened an eyelash.", + "That's worse than running chalk up and down your back.", + "The aggressor is on the wrong foot.", + "The analogy is a deeply superficial one.", + "The atmosphere militates against a solution.", + "The ball is in our lap.", + "The circuit breaker just kicked in.", + "The die has been cast on the face of the waters.", + "The domestic problems are a terrible can of worms.", + "The early bird will find his can of worms.", + "The early worm catches the fish.", + "The eggs we put all in one basket have come home to roost.", + "The faculty has cast a jaundiced eye upon the waters.", + "The fervor is so deep you can taste it.", + "The foot that rocks the cradle is usually in the mouth.", + "The fruits of our labors are about to be felt.", + "The future is not what it used to be.", + "The grass is always greener when you can't see the forest for the trees.", + "The gremlins have gone off to roost on someone else's canard.", + "The grocer's son always has shoes.", + "The groundwork is thoroughly broken.", + "The hand is on the wall.", + "The horse is stolen before the barn even gets its door closed.", + "The idea did cross my head.", + "The ideas sprang full-blown from the hydra's heads.", + "The importance of that cannot be underestimated.", + "The initiative is on the wrong foot.", + "The lights are so bright the air is opaque.", + "The meeting was a first-class riot squad.", + "The onus is on the other foot.", + "The onus of responsibility lies on his shoulders.", + "The people are too nameless to number.", + "The pipeline has ramped up.", + "The restaurants are terrible \(em the town is completely indigestible.", + "The screws of progress grind fine.", + "The sink is shipping.", + "The town is a simmering powder keg.", + "The up-kick of all that will be nothing.", + "The viewpoints run from hot to cold.", + "The whole thing is a hairy potpourri.", + "The wishbone's connected to the kneebone.", + "Their attitude is to let lying dogs sleep.", + "There are enough cooks in the pot already.", + "There are no easy bullets.", + "There are too many cooks and not enough indians.", + "There are too many people in the soup.", + "There are two sides to every marshmallow.", + "There hasn't been much of a peep about it.", + "There is a prolifery of new ideas.", + "There is no surefool way of proceeding.", + "There is one niche in his armor.", + "There is some milk of contention between us.", + "There was danger lurking under the tip of an iceberg.", + "There were foot-high puddles.", + "There will be fangs flying.", + "There's a dark cloud on every rainbow's horizon.", + "There's a flaw in the ointment.", + "There's a little life in the old shoe yet.", + "There's a lot of blanche here to carte.", + "There's a lot of bull in the china shop.", + "There's a lot of credibility in that gap!", + "There's a strong over current here.", + "There's a vortex swimming around out there.", + "There's going to be hell and high water to pay.", + "There's laughing on the outside, panelling on the inside.", + "There's more than one way to skin an egg without letting the goose out of the bag.", + "There's no place in the bowl for another spoon to stir the broth.", + "There's no two ways around it.", + "There's nothing like stealing the barn door after the horse is gone.", + "There's only so many times you can beat a dead horse.", + "There's some noise afoot about the problem.", + "There's some trash to be separated from the chaff.", + "They are straining at nits.", + "They are unscrupulously honest.", + "They are very far and few between.", + "They closed the doors after the barn was stolen.", + "They descended on me like a hoar of locust.", + "They don't like to dictate themselves to the problem.", + "They don't see eye for eye with us.", + "They don't stand a teabag's chance in hell.", + "They fell all over their faces.", + "They just want to chew the bull.", + "They just want to shoot the fat.", + "They kicked the tar out of our ass.", + "They locked the door after the house was stolen.", + "They make strange bedfellows together.", + "They rolled their eyebrows at me.", + "They run across the gamut.", + "They run like flies when he comes near.", + "They sucked all the cream off the crop.", + "They sure dipsied his doodle.", + "They unspaded some real down to earth data.", + "They went after him tooth and fang.", + "They wrecked havoc in the kitchen.", + "They'll carve that spectrum any way we desire it.", + "They're a bunhc of pushers and shavers.", + "They're atrophying on the vine.", + "They're be chick peas in every pot.", + "They're colder than blue blazes.", + "They're coming farther between.", + "They're cooking on all cylinders.", + "They're dropping his course like flies.", + "They're dying off like fleas.", + "They're eating out of our laps.", + "They're germs in the rough.", + "They're grasping for needles.", + "They're spreading like wildflowers.", + "They're very far and few between.", + "They're working their bones off.", + "They's chomping their lips at the prospect.", + "They've beaten the bushes to death.", + "They've got the bull by the tail now.", + "They've reached a new level of lowness.", + "Things are all up in a heaval.", + "Things have slowed down to a terrible halt.", + "Things keep falling out of it, three or four years at a time.", + "This bit of casting oil on troubled feathers is more than I can take.", + "This business is being run by bean-pushers.", + "This field of research is so virginal that no human eye has set foot on it.", + "This ivory tower we're living in is a glass house.", + "This office requires a president who will work right up to the hilt.", + "This program has many weaknesses, but its strongest weakness remains to be seen.", + "This thing kills me to the bone.", + "This wine came from a really great brewery.", + "This work was the understatement of the year.", + "Those are good practices to avoid.", + "Those guys are as independent as hogs on ice.", + "Those guys weld a lot of power.", + "Those people have no bones to grind.", + "Those words were very carefully weasled.", + "Time and tide strike but once.", + "To all intensive purposes, the cause is lost.", + "To be a leader, you have to develop a spear de corps.", + "To coin a cliche, let's have at them.", + "To sweeten the pie, I'll add some cash.", + "To the cook goes the broth!", + "Today I was singing 'Snowflakes roasting on an open file'.", + "Together again for the first time.", + "Too many chiefs spoil the soup.", + "Too many drinks spoil the broth.", + "Too many hands spoil the soap.", + "Tread lightly on the face of the vois.", + "Trying to do anything is like a tour de force.", + "Trying to get a doctor on Wednesday is like trying to shoot a horse on Sunday.", + "Watch her \(em she gets on the stick very quickly.", + "We are on equally unfooted ground.", + "We are paying for the sins of serenity.", + "We brought this can of worms into the open.", + "We can clean ourselves right up to date.", + "We can throw a lot of muscle into the pot.", + "We can't get through the forest for the trees.", + "We didn't know which facts were incorrect.", + "We don't want to get enhangled in that either.", + "We got another thing out of it that I want to heave in.", + "We got on board at ground zero.", + "We got the story post hoc.", + "We have a difference of agreement.", + "We have a real ball of wax to unravel.", + "We have a real messy ball of wax.", + "We have a wide range of broad-gauge people.", + "We have achieved a wide specter of support.", + "We have the whole gambit to select from.", + "We haven't found a smoking baton.", + "We sure pulled the wool over his socks.", + "We sure pulled the wool over their socks.", + "We threw everything in the kitchen sink at them.", + "We won't turn a deaf shoulder to the problem.", + "We'd better jump under the bandwagon before the train leaves the station.", + "We'll see what comes down the tubes.", + "We're getting down to bare tacks.", + "We're treading on new water.", + "We're willing to throw away the baby with the bath water.", + "What can we do to shore up these problems?", + "When the tough get going they let sleeping does lie.", + "When they go downstairs, you can hear neither hide nor hair of them.", + "When you're jumping on sacred cows, you've got to watch your step.", + "You can make a prima donna sing, but you can't make her dance.", + "You get more for your mileage that way.", + "You gotta strike while the shoe is hot or the iron may be on the other foot.", + "You have sowed a festering cowpie of suspicion.", + "You put all your eggs before the horse.", + "You really can't compare us -- our similarities are different.", + "You take the chicken and run with me.", + "You're blowing it all out of context.", + "You're eating like wildfire.", + "You're skating on thin eggs.", + "You've always been the bone of human kindness.", + "Your ass is going to be mud.", + "Your wild oats have come home to roost." + ] + every write(|?farb) \ count + +end diff --git a/ipl/progs/farb2.icn b/ipl/progs/farb2.icn new file mode 100644 index 0000000..a68d6bc --- /dev/null +++ b/ipl/progs/farb2.icn @@ -0,0 +1,64 @@ +############################################################################ +# +# File: farb2.icn +# +# Subject: Program to generate Farberisms +# +# Author: Alan Beale +# +# Date: June 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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.'' +# +############################################################################ +# +# This program obtains its farberisms from the farber.sen file to +# allow additional farberisms to be added without recompilation or +# straining the limits of the Icon translator. It builds an index file +# farber.idx to allow for efficient access to the sentences file. The +# use of untranslated I/O for the index file is necessary for correct +# behavior on some systems (e.g., MVS). +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +procedure main(argv) + local f, ix, n + + f := open("farber.sen", "r") | stop("*** cannot open \"farber.sen\"") + if not (ix := open("farber.idx", "ru")) then { + ix := open("farber.idx", "bcu") + n := 0; + repeat { + writes(ix, left(where(f), 10)) + if not read(f) then break + n +:= 1 + } + seek(ix, -10) + writes(ix, left(n, 10)) + } + seek(ix, -10) + randomize() + seek(ix,10*(?numeric(reads(ix,10))-1)) + seek(f,numeric(reads(ix,10))) + write(read(f)) +end diff --git a/ipl/progs/filecnvt.icn b/ipl/progs/filecnvt.icn new file mode 100644 index 0000000..a2dc34d --- /dev/null +++ b/ipl/progs/filecnvt.icn @@ -0,0 +1,93 @@ +############################################################################ +# +# File: filecnvt.icn +# +# Subject: Program to convert line terminators +# +# Author: Beth Weiss +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program copies a text file, converting line terminators. It is +# called in the form +# +# filecnvt [-i s1] [-o s2] infile outfile +# +# The file name "-" is taken to be standard input or output, depending +# on its position, although standard input/output has limited usefulness, +# since it translates line terminators according the the system +# being used. +# +# The options are: +# +# -i s1 assume the input file has line termination for the +# system designated by s1. The default is "u". +# +# -o s2 write the output file with line terminators for the +# system designated by s2. The default is "u". +# +# The designations are: +# +# d MS-DOS ("\n\r"); also works for the Atari ST +# m Macintosh ("\r") +# u UNIX ("\n"); also works for the Amiga +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local T, input, output, input_eoln, output_eoln, last_part, line, result + + T := options(args, "i:o:") + + if args[1] == "-" then + input := &input + else + input := open(args[1], "ru") | stop("*** cannot open ", args[1], "***") + + if args[2] == "-" then + output := &output + else + output := open(args[2], "wu") | stop("*** cannot open ", args[2], "***") + + input_eoln := \eoln(T["i"]) | "\n" + output_eoln := \eoln(T["o"]) | "\n" + + last_part := "" + + while line := reads(input, 10000) do { # magic number + (last_part || line) ? { + while result := tab(find(input_eoln)) do { + writes(output, result, output_eoln) + move(*input_eoln) + } + # Saving the last part of each read and prepending it to the next + # ensures that eoln symbols that span reads aren't missed. + last_part := tab(0) + } + } + + writes(output, last_part) + + close(input) + close(output) +end + +procedure eoln(file_type) + case file_type of { + "u" : return "\n" + "d" : return "\r\n" + "m" : return "\r" + } +end diff --git a/ipl/progs/filehtml.icn b/ipl/progs/filehtml.icn new file mode 100644 index 0000000..ca97799 --- /dev/null +++ b/ipl/progs/filehtml.icn @@ -0,0 +1,34 @@ +############################################################################ +# +# File: filehtml.icn +# +# Subject: Program to create Web page with links to files +# +# Author: Ralph E. Griswold +# +# Date: September 17, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The files to be includes are listed on the command line. There is no +# check that the files actually exist. +# +############################################################################ + +procedure main(args) + local file + + write("<HTML><HEAD>") + write("<TITLE>File Links</TITLE></HEAD>") + write("<BODY>") + + every file := !args do + write("<A HREF=\"", file, "\">", file, "</A><BR>") + + write("</BODY></HTML>") + +end diff --git a/ipl/progs/fileprep.icn b/ipl/progs/fileprep.icn new file mode 100644 index 0000000..7e4f835 --- /dev/null +++ b/ipl/progs/fileprep.icn @@ -0,0 +1,59 @@ +############################################################################ +# +# File: fileprep.icn +# +# Subject: Program to prepare file information for IPL indexes +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program creates files used in the construction of indexes for the +# Icon program library. +# +############################################################################ + +procedure main() + local files, file, input, line + + files := open("ls [a-z]*.icn", "p") + + while file := read(files) do { + if *file > 13 then write(&errout,"*** file name too long: ", file) + input := open(file) + every 1 to 4 do read(input) # skip to subject line + line := read(input) | { + write(&errout, "*** no subject in ", file) + next + } + line ? { + if tab(find("Subject: Program ") + 18) | + tab(find("Subject: Procedures") + 21) | + tab(find("Subject: Procedure ") + 20) | + tab(find("Subject: Procedure ") + 20) | + tab(find("Subject: Definitions ") + 22) | + tab(find("Subject: Declarations ") + 23) | + tab(find("Subject: Declaration ") + 22) | + tab(find("Subject: Link declarations ") + 28) | + tab(find("Subject: Link declaration ") + 27) | + tab(find("Subject: Record declarations ") + 30) | + tab(find("Subject: Record declaration ") + 29) then + { + =("for " | "to ") # optional in some cases + write(file ? tab(find(".icn")), ": ", tab(0)) + } + else { + write(&errout, "*** bad subject line in ", file) + write(&errout, line) + } + } + close(input) + } + +end diff --git a/ipl/progs/fileprnt.icn b/ipl/progs/fileprnt.icn new file mode 100644 index 0000000..af70da2 --- /dev/null +++ b/ipl/progs/fileprnt.icn @@ -0,0 +1,105 @@ +############################################################################ +# +# File: fileprnt.icn +# +# Subject: Program to display characters in file +# +# Author: Ralph E. Griswold +# +# Date: November 21, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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. +# +# Input 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 diff --git a/ipl/progs/filerepl.icn b/ipl/progs/filerepl.icn new file mode 100644 index 0000000..46483bf --- /dev/null +++ b/ipl/progs/filerepl.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: filerepl.icn +# +# Subject: Program to replicate file +# +# Author: Ralph E. Griswold +# +# Date: January 2, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes standard input to standard a specified number of +# times. Number of replications is given on command line. +# +# NOTE: Since the input stream is stored internally, standard input +# must be of finite length. +# +############################################################################ + +procedure main(args) + local file + + file := [] + + while put(file, read()) + + every 1 to args[1] do + every write(!file) + +end diff --git a/ipl/progs/filesect.icn b/ipl/progs/filesect.icn new file mode 100644 index 0000000..fd01f54 --- /dev/null +++ b/ipl/progs/filesect.icn @@ -0,0 +1,51 @@ +############################################################################ +# +# File: filesect.icn +# +# Subject: Program to produce section of a file +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes the section of the input file starting at a +# specified line number and extending a specified number of lines. +# +# The specifications are given as integer command-line arguments; the +# first is the starting line, the second is the number of lines. For +# example, +# +# filesect 20 100 <input >output +# +# copies 100 lines from input to output, starting at line 20 of input. +# +# If the specifications are out of range, the file written is truncated +# without comment. +# +# +############################################################################ + +procedure main(argl) + local start, count + + start := argl[1] | stop("*** starting value missing") + count := argl[2] | stop("*** count missing") + + if not (start := integer(start) & start > 0) then + stop("starting value not positive integer") + if not (count := integer(count) & count >= 0) then + stop("starting value not non-negative integer") + + every 1 to start - 1 do + read() | exit() + + every 1 to count do + write(read()) | exit() + +end diff --git a/ipl/progs/filexref.icn b/ipl/progs/filexref.icn new file mode 100644 index 0000000..12f8c4e --- /dev/null +++ b/ipl/progs/filexref.icn @@ -0,0 +1,190 @@ +############################################################################# +# +# File: filexref.icn +# +# Subject: Program to cross-reference files by components +# +# Author: David Gamey +# +# Date: July 7, 1994 +# +############################################################################# +# +# This file is in the public domain. +# +############################################################################ +# +# History: +# +# 11Jul94 - D.Gamey - Reorganized to eliminate empty columns +# 13Jul94 - D.Gamey - Added dateline & total number of files +# 29Jul94 - D.Gamey - Page numbers in headers +# 6Jan95 - D.Gamey - Allow DOS wild cards to select within directories +# +############################################################################ +# +# Usage: +# +# dir dir1 /b /a:d > dirlist +# filexref < dirlist +# +# Note: +# +# Dir does not preface its results with the parent directory +# - take care! +# +# Options: +# +# -D Produce an ascii delimited file +# -h Exclude hidden files +# -n Page Length ... must be integer >= 25 +# +############################################################################# +# +# Requires: MS-DOS compatible operating system +# +############################################################################ +# +# Links: io, options +# +############################################################################ + +link io +link options + +procedure main(arglist) + +local opt, diropts, dir, paths , fn, ext +local tempfn, tempf, file, line +local b10, tens, header, _pl, _ppage, _fnw +local _asciid, _exchidden +local _star, _dot, _sepr, _q +local pagenum, linenum +local N, E, D, DET, t + +opt := options(arglist,"D!h!n+") # parse command line options + +_asciid := opt["D"] # ascii delimited +_exchidden := opt["-h"] # exclude hidden files +_pl := ( 25 <= integer(\opt["n"])) | 55 # page length +_fnw := 10 # width for file name field +_ppage := [73,4] # position & width of page number + + +if \_asciid then +{ + _star := ",\"@\"" + _dot := ",\" \"" + _sepr := "," + _q := "\"" +} +else +{ + _star := "@" + _dot := "." + _sepr := " " + _q := "" +} + +if \_exchidden then + diropts := " /b /a:-d-h >> " +else + diropts := " /b /a:-d >> " + +N := set() # file names +E := set() # file extensions +D := set() # directory list +DET := table() # directory - extension table + +if not close(open(tempfn := tempname(),"w")) then + stop(&errout,"Unable to create temporary file, e.g. ",tempfn) + +diropts ||:= tempfn + +while dir := read() do +{ + dir := trim( dir ? tab(upto('#')) ) # strip icon style comments + if *dir > 0 then + system( "dir " || dir || diropts ) +} + +if not ( tempf := open(tempfn,"r") ) then + stop(&errout,"Unable to open(read) temporary file ",tempfn) + +while line := map(trim(read(tempf))) do +{ + file := DOS_FileParts(line) + /DET[file.devpath] := table() + /DET[file.devpath][file.extension] := set() + insert( DET[file.devpath][file.extension], file.name ) + insert( D, file.devpath ) + insert( E, file.extension ) + insert( N, file.name ) +} + +close(tempf) +D := sort( D ) +E := sort( E ) +N := sort( N ) + +write( _q, "File Inventory Cross-Reference Report -- ", + &dateline, _q, "\r\n" ) +write( _q, "Directories Searched (cross-reference number and path):", _q ) + +paths := 0 +every dir := !D & ext := !E do + if \DET[dir][ext] then + write( right(paths +:= 1, 4), _sepr, _q, dir, " [", ext, "]", _q ) + +if \_asciid then +{ + write( "\r\n", _q, "Files by Directory:", _q ) + write() + writes( _q,_q,_sepr, _q,_q ) + every writes( _sepr, 1 to paths ) + write() +} +else +{ + header := [] + tens := "" + b10 := repl(" ",10) + every tens ||:= (b10 || (1 to (paths / 10)))[-10:0] + put( header, "Files by Directory:" ) + header[1] ||:= right("Page ",_ppage[1] - *header[1]) || repl("X",_ppage[2]) + put( header, left("",_fnw + *_sepr) || tens ) + put( header, + left("",_fnw + *_sepr) || + repl( "1234567890", (paths / 10) + 1)[1:paths+1] ) + put( header, + left("",_fnw + *_sepr) || + repl( "----+----|", (paths / 10) + 1)[1:paths+1] ) +} + +linenum := pagenum := 0 +every fn := !N do +{ + if \header & ( ( ( linenum +:= 1 ) % _pl ) = 1 ) then + { + pagenum +:= 1 + writes( "\f" ) + header[1][-_ppage[2]:0] := right(pagenum,_ppage[2]) + every write( !header ) do linenum +:= 1 + } + writes( _q,_q,_sepr, _q,left( fn, _fnw),_q ) + every ( dir := !D ) & ( ext := !E ) do + { + if ( t := \DET[dir][ext] ) then + if member( t, fn ) then + writes( _star ) + else + writes( _dot ) + } + write() +} + +write() +write( _q, "Total files in inventory is ", _q, _sepr, *N ) + +exit(0) +end diff --git a/ipl/progs/filtskel.icn b/ipl/progs/filtskel.icn new file mode 100644 index 0000000..4b99763 --- /dev/null +++ b/ipl/progs/filtskel.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: filtskel.icn +# +# Subject: Program skeleton for generic filter +# +# Author: Robert J. Alexander +# +# Date: July 16, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/findstr.icn b/ipl/progs/findstr.icn new file mode 100644 index 0000000..aa09d5e --- /dev/null +++ b/ipl/progs/findstr.icn @@ -0,0 +1,78 @@ +############################################################################ +# +# File: findstr.icn +# +# Subject: Program to find embedded character strings +# +# Author: Robert J. Alexander +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Utility filter to list character strings embedded in data files (e.g. +# object files). +# +# findstr -options file... +# +# -l length minimum string size to be printed (default 3) +# -c chars a string of characters (besides the standard ASCII +# printable characters) to be considered part of a +# string +# +# Icon string escape sequences can be used to specify the -c option. +# +# Multiple files can be specified as arguments, and will be processed +# in sequence. +# + +link options,escape + +procedure main(arg) + local c, f, fn, header, min_string_size, okchars, opt, s, istring + # + # Process command line options and file names. + # + opt := options(arg,"l+c:") + if *arg = 0 then stop("Usage: findstr -options file..._ + \n_ + \n-l length\tminimum string size to be printed (default 3)_ + \n-c chars\ta string of characters (besides the standard ASCII_ + \n\t\tprintable characters) to be considered part of a string_ + \n") + # + # Define minimum string size to print. + # + min_string_size := \opt["l"] | 3 # default min string size = 3 + # + # Define characters that can be in strings. + # + okchars := cset(&ascii[33:-1]) # normal ASCII printable characters + okchars ++:= istring(\opt["c"]) # additional chars supplied by user + # + # Loop to process files. + # + every fn := !arg do { + f := open(fn,"u") | stop("Can't open input file \"",fn,"\"") + # + # Now find and print the strings. + # + header := if *arg > 1 then fn || ": " else "" + s := "" + while c := reads(f) do { + if any(okchars,c) then s ||:= c + else { + if *s >= min_string_size then write(header,image(s)) + s := "" + } + } + # + # Close this file. + # + close(f) + } +end diff --git a/ipl/progs/findtext.icn b/ipl/progs/findtext.icn new file mode 100644 index 0000000..2cea8a7 --- /dev/null +++ b/ipl/progs/findtext.icn @@ -0,0 +1,85 @@ +############################################################################ +# +# File: findtext.icn +# +# Subject: Program to retrieve data from files indexed by idxtext +# +# Author: Phillip Lee Thomas +# +# Date: November 21, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# History: Tested with DOS, DOS-386, OS/2, ProIcon, UNIX +# +############################################################################ +# +# Version: 1.2 (August 5, 1995) +# +############################################################################ +# +# See documentation with idxtext.icn, gettext.icn, adjuncts.icn +# +# History: +# (1.1) Tested with DOS, DOS-386, OS/2, ProIcon, UNIX +# (1.2) Use preprocessor include statement instead of link. +# +############################################################################ +# +# Links: gettext +# +# Program findtext retrieves multiline text from database indexed by +# idxtext. Each stretch of text follows a line declaring the index +# terms: +# +# ::be ::to ::by ::retrieved +# Text to be retrieved +# by findtext. +# ::index ::line +# Each index line begins with "::". +# +############################################################################ + +link gettext + +procedure main(args) + + local count, file, out_line, s + + Set_OS() + + s := \args[1] | "" + file := \args[2] | "" + + if *args ~= 2 then { + while *s = 0 do { # force entry of search string + writes("Search string: ") + s := read() + } + + while *file = 0 do { # force entry of datafile name + writes("Search file: ") + file := read() + } + } + + # Find text associated with index s in file 'file'. + + count := 0 + every out_line := gettext(s, file) do { + count +:= 1 + write(count, ": ", out_line) + } + + if count = 0 then { + write("String '", s, "' not found in indexed file '", file, "'") + write("Format: [iconx] findtext string filename") + exit(1) + } + + exit(0) +end diff --git a/ipl/progs/fixhqx.icn b/ipl/progs/fixhqx.icn new file mode 100644 index 0000000..244416e --- /dev/null +++ b/ipl/progs/fixhqx.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: fixhqx.icn +# +# Subject: Program to strip headers from BinHex files +# +# Author: Ralph E. Griswold +# +# Date: February 20, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Sometimes Macintosh .hqx files come with commentary before the +# BinHex data. This program strips off the heading material so that +# BinHex can be used. +# +# Input comes from standard input and output goes to standard output. +# +############################################################################ + +procedure main() + local line + + while line := read() do + line ? { + if ="(This file must be converted with BinHex 4.0)" then { + write(line) + break + } + else write(&errout, line) + } + + while write(read()) + +end diff --git a/ipl/progs/fixpath.icn b/ipl/progs/fixpath.icn new file mode 100644 index 0000000..514fdc6 --- /dev/null +++ b/ipl/progs/fixpath.icn @@ -0,0 +1,62 @@ +############################################################################ +# +# File: fixpath.icn +# +# Subject: Program to replace path in a binary file +# +# Author: Gregg M. Townsend +# +# Date: November 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: fixpath filename oldpath newpath +# +# Fixpath changes file paths or other strings in a binary file by modifying +# the file in place. Each null-terminated occurrence of "oldpath" is +# replaced by "newpath". +# +# If the new path is longer than the old one, a warning is given and the +# old path is extended by null characters, which must be matched in the +# file for replacement to take place. This is dangerous in general but +# allows repairing an errant fixpath command. +# +############################################################################ + + +procedure main(args) + local fname, oldpath, newpath, f, pgm, n, p, s + + (*args == 3) | stop("usage: fixpath filename oldpath newpath") + fname := args[1] + oldpath := args[2] + newpath := args[3] + if *newpath > *oldpath then { + write(&errout, "warning: newpath is longer than oldpath") + oldpath := left(oldpath, *newpath, "\0") + } + oldpath ||:= "\0" + newpath := left(newpath, *oldpath, "\0") + + (f := open(fname, "rwu")) | stop(fname, ": can't open") + pgm := "" + while pgm ||:= reads(f, 8192) + (*pgm > 0) | stop(fname, ": empty file") + n := 0 + pgm ? { + while tab(p := find(oldpath)) do { + seek(f, p) | stop(fname, ": can't seek") + writes(f, s, newpath) | stop(fname, ": can't write") + move(*newpath) + n +:= 1 + } + (n > 0) | stop(fname, ": can't find string `", args[2], "'") + } + write("replaced ", n, " occurrence", if n>1 then "s" else "") + +end + diff --git a/ipl/progs/fnctab.icn b/ipl/progs/fnctab.icn new file mode 100644 index 0000000..669e379 --- /dev/null +++ b/ipl/progs/fnctab.icn @@ -0,0 +1,67 @@ +############################################################################ +# +# File: fnctab.icn +# +# Subject: Program to list function usage +# +# Author: Ralph E. Griswold +# +# Date: June 18, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program processes an MVT token file and tabulates the usage +# of functions. +# +# Since function usage cannot be determined completely from static +# analysis, the results should be viewed with this limitation in mind. +# +############################################################################ + +procedure main() + local fncset, fnctab, line, count, name, total + + fncset := set() # set for the names of all functions + fnctab := table(0) # table to tabulate function count + + total := 0 + + every insert(fncset, function()) + delete(fncset, "args") # ad hoc -- usual not used as functions + delete(fncset, "name") + + while line := read() | stop("*** didn't find variable references") do { + line ? { + if ="Variable references:" then break + } + } + + + while line := trim(read()) do { + line ? { + if tab(upto(&digits)) then { + count := tab(many(&digits)) + tab(upto(&letters)) + name := tab(0) + if name == "" then break + if member(fncset, name) then { + fnctab[name] +:= count + total +:= count + } + } + } + } + + fnctab := sort(fnctab, 4) + + while count := pull(fnctab) do + write(left(pull(fnctab), 14), right(count, 8)) + + write() + write("total ", right(total, 8)) + +end diff --git a/ipl/progs/fnctmpl.icn b/ipl/progs/fnctmpl.icn new file mode 100644 index 0000000..c7dd2e0 --- /dev/null +++ b/ipl/progs/fnctmpl.icn @@ -0,0 +1,70 @@ +############################################################################ +# +# File: fnctmpl.icn +# +# Subject: Program to produce function templates +# +# Author: Ralph E. Griswold +# +# Date: February 27, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program processes the rt.db database for the Icon compiler produced +# by rtt and produces procedures for each Icon function to be used by +# iftrace.icn. +# +# The data base is expected from standard input. +# +############################################################################ + +procedure main() + local line, header, proto, rettype, name, varargs + + while line := read() do + line ? { + if pos(0) then { + header := read() | stop("eof") + proto := read() | stop("eof") + header ? { + if ="$endsect" then exit() + tab(upto('{')) + tab(upto(',') + 1) + if =("*" | "1+") then rettype := "suspend" + else rettype := "return" + } + proto ? { + ="\"" | next + name := tab(bal(' ')) | stop("bad proto") + name := trim(name,',') + name ?:= { + map(move(1),&lcase,&ucase) || tab(0) + } + name ?:= { + if find("...") then { + varargs := 1 + tab(upto('(') + 1) || "x[])" + } + else { + varargs := &null + tab(0) + } + } + } + write("procedure ",name) + if /varargs then write(" ",rettype," ",name) + else { + name ?:= { + tab(upto('(')) + } + write(" ",rettype," ",name," ! x") + } + write("end\n") + } + else if ="$endsect" then exit() + } +end diff --git a/ipl/progs/format.icn b/ipl/progs/format.icn new file mode 100644 index 0000000..fc0528d --- /dev/null +++ b/ipl/progs/format.icn @@ -0,0 +1,162 @@ +############################################################################ +# +# File: format.icn +# +# Subject: Program to word wrap a range of text +# +# Author: Robert J. Alexander +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 attempts 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 + +procedure main(arg) + local usage, opts, tabs, comment, format, just1, space, nspace, wchar, Entab + local line, pre, empty, outline, spaces, word, len, width, xspace, Detab + local outpre + # + # Process the options. + # + usage := + "usage: format [-options]\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, too\n_ + \t-c\tattempt to format program comments\n_ + \t-n\tdon't put extra spaces after sentences\n_ + \t-h\tprint help message" + opts := options(arg,"ht+w+cjJn") + if \opts["h"] then stop(usage) + width := integer(\opts["w"]) | 72 + tabs := (integer(\opts["t"]) | 8) + 1 + if tabs >= 2 then { + Detab := detab + Entab := entab + } + else Entab := Detab := 1 + comment := opts["c"] + format := if \just1 | \opts["j"] then justify else 1 + just1 := opts["J"] + xspace := if \opts["s"] then '' else '.?:!' + # + # 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 := Detab(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) + outpre := Entab(pre,tabs) + 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(outpre,"" ~== 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(outpre,"" ~== format(outline,width)) + outline := spaces := "" + } + outline ||:= spaces || word + spaces := if any(xspace,word[-1]) then " " else " " + } + } + } + } + line := Detab(read(),tabs) | break + } + write(outpre,"" ~== (if \just1 then justify else 1)(outline,width)) +end + + +# +# justify(s,width) -- Inserts extra spaces between words of "s" so that +# "s" will be exactly "width" characters long. "s" is trimmed of +# spaces on the right and left ends. If "s" contains fewer than two +# words, or if the trimmed version is longer than "width", the trimmed +# version of "s" is returned unchanged. Where some gaps between words +# are required to be wider than others, the extra spaces are +# distributed randomly to minimize "rivering" in justified paragraphs. +# +procedure justify(s,width) + local wlist,wset,t,r + static space,nspace + initial { + space := ' ' + nspace := &cset -- space + } + s := trim(s[many(space,s) | 1:0]) + wlist := [] + s ? while put(wlist,[tab(many(nspace)),*tab(many(space)) | 0]) + if *s >= width | *wlist < 2 then return s + wset := set(wlist[1:-1]) + t := (width - *s) / *wset + every (!wset)[2] +:= t + every 1 to (width - *s) % *wset do { + (t := ?wset)[2] +:= 1 + delete(wset,t) + } + r := "" + every t := !wlist do r ||:= t[1] || repl(" ",t[2]) + return r +end diff --git a/ipl/progs/former.icn b/ipl/progs/former.icn new file mode 100644 index 0000000..df8c372 --- /dev/null +++ b/ipl/progs/former.icn @@ -0,0 +1,33 @@ +############################################################################ +# +# File: former.icn +# +# Subject: Program to format long string in fixed-length lines +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program takes a single line of input and outputs in in lines +# no greater than the number given on the command line (default 80). +# +############################################################################ + +procedure main(args) + local limit, line + + limit := integer(args[1]) | 80 + + line := read() | stop("*** no input line") + + line ? { + while write(move(limit)) + if not pos(0) then write(tab(0)) + } +end diff --git a/ipl/progs/fract.icn b/ipl/progs/fract.icn new file mode 100644 index 0000000..856f200 --- /dev/null +++ b/ipl/progs/fract.icn @@ -0,0 +1,80 @@ +############################################################################ +# +# File: fract.icn +# +# Subject: Program to approximate real number as a fraction +# +# Author: Ralph E. Griswold +# +# Date: October 26, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces successive rational approximations to a real +# number. +# +# The options supported are: +# +# -n r real number to be approximated, default .6180339887498948482 +# (see below) +# +# -l i limit on number of approximations, default 100 (unlikely to +# be reached). +# +############################################################################ +# +# This program was translated from a C program by Gregg Townsend. His +# documentation includes the following remarks. +# +# rational mode based on a calculator algorithm posted by: +# +# Joseph D. Rudmin (duke!dukempd!jdr) +# Duke University Physics Dept. +# Aug 19, 1987 +# +# n.b. for an interesting sequence try "fract .6180339887498948482". +# Do you know why? (Hint: "Leonardo of Pisa"). +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +$define Epsilon 1.e-16 # maximum precision (more risks overflow) + +procedure main(args) + local v, t, x, y, a, d, i, j, ops, opts, limit + + opts := options(args, "n.l+") + + v := \opts["n"] | .6180339887498948482 + limit := \opts["l"] | 100 + + x := list(limit + 2) + y := list(limit + 2) + + t := v + + every i := 1 to limit do { + x[i + 1] := integer(t) + y[i + 1] := 1 + y[i + 2] := 0 + every j := i - 1 to 0 by -1 do + y[j + 1] := x[j + 2] * y[j + 2] + y[j + 3] + a := real(integer(y[1])) / integer(y[2]) + if a < 0 then exit() + write(integer(y[1]), " / ", integer(y[2]), " \t", a) + if abs(a - v) < Epsilon then exit() + d := t - integer(t) + if d < Epsilon then exit() + t := 1.0 / d + } + +end diff --git a/ipl/progs/fset.icn b/ipl/progs/fset.icn new file mode 100644 index 0000000..8f0f37e --- /dev/null +++ b/ipl/progs/fset.icn @@ -0,0 +1,213 @@ +############################################################################ +# +# File: fset.icn +# +# Subject: Program to do set operations on file specifications +# +# Author: Thomas R. Hicks +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The UNIX shell provides for the specification of filenames +# using ``wildcards''. Each wildcard specification may be +# thought of as defining a set of names (that is, those that +# match the specification). Fset allows the user to apply the +# set operations of intersection, union, and difference to +# these filename sets. The resultant list may then be used as +# an argument to other shell commands. +# +# Fset's argument is an expression composed of legal UNIX file +# specifications, parenthesis, and the following set opera- +# tors: +# +# && intersection +# ++ union +# -- difference +# +# Because characters that have special meaning to the shell +# occur frequently in the arguments used for fset, it is +# advisable to quote the arguments consistently. +# +# The use of fset is illustrated by the following examples: +# +# fset 'g*--*.icn' +# +# produces the list (set) of filenames for files beginning +# with g, excluding those ending with .icn. +# +# Similarly, +# +# fset '*' +# +# produces all files in the current directory excluding the . +# and .. files. +# +# fset '((*--*.icn)++c*)' +# and +# +# fset '(*--*.icn)++c*' +# +# produces the complement of all filenames ending with .icn in +# addition to all filenames beginning with c. +# +# fset '(((c? && c*)))' +# +# is a redundant, but legal, specification for all two- +# character filenames that begin with c, while +# +# fset '.*' +# +# produces the set of filenames for all hidden files, exclud- +# ing the . and .. files. +# +# Limitations: +# +# Multiple command line arguments, formed by omitting the +# quotes around the file set expression, are permitted. Their +# use is limited, however, since parentheses do not get past +# the shell's command-line expansion. +# +# Almost any legal file specification will work when enclosed +# in quotes except that the simple grammar that is used cannot +# handle blanks adjacent to parentheses. +# +# File names that begin or end in ``questionable'' characters +# such as *, ?, +, -, and &, probably will not work. +# +# A file specification that, when interpreted by the shell, +# produces no matching filename will be placed (unchanged) in +# the result. +# +############################################################################ +# +# See also: gcomp.icn +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main(args) + local i, fyls, arglist + if *args = 0 then return + if *args > 1 then + every i := 2 to *args do + args[1] ||:= (" " || args[i]) + (arglist := parse(args[1])) | + stop("Invalid file specification expression") + case type(arglist) of { + "string" : fyls := mkfset(arglist) + "list" : fyls := exec(arglist) + default : stop("Main: bad type -can't happen") + } + fyls := sort(fyls) + every write(!fyls," ") +end + +procedure Exp() # file spec expression parser + local a + suspend (a := [Factor(),=Op(),Factor()] & [a[2],a[1],a[3]]) | + Factor() | + (a := [="(",Exp(),=")"] & .a[2]) +end + +procedure Factor() # file spec expression parser + local a + suspend (a := [Term(),=Op(),Term()] & [a[2],a[1],a[3]]) | + Term() | + (a := [="(",Factor(),=")"] & .a[2]) +end + +procedure Name() # file spec name matcher + static valid + initial valid := ~'()' + suspend (any(~valid) || fail) | tab(find(Op()) | many(valid)) +end + +procedure Non() # file spec expression parser + local a + suspend a := [Name(),=Op(),Name()] & [a[2],a[1],a[3]] +end + +procedure Op() # file spec operation matcher + suspend !["++","--","&&"] +end + +procedure Term() # file spec expression parser + local a + suspend (a := [="(",Non(),=")"] & .a[2]) | + Name() +end + +procedure bldfset(arg) # build file set, excluding . and .. + local line + static dotfiles + initial dotfiles := set([".",".."]) + line := read(open("echo " || arg,"rp")) + return str2set(line,' ') -- dotfiles +end + +procedure exec(lst) # process file spec list recursively + return setops(lst[1])(exec2(lst[2]),exec2(lst[3])) +end + +procedure exec2(arg) # helping procedure for exec + case type(arg) of { + "string" : return mkfset(arg) + "list" : return exec(arg) + default : stop("exec2: can't happen") + } +end + +procedure mkfset(fspec) # make file list from specification + if fspec == "*" then + fspec := "* .*" + return bldfset(fspec) +end + +procedure parse(str) # top level of parsing procedures + local res + str ? (res := Exp() & pos(0)) | fail + return res +end + +procedure sdiff(f1,f2) # set difference + return f1 -- f2 +end + +procedure setops(op) # return correct set operaton + case op of { + "++" : return sunion + "&&" : return sinter + "--" : return sdiff + } +end + +procedure sinter(f1,f2) # set intersection + return f1 ** f2 +end + +procedure str2set(str,delim) # convert delimited string into a set + local fset, f + fset := set() + str ? { + while f := (tab(upto(delim))) do { + insert(fset,f) + move(1) + } + if "" ~== (f := tab(0)) then + insert(fset,f) + } + return fset +end + +procedure sunion(f1,f2) # set union + return f1 ++ f2 +end diff --git a/ipl/progs/fuzz.icn b/ipl/progs/fuzz.icn new file mode 100644 index 0000000..de81814 --- /dev/null +++ b/ipl/progs/fuzz.icn @@ -0,0 +1,179 @@ +############################################################################ +# +# File: fuzz.icn +# +# Subject: Program to perform fuzzy pattern matching +# +# Author: Alex Cecil +# +# Date: November 10, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program illustrates "fuzzy" string pattern matching. The result +# of matching s and t is a number between 0 and 1 which is based on +# counting matching pairs of characters in increasingly long substrings +# of s and t. Characters may be weighted differently, and the reverse +# tally may be given a negative bias. +# +############################################################################ + + +global bias, rank_list_max, weight1, weight2, weight_set, which_fuzz_value + +procedure main() + local alphanum, in_id, in_name, in_record, rank_list, + start_time, word_requested + + bias := -2 # Reduce importance of reverse match + rank_list_max := 15 # Number of best matches to write + weight1 := 6 # Weight of chars not in weight_set + weight2 := 2 # Weight of chars in weight_set + weight_set := 'aehiouwy' # Soundex ignore list + + write("The ",rank_list_max, + " best matches for the first word in each line will be written.") + writes("\nName of input file: "); in_name := read() + in_id := (open(in_name,"r")) | (stop("Can't open file ",in_name)) + + writes("\nWord to search for: ") + word_requested := map(read()) + + writes("\nWhich function: Simple, Optimized, Weighted (1,2,3): ") + which_fuzz_value := case read() of { + "1" : fuzz_value_1 # Simple, "obvious" implementation + "2" : fuzz_value_2 # Simple, linearized for speed + default : fuzz_value_3 # Weights and bias included + } + + write("\nSearching for \"",word_requested,"\" in file ",in_name) + start_time := &time + alphanum := &letters ++ &digits + rank_list := [] # [[fuzz-value,in-record],...] + while in_record := read(in_id) do { + in_record ? { + tab(upto(alphanum)) + rank(word_requested,map(tab(many(alphanum))),in_record, + rank_list,rank_list_max) + } + } + write("\nFuzz Value of first word\n | Input Record...") + every rank := !rank_list do { + write(left(string(rank[1]),5)," ",left(rank[2],72)) + } + write("\nElapsed time in milliseconds: ",&time - start_time) +end + +procedure rank(s,t,r,rl,rm) +# Maintain a sorted list (rl) of the rm best Fuzz values with records (r). +# Special cases to save time: strings are the same; or s and t have fewer +# than about 50% characters in common. + local i, v + if s == t then v := 1.0 + else if *(s ** t) * 4 <= (*s + *t) then v := 0.0 + else v := which_fuzz_value(s,t,weight1,weight2,weight_set,bias) + # 3rd-last args needed by fuzz_value_3 + if *rl = 0 then put(rl,[v,r]) # First entry in list + else if v >= rl[*rl][1] then { # If value greater than least in list... + put(rl,[v,r]) # add to list, sort, and trim + every i := *rl to 2 by -1 do { + if rl[i][1] > rl[i-1][1] then rl[i] :=: rl[i-1] + } + if *rl > rm then pull(rl) + } +end + +procedure fuzz_value_1(s,t) +# Calculate Fuzz Value of s and t with weight=1 and bias=0 +# Simple, non-optomized algorithm. + if *s > *t then s :=: t + return 2.0 * (fuzz_match_1(s,t) + fuzz_match_1(reverse(s),reverse(t)))/ + ((*s * (*s+1)) + (*t * (*t+1))) +end + +procedure fuzz_match_1(s,ti) +# Calculate the Fuzz Matches between s and t. Simple algorithm. +# ASCII NUL is used to mark matched pairs, so can't be used in strings + local i, imax, jmax, m, t, tsdif + tsdif := *ti - *s + m := 0 + every imax := 1 to *s do { + t := ti + jmax := imax + tsdif + 1 + every i := 1 to imax do + if t[find(s[i],t,1,jmax)] := "\0" then m +:= 1 + } + return m +end + +procedure fuzz_value_2(s,t) +# Calculate Fuzz Value with weight=1 and bias=0 +# Optomized version. + if *s > *t then s :=: t + return 2.0 * (fuzz_match_2(s,t) + fuzz_match_2(reverse(s),reverse(t)))/ + ((*s * (*s+1)) + (*t * (*t+1))) +end + +procedure fuzz_match_2(s,t) +# Calculate the Fuzz Matches between s and t. +# Replace column loop by imperical calculation. +# ASCII NUL is used to mark matched pairs, so can't be used in s or t. +# s(ip) is ith char from right, similarly for t(jp) + local ip, j, jmp, jp, m, si + ip := *s + jmp := *t + 1 + m := 0 + every si := !s do { + if t[j := find(si,t)] := "\0" then { + jp := jmp - j + m +:= (ip <= jp | ip) - abs(ip - jp) # max column minus column offset + } + ip -:= 1 + } + return m +end + +procedure fuzz_value_3(s,t,w1,w2,w2c,b,c) +# Calculate Fuzz Value with weight w2 if in cset w2c, else weight w1; bias b. + if *s > *t then s :=: t + return 2.0 * (fuzz_match_3(s,t,w1,w2,w2c) + + fuzz_match_3(reverse(s),reverse(t),w1+b,w2+b,w2c)) / + (fuzz_self_3(s,w1+w1+b,w2+w2+b,w2c) + fuzz_self_3(t,w1+w1+b,w2+w2+b,w2c)) +end + +procedure fuzz_match_3(s,t,w1,w2,w2c) +# Calculate the Fuzz Matches between s and t. +# Replace column loop by imperical calculation. +# ASCII NUL is used to mark matched pairs, so can't be used in s or t. +# s(ip) is ith char from right, similarly for t(jp) + local ip, j, jmp, jp, m, mo, si + ip := *s + jmp := *t + 1 + m := 0 + every si := !s do { + if t[j := find(si,t)] := "\0" then { + jp := jmp - j + mo := (ip <= jp | ip) - abs(ip - jp) # max column minus column offset + m +:= (any(w2c,si) & (w2 * mo)) | (w1 * mo) + } + ip -:= 1 + } + return m +end + +procedure fuzz_self_3(s,w1fr,w2fr,w2c) +# fuzz matches of s with s +# w1fr, w2fr: forward plus reverse weights. + local ip, m, si + ip := *s + m := 0 + every si := !s do { + m +:= (any(w2c,si) & (w2fr * ip)) | (w1fr * ip) + ip -:= 1 + } + return m +end diff --git a/ipl/progs/gcomp.icn b/ipl/progs/gcomp.icn new file mode 100644 index 0000000..77ea9bc --- /dev/null +++ b/ipl/progs/gcomp.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: gcomp.icn +# +# Subject: Program to produce complement of file specification +# +# Author: William H. Mitchell, modified by Ralph E. Griswold +# +# Date: December 27, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +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 diff --git a/ipl/progs/geddump.icn b/ipl/progs/geddump.icn new file mode 100644 index 0000000..744d54b --- /dev/null +++ b/ipl/progs/geddump.icn @@ -0,0 +1,123 @@ +############################################################################ +# +# File: geddump.icn +# +# Subject: Program to dump contents of GEDCOM file +# +# Author: Gregg M. Townsend +# +# Date: July 3, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# usage: geddump [file] +# +# This program prints the genealogical information contained +# in a GEDCOM file. Individuals are printed alphabetically, +# with sequence numbers to assist cross-referencing. +# +# Marriages are noted for both partners. Children are listed +# under the father, or under the mother if no father is known. +# +############################################################################ +# +# Links: gedcom +# +############################################################################ + +link gedcom + +record person(n, k, r) # number, sort key, gedrec node + + +global ptab # person number table, indexed by gedrec node + + +procedure main(args) + local f, g, i, n, p, r, plist, fam, husb, sp, b, d, byr, dyr + + if *args > 0 then + f := open(args[1]) | stop("can't open ", args[1]) + else + f := &input + + g := gedload(f) + close(f) + + plist := [] + ptab := table() + every r := !g.ind do + put(plist, ptab[r] := person(0, sortkey(r), r)) + + plist := sortf(plist, 2) + + n := 0 + every (!plist).n := (n +:= 1) + + every p := !plist do { + b := gedsub(p.r, "BIRT") | &null + d := gedsub(p.r, "DEAT") | &null + + write() + writes("[", p.n, "] ", gedlnf(p.r)) + byr := gedyear(\b) | &null + dyr := gedyear(\d) | &null + if \byr | \dyr then + writes(" (", byr, " - ", dyr, ")") + write() + + if fam := gedref(p.r, "FAMC") then { + refto("father", gedref(fam, "HUSB")) + refto("mother", gedref(fam, "WIFE")) + } + + event("b.", \b) + + r := &null + every fam := gedref(p.r, "FAMS") do { # for every family + r := event("m.", gedsub(fam, "MARR")) + r := refto(" husb", p.r ~=== gedref(fam, "HUSB")) + r := refto(" wife", p.r ~=== gedref(fam, "WIFE")) + # if had earlier kids and did not indicate remarriage, do so now + if \r then + write(" m.") + # print children under husband, or under wife if no husband + if (p.r === gedref(fam, "HUSB")) | (not gedref(fam, "HUSB")) then { + every r := gedref(fam, "CHIL") do { + case (gedval(r, "SEX") | "") of { + "M": refto(" son", r) + "F": refto(" dau", r) + default: refto(" child", r) + } + } + } + } + + event("d.", \d) + } +end + +procedure event(label, r) + local date, place + + date := ("" ~== geddate(r)) + place := ("" ~== gedval(r, "PLAC")) + if /place then + write(" ", label, " ", \date) + else + write(" ", label, " ", \date | " ", " ", place) + return +end + +procedure refto(label, r) + write(" ", label, " [", ptab[r].n, "] ", gedfnf(r)) + return +end + +procedure sortkey(r) + return map(gedlnf(r)) +end diff --git a/ipl/progs/gediff.icn b/ipl/progs/gediff.icn new file mode 100644 index 0000000..58cec6f --- /dev/null +++ b/ipl/progs/gediff.icn @@ -0,0 +1,79 @@ +############################################################################ +# +# File: gediff.icn +# +# Subject: Program to "diff" for use with ged +# +# Author: Robert J. Alexander +# +# Date: July 9, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to produce diff output in a format for use with ged's +# "FindFileAndLine" (esc-S) command. It causes the "diffed" files +# to be open in the editor with the differing portions selected. +# +############################################################################ +# +# Links: options, word +# +############################################################################ +# +# Requires: pipes, a "diff" command in the environment +# +############################################################################ +# +# See also: diffn.icn (a diff-type program) +# +############################################################################ + +link options,word + +global Diff,ArgStr + +procedure Options(arg) + local opt,c + opt := options(arg,"dbitwrsS:") + Diff := \opt["d"] | "diff" + ArgStr := "" + ArgStr ||:= " -S " || \opt["S"] + every c := !"bitwrs" do { # single-character options passed to diff + if \opt[c] then ArgStr ||:= " -" || c + } + return opt +end + +procedure main(arg) + local argstr,fn1,fn2,p,dargs,cmd + Options(arg) + every ArgStr ||:= " " || !arg + fn1 := arg[-2] + fn2 := arg[-1] + cmd := Diff || ArgStr + #write(&errout,cmd) + p := open(cmd,"pr") + while read(p) ? { + if any(&digits) then { + write(fn1,":",tab(upto(&letters))) + move(1) + write(fn2,":",tab(0)) + } + else if ="diff" & tab(many(' \t')) then { + write(&subject) + dargs := [] + while put(dargs,word_dequote(tab(word()))) do tab(many(' \t')) + fn1 := dargs[-2] + fn2 := dargs[-1] + while match("./",fn1) do fn1[1+:2] := "" + while match("./",fn2) do fn2[1+:2] := "" + } + else write(tab(0)) + {} + } + exit(close(p)) +end diff --git a/ipl/progs/gener.icn b/ipl/progs/gener.icn new file mode 100644 index 0000000..9c0b750 --- /dev/null +++ b/ipl/progs/gener.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: gener.icn +# +# Subject: Program to generate sequence from Icon expression +# +# Author: Ralph E. Griswold +# +# Date: January 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program takes an Icon expression is given on the command line, and +# writes its results to standard output. Watch for syntactic problems. +# +############################################################################ +# +# Requires: system(), pipes +# +############################################################################ +# +# Links: exprfile +# +############################################################################ + +link exprfile + +procedure main(args) + local input + + input := exprfile(args[1], "seqfncs") + + while write(read(input)) + +end diff --git a/ipl/progs/genfile.icn b/ipl/progs/genfile.icn new file mode 100644 index 0000000..7347a4d --- /dev/null +++ b/ipl/progs/genfile.icn @@ -0,0 +1,47 @@ +############################################################################ +# +# File: genfile.icn +# +# Subject: Program to generate sequence from Icon expression in file +# +# Author: Ralph E. Griswold +# +# Date: January 22, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes the results of an Icon expression given in the file +# named on the command line. +# +############################################################################ +# +# Requires: system(), pipes +# +############################################################################ +# +# Links: exprfile +# +############################################################################ + +link exprfile + +procedure main(args) + local expression, input, limit + + limit := 1000 # AD HOC; make option. + + input := open(args[1]) | stop("*** cannot open file") + + expression := read(input) | stop("*** empty file") + + close(input) + + input := exprfile(expression, "seqfncs") + + every write(!input) \ limit + +end diff --git a/ipl/progs/genqueen.icn b/ipl/progs/genqueen.icn new file mode 100644 index 0000000..f10d70f --- /dev/null +++ b/ipl/progs/genqueen.icn @@ -0,0 +1,101 @@ +############################################################################ +# +# File: genqueen.icn +# +# Subject: Program to solve arbitrary-size n-queens problem +# +# Author: Peter A. Bigot +# +# Date: October 25, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program solve the non-attacking n-queens problem for (square) boards +# of arbitrary size. The problem consists of placing chess queens on an +# n-by-n grid such that no queen is in the same row, column, or diagonal as +# any other queen. The output is each of the solution boards; rotations +# not considered equal. An example of the output for n: +# +# ----------------- +# |Q| | | | | | | | +# ----------------- +# | | | | | | |Q| | +# ----------------- +# | | | | |Q| | | | +# ----------------- +# | | | | | | | |Q| +# ----------------- +# | |Q| | | | | | | +# ----------------- +# | | | |Q| | | | | +# ----------------- +# | | | | | |Q| | | +# ----------------- +# | | |Q| | | | | | +# ----------------- +# +# Usage: genqueen n +# where n is the number of rows / columns in the board. The default for n +# is 6. +# +############################################################################ + +global + n, # Number of rows/columns + rw, # List of queens in each row + dd, # List of queens in each down diagonal + ud # List of queens in each up diagonal + +procedure main (args) # Program arguments + n := integer (args [1]) | 6 + rw := list (n) + dd := list (2*n-1) + ud := list (2*n-1) + solvequeen (1) + return + end # procedure main + +# placequeen(c) -- Place a queen in every permissible position in column c. +# Suspend with each result. +procedure placequeen (c) # Column at which to place queen + local r # Possible placement row + + every r := 1 to n do + suspend (/rw [r] <- /dd [r+c-1] <- /ud [n+r-c] <- c) + fail + end # procedure placequeen + +# solvequeen(c) -- Place the c'th and following column queens on the board. +# Write board if have completed it. Suspends all viable results +procedure solvequeen (c) # Column for next queen placement + if (c > n) then { + # Have placed all required queens. Write the board, and resume search. + writeboard () + fail + } + suspend placequeen (c) & solvequeen (c+1) + fail + end # procedure solvequeen + +# writeboard() -- Write an image of the board with the queen positions +# represented by Qs. +procedure writeboard () + local + r, # Index over rows during print + c, # Column of queen in row r + row # Depiction of row as its created + + write (repl ("--", n), "-") + every r := 1 to n do { + c := rw [r] + row := repl ("| ", n) || "|" + row [2*c] := "Q" + write (row) + write (repl ("--", n), "-") + } + write () + end # procedure writeboard diff --git a/ipl/progs/getcol.icn b/ipl/progs/getcol.icn new file mode 100644 index 0000000..8524667 --- /dev/null +++ b/ipl/progs/getcol.icn @@ -0,0 +1,53 @@ +############################################################################ +# +# File: getcol.icn +# +# Subject: Program to extract column from data +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program extracts a column from multi-column data. +# +# The supported options are: +# +# -n i column number, default 1 +# -c s column-separation characters, default ' \t' +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local i, chars, col, line, opts + + opts := options(args, "n+c:") + + i := \opts["n"] | 1 + if i < 1 then stop("*** invalid column specifications") + + chars := cset(\opts["c"]) | ' \t' + if *chars = 0 then stop("*** invalid character-separation specification") + + while line := read() do { + line ? { + every 1 to i - 1 do { + tab(upto(chars)) | stop("*** column missing") + tab(many(chars)) + } + write(tab(upto(chars) | 0)) + } + } + +end diff --git a/ipl/progs/getlines.icn b/ipl/progs/getlines.icn new file mode 100644 index 0000000..5c1b343 --- /dev/null +++ b/ipl/progs/getlines.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: getlines.icn +# +# Subject: Program to extract lines from a file +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to extract a few specified lines from a file. +# The line numbers are given on the command line, the file is read from +# standard input and the extracted lines are written to standard output +# as in +# +# getlines 46 23 119 <infile >outfile +# +# which writes lines 23, 46, and 119 of infile (if it contains that many +# lines) to outfile. +# +# Line numbers do not have to be given in order. Numbers less than 1 are +# ignored, but a nonnumerical argument is treated as an error. +# +############################################################################ + +procedure main(lines) + local i, line + + if *lines = 0 then stop("*** no lines specified") + + every i := 1 to *lines do + lines[i] := integer(lines[i]) | + stop("*** nonnumeric argument: ", image(lines[i])) + + lines := set(lines) # inefficient method but easy + + i := 0 + + while line := read() do { + i +:= 1 + if member(lines, i) then { + write(line) + delete(lines, i) # so process can be stopped before end + if *lines = 0 then exit() + } + } + +end diff --git a/ipl/progs/gftrace.icn b/ipl/progs/gftrace.icn new file mode 100644 index 0000000..d6bd0a9 --- /dev/null +++ b/ipl/progs/gftrace.icn @@ -0,0 +1,94 @@ +############################################################################ +# +# File: gftrace.icn +# +# Subject: Program for generating function tracing procedures +# +# Author: Gregg M. Townsend +# +# Date: August 8, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes a set of procedures to standard output. Those +# procedures can be linked with an Icon program to enable the tracing of +# calls to built-in functions. See the comments in the generated code +# for details. +# +# The set of generated functions reflects the built-in functions of +# the version of Icon under which this generator is run. +# +############################################################################ + + +procedure main() + local s + + header() + + write() + write("procedure _func(a[]); _func:=proc(\"proc\",0); ", + "proc:=_proc; return _func!a; end") + write("procedure _proc(a[]); static p; initial p:=_func(\"proc\",0); ", + "suspend p!a; end") + write() + + every s := function() do + if s ~== "proc" then + write("procedure ", s, "(a[]); static p; initial p:=_func(\"", + s, "\",0); suspend p!a; end") +end + + +procedure header() + local divider, date + + divider := repl("#", 76) + + &dateline ? { + tab(upto(',') + 1) + tab(many(' ')) + date := tab(upto(',') + 6) + } + + every write(![ + divider, + "#", + "#\tFile: ftrace.icn", + "#", + "#\tSubject: Procedures for tracing calls to built-in functions", + "#", + "#\tAuthor: Gregg M. Townsend", + "#", + "#\tDate: " || date, + "#", + divider + ]) + + every write ("# ", ![ + "", + " These procedures, when linked with an Icon program, cause calls of", + "built-in functions to be traced (along with calls of user procedures)", + "when &trace is nonzero. This is accomplished by interposing a level of", + "Icon procedures between the user program and the built-in functions.", + "", + " In the trace output, function arguments are shown as a list. The", + "very first function call produces two extra trace lines showing a call", + "to \"_func\". Calls to \"proc\" are reported as calls to \"_proc\".", + "", + " If the user program overloads any built-in function, linking fails", + "due to an \"inconsistent redeclaration\".", + ""]) + + write(divider) + write("#") + write("# Generated under: ", &version) + write("#") + write(divider) + + return +end diff --git a/ipl/progs/graphdem.icn b/ipl/progs/graphdem.icn new file mode 100644 index 0000000..05a022a --- /dev/null +++ b/ipl/progs/graphdem.icn @@ -0,0 +1,164 @@ +############################################################################ +# +# File: graphdem.icn +# +# Subject: Program to demonstrate simple bar graphics +# +# Author: Matthias Heesch +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# graph.icn: simple bar graphics package with two demo applications: +# 1. display the 4 most frequently used characters in a string. +# 2. display the fibonacci numbers +# +############################################################################ +# +# Requires: ANSI terminal support +# +############################################################################ + +procedure main() + local option + + write("graph: simple bar graphics package for icon") + write("(b)yte frequency count or (f)ibonacci's numbers?") + option := read() + case option of { +"b" : countdemo() +"f" : fibodemo() +default : write("erroneous option") + } +end +# +procedure countdemo() + local numlist, line, a, ms, b + + numlist := list(0) + write("type strings or quit using end-of-file") + while line := read() do { + a := frequ_count(line,4) + ms := a + a ? { + while b := tab(upto(";")) do { + b ? { + tab(upto(",")) + move(1) + b := tab(0) + } + move(1) + put(numlist,b) + } + } + graph(numlist,("the most frequently used characters: " || ms)) + } +end +# +procedure frequ_count(lin,item_number) + local result, n, byte_frequency_1, byte_frequency_2, byte, entry + + result := "" + n := 1 + byte_frequency_1 := table(0) + every byte := !lin do { + byte_frequency_1[byte] +:= 1 + } + byte_frequency_2 := sort(byte_frequency_1,2) + while n <= item_number do { + entry := pull(byte_frequency_2) + result := result || pop(entry) || "," || pull(entry) || ";" + n +:= 1 + } +return result +end +# +# fibodemo(): calls user defined function fibo(n,m): fibodemo() will +# use an ansi escape code to clear the screen after every call to +# graph. therefore when using ms/dr dos the config.sys file should +# contain: device=ansi.sys. using other operating systems, the line +# containing the esc-code should be deleted. +procedure fibodemo() + local a, l, b, fb + + while every a := fibo(0,1) & a < 10000 do { + l := list(4,0) +# delete the following line if you don't use ms/dr dos + write(char(27),"[2J") + l[1] := a + graph(l,("fibo: " || a || ". <enter> to continue")) + b := read() + } +end +# +procedure fibo(m,n) + local fb + + while n < 30000 do { + fb := m + n + m := n + n := fb + suspend fb + } +end +# +# graph(numbers,comment): bar graphics function which accepts a list +# of 4 integers 10000 and a commentary message. it will display 4 +# bar graphic diagrams which each contains a diagram of one of the +# argument values. in the order of the decimal system, the left bar +# shows the 1000s, the following the 100s etc. Therefore the values +# have to be <10000. When the diagram has been displayed argument +# comment will be written to the screen. +procedure graph(numbers,comment) + local item, itm, value, bar, graph_line, l, m, n, nn + +# item2 is a list which contains lists of each 4 strings. these strings +# correspond to the numerical values in the lists contained in list +# numbers. each of these strings contains repl(" ",(10-numerical_value)) +# || repl("\334",numerical_value). +# +# create item2 with its string contents + item := list(0) + while itm := pop(numbers) do { +# write every place of itm if there are less then 4 places. + if *itm < 4 then itm := repl("0",(4 - *itm)) || itm +# convert every place of itm to a "\334 "-string and assign it +# to list item + while every value := !itm do { + bar := repl(" ",(10 - value)) || repl("\334",value) + put(item,bar) + } + } +# display bar graphic + graph_line := "" + l := 1 + m := 1 + n := 1 + nn := 10 + while n <= 10 do { + while m <= 16 do { + while l <= 4 do { + graph_line := graph_line || " " || !item[m] + item[m][1] := "" + l +:= 1 + m +:= 1 + } + graph_line := graph_line || " \272 " + l := 1 + } + write(graph_line," ",nn) + graph_line := "" + l := 1 + m := 1 + n +:= 1 + nn -:= 1 + } + write(" a b c d") + write("a: 1000, b: 100, c: 10, d: 1") + write(comment) +end diff --git a/ipl/progs/grpsort.icn b/ipl/progs/grpsort.icn new file mode 100644 index 0000000..4ea4f34 --- /dev/null +++ b/ipl/progs/grpsort.icn @@ -0,0 +1,190 @@ +############################################################################ +# +# File: grpsort.icn +# +# Subject: Program to sort groups of lines +# +# Author: Thomas R. Hicks +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/hcal4unx.icn b/ipl/progs/hcal4unx.icn new file mode 100644 index 0000000..80382aa --- /dev/null +++ b/ipl/progs/hcal4unx.icn @@ -0,0 +1,950 @@ +############################################################################ +# +# File: hcal4unx.icn +# +# Subject: Program for Jewish/Civil calendar in UNIX +# +# Author: Alan D. Corre (ported to UNIX by Richard L. Goerwitz) +# +# Date: January 3, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.16 +# +############################################################################ +# +# This work is respectfully devoted to the authors of two books +# consulted with much profit: "A Guide to the Solar-Lunar Calendar" +# by B. Elihu Rothblatt published by our sister Hebrew Dept. in +# Madison, Wis., and "Kiddush HaHodesh" by Rabbenu Moses ben Maimon, +# on whom be peace. +# +# The Jewish year harmonizes the solar and lunar cycle, using the +# 19-year cycle of Meton (c. 432 BCE). It corrects so that certain +# dates shall not fall on certain days for religious convenience. The +# Jewish year has six possible lengths, 353, 354, 355, 383, 384, and +# 385 days, according to day and time of new year lunation and +# position in Metonic cycle. Time figures from 6pm previous night. +# The lunation of year 1 is calculated to be on a Monday (our Sunday +# night) at ll:11:20pm. Our data table begins with a hypothetical +# year 0, corresponding to 3762 B.C.E. Calculations in this program +# are figured in the ancient Babylonian unit of halaqim "parts" of +# the hour = 1/1080 hour. +# +# Startup syntax is simply hebcalen [date], where date is a year +# specification of the form 5750 for a Jewish year, +1990 or 1990AD +# or 1990CE or -1990 or 1990BC or 1990BCE for a civil year. +# +############################################################################ +# +# Revised October 25, 1993 by Ralph E. Griswold to use dopen(). +# +############################################################################ +# +# Links: io, iolib +# +############################################################################ +# +# Requires: UNIX, hebcalen.dat, hebcalen.hlp +# +############################################################################ +# +# See also: hebcalen.icn +# +############################################################################ + +link io +link iolib + +record date(yr,mth,day) +record molad(day,halaqim) + +global cyr,jyr,days_in_jyr,current_molad,current_day,infolist + + +#------- the following sections of code have been modified - RLG -------# + +procedure main(a) + local n, p + + iputs(getval("ti")) + display_startup_screen() + + if *a = 0 then { + #put()'ing an asterisk means that user might need help + n := 1; put(a,"*") + } + else n := *a + every p := 1 to n do { + initialize(a[p]) | break + process() | break + } + iputs(getval("te")) + +end + + + +procedure display_startup_screen() + + local T + + clear() + banner("PERPETUAL JEWISH/CIVIL CALENDAR","by","ALAN D. CORRE") + # Use a combination of tricks to be sure it will be up there a sec. + every 1 to 10000 + T := &time; until &time > (T+450) + + return + +end + + + +procedure banner(l[]) + + # Creates a banner to begin hebcalen. Leaves it on the screen for + # about a second. + + local m, n, CM, COLS, LINES + + CM := getval("cm") + COLS := getval("co") + LINES := getval("li") + (COLS > 55, LINES > 9) | + stop("\nSorry, your terminal just isn't big enough.") + + if LINES > 20 then { + # Terminal is big enough for banner. + iputs(igoto(CM,1,3)) + writes("+",repl("-",COLS-3),"+") + iputs(igoto(CM,1,4)) + writes("|") + iputs(igoto(CM,COLS-1,4)) + writes("|") + + m := 0 + every n := 5 to (*l * 3) + 4 by 3 do { + iputs(igoto(CM,1,n)) + writes("|",center(l[m+:=1],COLS-3),"|") + every iputs(igoto(CM,1,n+(1|2))) & writes("|") + every iputs(igoto(CM,COLS-1,n+(1|2))) & writes("|") + } + + iputs(igoto(CM,1,n+3)) + writes("+",repl("-",COLS-3),"+") + iputs(igoto(CM,1,n+4)) + write(" Copyright (c) Alan D. Corre, 1990") + } + else { + # Terminal is extremely short + iputs(igoto(CM,1,(LINES/2)-1)) + write(center(l[1],COLS)) + write(center("Copyright (c) Alan D. Corre, 1990",COLS)) + } + + return + +end + + + +procedure get_paths() + + local paths, p + + suspend "./" | "/usr/local/lib/hebcalen/" + paths := getenv("PATH") + \paths ? { + tab(match(":")) + while p := 1(tab(find(":")), move(1)) + do suspend "" ~== trim(p,'/ ') || "/" + return "" ~== trim(tab(0) \ 1,'/ ') || "/" + } + +end + + + +procedure instructions(filename) + + # Gives user access to a help file which is printed out in chunks + # by "more." + + local helpfile, pager, ans, more_file + + iputs(igoto(getval("cm"),1,2)) + writes("Do you need instructions? [ny] ") + ans := map(read()) + "q" == ans & fail + + if "y" == ans then { + clear() + write() + dopen(helpfile := filename) | + stop("Can't find your hebcalen.hlp file!") + iputs(igoto(getval("cm"),1,getval("li"))) + boldface() + writes("Press return to continue.") + normal() + "q" == map(read()) & fail + } + + return \helpfile | "no help" + +end + + + +procedure clear() + local i + + # Clears the screen. Tries several methods. + + if not iputs(getval("cl")) + then iputs(igoto(getval("cm"),1,1)) + if not iputs(getval("cd")) + then { + every i := 1 to getval("li") do { + iputs(igoto(getval("cm"),1,i)) + iputs(getval("ce")) + } + iputs(igoto(getval("cm"),1,1)) + } + +end + + + +procedure initialize_list() + + # Put info of hebcalen.dat into a global list + + local infile,n + + infolist := list(301) + if not (infile := dopen("hebcalen.dat")) then + stop("\nError: cannot open hebcalen.dat") + + # The table is arranged at twenty year intervals with 301 entries. + every n := 1 to 301 do + infolist[n] := read(infile) + close(infile) + +end + + + +procedure initialize_variables() + + # Get the closest previous year in the table. + + local line, quotient + + quotient := jyr.yr / 20 + 1 + # Only 301 entries. Figure from last if necessary. + if quotient > 301 then quotient := 301 + # Pull the appropriate info, put into global variables. + line := infolist[quotient] + + line ? { + current_molad.day := tab(upto('%')) + move(1) + current_molad.halaqim := tab(upto('%')) + move(1) + cyr.mth := tab(upto('%')) + move(1) + cyr.day := tab(upto('%')) + move(1) + cyr.yr := tab(upto('%')) + days_in_jyr := line[-3:0] + } + + # Begin at rosh hashana. + jyr.day := 1 + jyr.mth := 7 + return + +end + + + +procedure initialize(yr) + + local year + static current_year + + # initialize global variables + initial { + cyr := date(0,0,0) + jyr := date(0,0,0) + current_molad := molad(0,0) + initialize_list() + current_year := get_current_year() + } + + clear() + #user may need help + if yr == "*" then { + instructions("hebcalen.hlp") | fail + clear() + iputs(igoto(getval("cm"),1,2)) + write("Enter a year. By default, all dates are interpreted") + write("according to the Jewish calendar. Civil years should") + write("be preceded by a + or - sign to indicate occurrence") + write("relative to the beginning of the common era (the cur-") + writes("rent civil year, ",current_year,", is the default): ") + boldface() + year := read() + normal() + "q" == map(year) & fail + } + else year := yr + + "" == year & year := current_year + until jyr.yr := cleanup(year) do { + writes("\nI don't consider ") + boldface() + writes(year) + normal() + writes(" a valid date. Try again: ") + boldface() + year := read() + normal() + "q" == map(year) & fail + "" == year & year := current_year + } + + clear() + initialize_variables() + return + +end + + + +procedure get_current_year() + local c_date + + &date ? c_date := tab(find("/")) + return "+" || c_date +end + + + +procedure cleanup(str) + + # Tidy up the string. Bugs still possible. + + if "" == trim(str) then return "" + + map(Strip(str,~(&digits++'ABCDE+-'))) ? { + + if find("-"|"bc"|"bcd") + then return (0 < (3761 - (0 ~= checkstr(str)))) + else if find("+"|"ad"|"ce") + then return ((0 ~= checkstr(str)) + 3760) + else if 0 < integer(str) + then return str + else fail + + } + +end + + + +procedure Strip(s,c) + local s2 + + s2 := "" + s ? { + while s2 ||:= tab(upto(c)) + do tab(many(c)) + s2 ||:= tab(0) + } + return s2 + +end + + + +procedure checkstr(s) + + # Does preliminary work on string before cleanup() cleans it up. + + local letter,n,newstr + + newstr := "" + every newstr ||:= string(integer(!s)) + if 0 = *newstr | "" == newstr + then fail + else return newstr + +end + + + +procedure process() + local ans, yj, n + + # Extracts information about the specified year. + + local msg, limit, dj, dc, month_count, done + static how_many_per_screen, how_many_screens + initial { + how_many_per_screen := how_many_can_fit() + (how_many_screens := seq()) * how_many_per_screen >= 12 + } + + # 6019 is last year handled by the table in the usual way. + if jyr.yr > 6019 + then msg := "Calculating. Years over 6019 take a long time." + else msg := "Calculating." + if jyr.yr <= 6019 then { + limit := jyr.yr % 20 + jyr.yr := ((jyr.yr / 20) * 20) + } + else { + limit := jyr.yr - 6000 + jyr.yr := 6000 + } + + ans := "y" + establish_jyr() + iputs(igoto(getval("cm"),1,2)) + writes(msg) + every 1 to limit do { + # Increment the years, establish the type of Jewish year + cyr_augment() + jyr_augment() + establish_jyr() + } + + clear() + while ("y"|"") == map(ans) do { + + yj := jyr.yr + dj := days_in_jyr + + month_count := 0 + # On the variable how_many_screens, see initial { } above + every n := 1 to how_many_screens do { + clear() + every 1 to how_many_per_screen do { + write_a_month() + (month_count +:= 1) = 12 & break + } + if month_count < 12 | (12 % (13 > how_many_per_screen)) = 0 + then { + + iputs(igoto(getval("cm"),1,getval("li")-2)) + boldface() + writes(status_line(yj,dj)) + normal() + + if month_count < 12 | jyr.mth = 6 then { + iputs(igoto(getval("cm"),1,getval("li")-1)) + writes("Press return to continue. ") + "q" == map(read()) & fail + } + } + } + + if jyr.mth = 6 then { + if (12 % (13 > how_many_per_screen)) = 0 + then clear() + write_a_month() + } + iputs(igoto(getval("cm"),1,getval("li")-2)) + boldface() + writes(status_line(yj,dj)) + normal() + + iputs(igoto(getval("cm"),1,getval("li")-1)) + writes("Display the next year? [yn] ") + ans := read() + + } + return + +end + + + +procedure how_many_can_fit() + + local LINES, how_many + + LINES := getval("li") + 1 + (((8 * (how_many := 1 to 14)) / LINES) = 1) + + return how_many - 1 + +end + + + +procedure cyr_augment() + + # Make civil year a year later, we only need consider Aug,Sep,Nov. + + local days,newmonth,newday + + if cyr.mth = 8 then + days := 0 else + if cyr.mth = 9 then + days := 31 else + if cyr.mth = 10 then + days := 61 else + stop("Error in cyr_augment") + + writes(".") + + days := (days + cyr.day-365+days_in_jyr) + if isleap(cyr.yr + 1) then days -:= 1 + + # Cos it takes longer to get there. + if days <= 31 then {newmonth := 8; newday := days} else + if days <= 61 then {newmonth := 9; newday := days-31} else + {newmonth := 10; newday := days-61} + + cyr.mth := newmonth + cyr.day := newday + cyr.yr +:= 1 + if cyr.yr = 0 then cyr.yr := 1 + + return + +end + + + +procedure header() + local COLS + + # Creates the header for Jewish and English side. Bug: This + # routine, as it stands, has to rewrite the entire screen, in- + # cluding blank spaces. Many of these could be elminated by + # judicious line clears and/or cursor movement commands. Do- + # ing so would certainly speed up screen refresh for lower + # baud rates. I've utilized the ch command where available, + # but in most cases, plain old spaces must be output. + + static make_whitespace, whitespace + initial { + COLS := getval("co") + if getval("ch") then { + # Untested, but it would offer a BIG speed advantage! + make_whitespace := create |iputs(igoto(getval("ch"),(COLS-53)+25)) + } + else { + # Have to do things this way, since we don't know what line + # we are on (cm commands usually default to row/col 1). + whitespace := repl(" ",COLS-53) + make_whitespace := create |writes(whitespace) + } + } + + writes(repl(" ",7),"S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W", + repl(" ",2),"T",repl(" ",2),"F",repl(" ",2)) + boldface() + writes("S") + normal() + @make_whitespace + writes("S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W", + repl(" ",2),"T",repl(" ",2),"F",repl(" ",2)) + boldface() + writes("S") + normal() + iputs(getval("ce")) + write() + +end + + + +procedure write_a_month() + + # Writes a month on the screen + + header() + every 1 to 5 do { + writes(make_a_line()) + iputs(getval("ce")) + write() + } + if jyr.day ~= 1 then { + writes(make_a_line()) + iputs(getval("ce")) + write() + } + iputs(getval("ce")) + write() + + return + +end + + + +procedure status_line(a,b) + + # Create the status line at the bottom of screen. + + local sline,c,d + + c := cyr.yr + if (cyr.day = 1) & (cyr.mth = 1) then c -:= 1 + d := { if isleap(c) then 366 else 365 } + if getval("co") > 79 then { + sline := ("Year of Creation: " || a || " Days in year: " || b || + " Civil year: " || c || " Days in year: " || d) + } + else { + sline := ("Jewish year " || a || " (" || b || " days)," || + " Civil year " || c || " (" || d || " days)") + } + + return center(sline,getval("co")) + +end + + + +procedure boldface() + + static bold_str, cookie_str + initial { + if bold_str := getval("so") + then cookie_str := repl(getval("bc") | "\b", getval("sg")) + else { + if bold_str := getval("ul") + then cookie_str := repl(getval("bc") | "\b", getval("ug")) + } + } + + iputs(\bold_str) + iputs(\cookie_str) + return + +end + + + +procedure normal() + + static UN_bold_str, cookie_str + initial { + if UN_bold_str := getval("se") + then cookie_str := repl(getval("bc") | "\b", getval("sg")) + else { + if UN_bold_str := getval("ue") + then cookie_str := repl(getval("bc") | "\b", getval("ug")) + } + } + + iputs(\UN_bold_str) + iputs(\cookie_str) + return + +end + + +#--------------------- end modified sections of code ----------------------# + +# Okay, okay a couple of things have been modified below, but nothing major. + +procedure make_a_line() +#make a single line of the months +local line,blanks1,blanks2,start_point,end_point,flag,fm +static number_of_spaces +initial number_of_spaces := getval("co")-55 + +#consider the first line of the month + if jyr.day = 1 then { + line := mth_table(jyr.mth,1) +#setting flag means insert civil month at end of line + flag := 1 } else + line := repl(" ",3) +#consider the case where first day of civil month is on Sunday + if (cyr.day = 1) & (current_day = 1) then flag := 1 +#space between month name and beginning of calendar + line ||:= repl(" ",2) +#measure indentation for first line + line ||:= blanks1 := repl(" ",3*(current_day-1)) +#establish start point for Hebrew loop + start_point := current_day +#establish end point for Hebrew loop and run civil loop + every end_point := start_point to 7 do { + line ||:= right(jyr.day,3) + if not j_augment() then {jyr_augment(); establish_jyr(); current_day -:= 1; if current_day = 0 then current_day := 7} + d_augment() + if jyr.day = 1 then break } +#measure indentation for last line + blanks2 := repl(" ",3*(7-end_point)) + line ||:= blanks2; line ||:= repl(" ",number_of_spaces); line ||:= blanks1 + every start_point to end_point do { + line ||:= right(cyr.day,3) + if (cyr.day = 1) then flag := 1 + augment()} + line ||:= blanks2 ||:= repl(" ",3) + fm := cyr.mth + if cyr.day = 1 then + if cyr.mth = 1 then fm := 12 else fm := cyr.mth - 1 + if \flag then line ||:= mth_table(fm,2) else + line ||:= repl(" ",3) +return line +end + +procedure mth_table(n,p) +#generates the short names of Jewish and Civil months. Get to civil side +#by adding 13 (=max no of Jewish months) +static corresp +initial corresp := ["NIS","IYA","SIV","TAM","AV ","ELU","TIS","HES","KIS", +"TEV","SHE","ADA","AD2","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP", +"OCT","NOV","DEC"] + if (p ~= 1) & (p ~= 2) then stop("ERROR IN MTH-TABLE") else + if p = 2 then n +:= 13 +return corresp[n] +end + +procedure d_augment() +#increment the day of the week + current_day +:= 1 + if current_day = 8 then current_day := 1 +return +end + +procedure augment() +#increments civil day, modifies month and year if necessary, stores in +#global variable cyr + if cyr.day < 28 then + cyr.day +:= 1 else + if cyr.day = 28 then { + if (cyr.mth ~= 2) | ((cyr.mth = 2) & isleap(cyr.yr)) then + cyr.day := 29 else { + cyr.mth := 3 + cyr.day := 1}} else + if cyr.day = 29 then { + if cyr.mth ~= 2 then + cyr.day := 30 else { + cyr.mth := 3 + cyr.day := 1}} else + if cyr.day = 30 then { + if is_31(cyr.mth) then + cyr.day := 31 else { + cyr.mth +:= 1 + cyr.day := 1}} else { + cyr.day := 1 + if cyr.mth ~= 12 then + cyr.mth +:= 1 else { + cyr.mth := 1 + cyr.yr +:= 1 + if cyr.yr = 0 + then cyr.yr := 1}} +return +end + +procedure is_31(n) +#civil months with 31 days +return n = 1 | n = 3 | n = 5 | n = 7 | n = 8 | n = 10 | n = 12 +end + +procedure isleap(n) +#checks for civil leap year + if n > 0 then +return (n % 400 = 0) | ((n % 4 = 0) & (n % 100 ~= 0)) else +return (n % 400 = -1) | ((n % 4 = -1) & (n % 100 ~= -1)) +end + +procedure j_augment() +#increments jewish day. months are numbered from nisan, adar sheni is 13. +#procedure fails at elul to allow determination of type of new year + if jyr.day < 29 then + jyr.day +:= 1 else + if (jyr.day = 30) | always_29(jyr.mth) | ((jyr.mth = 8) & + (days_in_jyr % 5 ~= 0)) | ((jyr.mth = 9) & ((days_in_jyr = 353) | + (days_in_jyr = 383))) then + jyr.mth +:= jyr.day := 1 else + if jyr.mth = 6 then fail else + if ((jyr.mth = 12) & (days_in_jyr < 383)) | (jyr.mth = 13) then + jyr.mth := jyr.day := 1 else + jyr.day := 30 +return +end + +procedure always_29(n) +#uncomplicated jewish months with 29 days +return n = 2 | n = 4 | n = 10 +end + +procedure jyr_augment() +#determines the current time of lunation, using the ancient babylonian unit +#of 1/1080 of an hour. lunation of tishri determines type of year. allows +#for leap year. halaqim = parts of the hour +local days, halaqim + days := current_molad.day + 4 + if days_in_jyr <= 355 then { + halaqim := current_molad.halaqim + 9516 + days := ((days +:= halaqim / 25920) % 7) + if days = 0 then days := 7 + halaqim := halaqim % 25920} else { + days +:= 1 + halaqim := current_molad.halaqim + 23269 + days := ((days +:= halaqim / 25920) % 7) + if days = 0 then days := 7 + halaqim := halaqim % 25920} + current_molad.day := days + current_molad.halaqim := halaqim +#reset the global variable which holds the current jewish date + jyr.yr +:= 1 #increment year + jyr.day := 1 + jyr.mth := 7 + establish_jyr() +return +end + +procedure establish_jyr() +#establish the jewish year from get_rh +local res + res := get_rh(current_molad.day,current_molad.halaqim,no_lunar_yr(jyr.yr)) + days_in_jyr := res[2] + current_day := res[1] +return +end + +procedure isin1(i) +#the isin procedures are sets of years in the Metonic cycle +return i = (1 | 4 | 7 | 9 | 12 | 15 | 18) +end + +procedure isin2(i) +return i = (2 | 5 | 10 | 13 | 16) +end + +procedure isin3(i) +return i = (3 | 6 | 8 | 11 | 14 | 17 | 0) +end + +procedure isin4(i) +return i = (1 | 2 | 4 | 5 | 7 | 9 | 10 | 12 | 13 | 15 | 16 | 18) +end + +procedure isin5(i) +return i = (1 | 4 | 9 | 12 | 15) +end + +procedure isin6(i) +return i = (2 | 5 | 7 | 10 | 13 | 16 | 18) +end + +procedure no_lunar_yr(i) +#what year in the metonic cycle is it? +return i % 19 +end + +procedure get_rh(d,h,yr) +#this is the heart of the program. check the day of lunation of tishri +#and determine where breakpoint is that sets the new moon day in parts +#of the hour. return result in a list where 1 is day of rosh hashana and +#2 is length of jewish year +local c,result + c := no_lunar_yr(yr) + result := list(2) + if d = 1 then { + result[1] := 2 + if (h < 9924) & isin4(c) then result[2] := 353 else + if (h < 22091) & isin3(c) then result[2] := 383 else + if (h > 9923) & (isin1(c) | isin2(c)) then result[2] := 355 else + if (h > 22090) & isin3(c) then result[2] := 385 + } else + if d = 2 then { + if ((h < 16789) & isin1(c)) | + ((h < 19440) & isin2(c)) then { + result[1] := 2 + result[2] := 355 + } else + if (h < 19440) & isin3(c) then { + result[1] := 2 + result[2] := 385 + } else + if ((h > 16788) & isin1(c)) | + ((h > 19439) & isin2(c)) then { + result[1] := 3 + result[2] := 354 + } else + if (h > 19439) & isin3(c) then { + result[1] := 3 + result[2] := 384 + } + } else + if d = 3 then { + if (h < 9924) & (isin1(c) | isin2(c)) then { + result[1] := 3 + result[2] := 354 + } else + if (h < 19440) & isin3(c) then { + result[1] := 3 + result[2] := 384 + } else + if (h > 9923) & isin4(c) then { + result[1] := 5 + result[2] := 354 + } else + if (h > 19439) & isin3(c) then { + result[1] := 5 + result[2] := 383} + } else + if d = 4 then { + result[1] := 5 + if isin4(c) then result[2] := 354 else + if h < 12575 then result[2] := 383 else + result[2] := 385 + } else + if d = 5 then { + if (h < 9924) & isin4(c) then { + result[1] := 5 + result[2] := 354} else + if (h < 19440) & isin3(c) then { + result[1] := 5 + result[2] := 385 + } else + if (9923 < h < 19440) & isin4(c) then { + result[1] := 5 + result[2] := 355 + } else + if h > 19439 then { + result[1] := 7 + if isin3(c) then result[2] := 383 else + result[2] := 353 + } + } else + if d = 6 then { + result[1] := 7 + if ((h < 408) & isin5(c)) | ((h < 9924) & isin6(c)) then + result[2] := 353 else + if ((h < 22091) & isin3(c)) then result[2] := 383 else + if ((h > 407) & isin5(c)) | ((h > 9923) & isin6(c)) then + result[2] := 355 else + if (h > 22090) & isin3(c) then result[2] := 385 + } else + if d = 7 then if (h < 19440) & (isin5(c) | isin6(c)) then { + result[1] := 7 + result[2] := 355 + } else + if (h < 19440) & isin3(c) then { + result[1] := 7 + result[2] := 385 + } else { + result[1] := 2 + if isin4(c) then + result[2] := 353 else + result[2] := 383} +return result +end diff --git a/ipl/progs/headicon.icn b/ipl/progs/headicon.icn new file mode 100644 index 0000000..4a179e2 --- /dev/null +++ b/ipl/progs/headicon.icn @@ -0,0 +1,84 @@ +############################################################################ +# +# File: headicon.icn +# +# Subject: Program to add header to Icon program +# +# Author: Ralph E. Griswold +# +# Date: November 20, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program prepends a standard header to an Icon program. It does not +# check to see if the program already has a header. +# +# The first command-line argument is taken as the base +# name of the file; default "foo". The second command-line argument is +# taken as the author; the default is "Ralph E. Griswold" -- with minor +# apologies, I use this program a lot; personalize it for your own +# use. +# +# The new file is brought up in the vi editor. +# +# The file skeleton.icn must be accessible via dopen(). +# +############################################################################ +# +# Requires: system(), vi(1) +# +############################################################################ +# +# Links: datetime, io +# +############################################################################ + +link datetime +link io + +procedure main(args) + local name, author, input, output, line + + name := (args[1] | "foo") + if (*name < 4) | (name[-4:0] ~== ".icn") then name ||:= ".icn" + + author := args[2] | "Ralph E. Griswold" + + output := tempfile("head", , "/tmp") | + stop("*** cannot open temporary file") + + input := dopen("skeleton.icn") | stop("*** cannot open skeleton file") + + every 1 to 2 do + write(output, read(input)) | stop("*** short skeleton file") + write(output, read(input), name) | stop("*** short skeleton file") + every 1 to 3 do + write(output, read(input)) | stop("*** short skeleton file") + write(output, read(input), author) | stop("*** short skeleton file") + write(output, read(input)) | stop("*** short skeleton file") + write(output, read(input), date()) | stop("*** short skeleton file") + every 1 to 18 do + write(output, read(input)) | stop("*** short skeleton file") + + close(input) + + input := open(name) | stop("*** cannot open input file") + + while write(output, read(input)) + + close(output) + + image(output) ? { + ="file(" + output := tab(upto(')')) + } + + system("cp " || output || " " || name) + + system("vi " || name) + +end diff --git a/ipl/progs/hebcalen.icn b/ipl/progs/hebcalen.icn new file mode 100644 index 0000000..85f2ba1 --- /dev/null +++ b/ipl/progs/hebcalen.icn @@ -0,0 +1,615 @@ +############################################################################ +# +# File: hebcalen.icn +# +# Subject: Program for combination Jewish/Civil calendar +# +# Author: Alan D. Corre +# +# Date: January 3, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This work is respectfully devoted to the authors of two books +# consulted with much profit: "A Guide to the Solar-Lunar Calendar" +# by B. Elihu Rothblatt published by our sister Hebrew Dept. in +# Madison, Wis., and "Kiddush HaHodesh" by Rabbenu Moses ben Maimon, +# on whom be peace. +# +# The Jewish year harmonizes the solar and lunar cycle, using the +# 19-year cycle of Meton (c. 432 BCE). It corrects so that certain +# dates shall not fall on certain days for religious convenience. The +# Jewish year has six possible lengths, 353, 354, 355, 383, 384, and +# 385 days, according to day and time of new year lunation and +# position in Metonic cycle. Time figures from 6pm previous night. +# The lunation of year 1 is calculated to be on a Monday (our Sunday +# night) at ll:11:20pm. Our data table begins with a hypothetical +# year 0, corresponding to 3762 B.C.E. Calculations in this program +# are figured in the ancient Babylonian unit of halaqim "parts" of +# the hour = 1/1080 hour. +# +# Startup syntax is simply hebcalen [date], where date is a year +# specification of the form 5750 for a Jewish year, +1990 or 1990AD +# or 1990CE or -1990 or 1990BC or 1990BCE for a civil year. +# +############################################################################ +# +# Revised October 25, 1993 by Ralph E. Griswold to use dopen() to +# find data files. +# +############################################################################ +# +# Links: io +# +############################################################################ +# +# Requires: keyboard functions, hebcalen.dat, hebcalen.hlp +# +############################################################################ +# +# See also: hcal4unx.icn +# +############################################################################ + +link io + +record date(yr,mth,day) +record molad(day,halaqim) +global cyr,jyr,days_in_jyr,current_molad,current_day,infolist + +procedure main(cmd) + local n, p + + clear() + banner("PERPETUAL JEWISH/CIVIL CALENDAR","","by","","ALAN D. CORRE") + if *cmd = 0 then { +#putting an asterisk indicates that user might need help + n := 1; put(cmd,"*")} else + n := *cmd + every p := 1 to n do { + initialize(cmd[p]) + process()} +end + +procedure banner(l[]) +#Creates a banner to begin programs. If you don't have the extended ASCII +#character set, replace each char(n) with some character that you have +#such as " " or "-" +#Does not work well if your screen has variable spacing. +local n + write();write();write() + writes(char(201)) #top left right angle + writes(repl(char(205),78)) #straight line + writes(char(187)) #top right right angle + writes(char(186)) #upright line at left + writes(right(char(186),79)) #upright line at right + every n := 1 to *l do { + writes(char(186)) #upright line at left + writes(center(l[n],78),char(186)) #string centered followed by upright line + writes(char(186)) #upright line at left + writes(right(char(186),79)) #upright line at right +} + writes(char(200)) #bottom left right angle + writes(repl(char(205),78)) #straight line + write(char(188)) #bottom right right angle + write() +return +end + +procedure instructions(filename) +#Gives user access to a help file which is printed out in chunks. +local filvar,counter,line + writes("Do you need instructions? y/n ") + if upto('yY',read()) then { +#The following if-statement fails if the file is not available + counter := 0 + if filvar := dopen(filename) then +#Read the help file. + while line := read(filvar) do { +#Write out a line and increment the counter + write(line) + counter +:= 1 +#Now we have a screenful; ask if we should continue + if counter >22 then { + write() + writes ("More? y/n ") +#User has had enough; break out of loop + if upto('nN',read()) then break else +#User wants more; reset counter and continue + counter := 0}} else +#This else goes with the second if-statement; the attempt to open the +#help file failed: + write("Sorry, instructions not available.")} + write ("Press return to continue.") + read() +#Close the file if it existed and was opened. If it was never opened +#the value of filvar will be null. This check has to be made because +#an attempt to use close() on a variable NOT valued at a file would +#cause an error. +/filvar | close(filvar) +end + +procedure clear() +#clears the screen. If you don't have ANSI omit the next line + writes("\e[2J") +end + +procedure initialize_list() +#while user views banner, put info of hebcalen.dat into a global list +local infile,n + infolist := list(301) + if not (infile := dopen("hebcalen.dat")) then + stop("This program must have the file hebcalend.dat line in order to _ + function properly.") +#the table is arranged arbitrarily at twenty year intervals with 301 entries. + every n := 1 to 301 do + infolist[n] := read(infile) + close(infile) +end + +procedure initialize_variables() +#get the closest previous year in the table +local line,quotient + quotient := jyr.yr / 20 + 1 +#only 301 entries. Figure from last if necessary. + if quotient > 301 then quotient := 301 +#pull the appropriate info, put into global variables + line := infolist[quotient] + line ? { current_molad.day := tab(upto('%')) + move(1) + current_molad.halaqim := tab(upto('%')) + move(1) + cyr.mth := tab(upto('%')) + move(1) + cyr.day := tab(upto('%')) + move(1) + cyr.yr := tab(upto('%')) + days_in_jyr := line[-3:0] + } +#begin at rosh hashana + jyr.day := 1 + jyr.mth := 7 +return +end + +procedure initialize(yr) +local year +#initialize global variables +initial { cyr := date(0,0,0) + jyr := date(0,0,0) + current_molad := molad(0,0) + initialize_list()} + clear() +#user may need help + if yr == "*" then { + instructions("hebcalen.hlp") + clear() + writes("Please enter the year. If you are entering a CIVIL year, precede _ + by + for \ncurrent era, - (the minus sign) for before current era. ") + year := read()} else + year := yr + while not (jyr.yr := cleanup(year)) do { + writes("I do not understand ",year,". Please try again ") + year := read()} + clear() + initialize_variables() +return +end + +procedure cleanup(str) +#tidy up the string. Bugs still possible. + if (not upto('.+-',str)) & integer(str) & (str > 0) then return str + if upto('-bB',str) then return (0 < (3761 - checkstr(str))) + if upto('+cCaA',str) then return (checkstr(str) + 3760) +fail +end + +procedure checkstr(s) +#does preliminary work on string before cleanup() cleans it up +local letter,n,newstr + newstr := "" + every n := 1 to *s do + if integer(s[n]) then + newstr ||:= s[n] + if (*newstr = 0) | (newstr = 0) then fail +return newstr +end + +procedure process() + local ans, yj, n + +#gets out the information +local limit,dj,dc +#this contains a correction +#6039 is last year handled by the table in the usual way +#The previous line should read 6019. Code has been corrected to erase +#this mistake. + if jyr.yr <= 6019 then { + limit := jyr.yr % 20 + jyr.yr := ((jyr.yr / 20) * 20)} else { +#otherwise figure from 6020 and good luck +#This has been corrected to 6000 + limit := jyr.yr - 6000 + jyr.yr := 6000} + ans := "y" + establish_jyr() + every 1 to limit do { +#tell user something is going on + writes(" .") +#increment the years, establish the type of Jewish year + cyr_augment() + jyr_augment() + establish_jyr()} + clear() + while upto('Yy',ans) do { + yj := jyr.yr + dj := days_in_jyr + every n := 1 to 4 do { + clear() + every 1 to 3 do + write_a_month() + write("Press the space bar to continue") + write() + writes(status_line(yj,dj)) +#be sure that your version of Icon recognises the function getch() + getch()} + if jyr.mth = 6 then { + clear() + write_a_month() + every 1 to 15 do write() + write(status_line(yj,dj))} + write() + writes("Do you wish to continue? Enter y<es> or n<o>. ") +#be sure that your version of Icon recognises the function getch() + ans := getch()} +return +end + +procedure cyr_augment() +#Make civil year a year later, we only need consider Aug,Sep,Oct. +local days,newmonth,newday + if cyr.mth = 8 then + days := 0 else + if cyr.mth = 9 then + days := 31 else + if cyr.mth = 10 then + days := 61 else + stop("Error in cyr_augment") + writes(" .") + days := (days + cyr.day-365+days_in_jyr) + if isleap(cyr.yr + 1) then days -:= 1 +#cos it takes longer to get there + if days <= 31 then {newmonth := 8; newday := days} else + if days <= 61 then {newmonth := 9; newday := days-31} else + {newmonth := 10; newday := days-61} + cyr.mth := newmonth + cyr.day := newday + cyr.yr +:= 1 + if cyr.yr = 0 then cyr.yr := 1 +return +end + + +procedure header() +#creates the header for Jewish and English side. If ANSI not available, +#substitute "S" for "\e[7mS\e[0m" each time. + write(repl(" ",7),"S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W", + repl(" ",2),"T",repl(" ",2),"F",repl(" ",2),"\e[7mS\e[0m",repl(" ",27), + "S",repl(" ",2),"M",repl(" ",2),"T",repl(" ",2),"W", + repl(" ",2),"T",repl(" ",2),"F",repl(" ",2),"\e[7mS\e[0m") +end + +procedure write_a_month() +#writes a month on the screen + header() + every 1 to 5 do + write(make_a_line()) + if jyr.day ~= 1 then + write(make_a_line()) + write() +return +end + +procedure status_line(a,b) +#create the status line at the bottom of screen +local sline,c,d + c := cyr.yr + if (cyr.day = 1) & (cyr.mth = 1) then c -:= 1 + d := 365 + if isleap(c) then d := 366 +#if ANSI not available omit "\e[7m" and "|| "\e[0m"" + sline := ("\e[7mYear of Creation: " || a || " Days in year: " || b || + " Civil year: " || c || " Days in year: " || d || "\e[0m") +return sline +end + +procedure make_a_line() +#make a single line of the months +local line,blanks1,blanks2,start_point,end_point,flag,fm + +#consider the first line of the month + if jyr.day = 1 then { + line := mth_table(jyr.mth,1) +#setting flag means insert civil month at end of line + flag := 1 } else + line := repl(" ",3) +#consider the case where first day of civil month is on Sunday + if (cyr.day = 1) & (current_day = 1) then flag := 1 +#space between month name and beginning of calendar + line ||:= repl(" ",2) +#measure indentation for first line + line ||:= blanks1 := repl(" ",3*(current_day-1)) +#establish start point for Hebrew loop + start_point := current_day +#establish end point for Hebrew loop and run civil loop + every end_point := start_point to 7 do { + line ||:= right(jyr.day,3) + if not j_augment() then {jyr_augment(); establish_jyr(); current_day -:= 1; if current_day = 0 then current_day := 7} + d_augment() + if jyr.day = 1 then break } +#measure indentation for last line + blanks2 := repl(" ",3*(7-end_point)) + line ||:= blanks2; line ||:= repl(" ",25); line ||:= blanks1 + every start_point to end_point do { + line ||:= right(cyr.day,3) + if (cyr.day = 1) then flag := 1 + augment()} + line ||:= blanks2 ||:= repl(" ",3) + fm := cyr.mth + if cyr.day = 1 then + if cyr.mth = 1 then fm := 12 else fm := cyr.mth - 1 + if \flag then line ||:= mth_table(fm,2) else + line ||:= repl(" ",3) +return line +end + +procedure mth_table(n,p) +#generates the short names of Jewish and Civil months. Get to civil side +#by adding 13 (=max no of Jewish months) +static corresp +initial corresp := ["NIS","IYA","SIV","TAM","AV ","ELU","TIS","HES","KIS", +"TEV","SHE","ADA","AD2","JAN","FEB","MAR","APR","MAY","JUN","JUL","AUG","SEP", +"OCT","NOV","DEC"] + if (p ~= 1) & (p ~= 2) then stop("ERROR IN MTH-TABLE") else + if p = 2 then n +:= 13 +return corresp[n] +end + +procedure d_augment() +#increment the day of the week + current_day +:= 1 + if current_day = 8 then current_day := 1 +return +end + +procedure augment() +#increments civil day, modifies month and year if necessary, stores in +#global variable cyr + if cyr.day < 28 then + cyr.day +:= 1 else + if cyr.day = 28 then { + if (cyr.mth ~= 2) | ((cyr.mth = 2) & isleap(cyr.yr)) then + cyr.day := 29 else { + cyr.mth := 3 + cyr.day := 1}} else + if cyr.day = 29 then { + if cyr.mth ~= 2 then + cyr.day := 30 else { + cyr.mth := 3 + cyr.day := 1}} else + if cyr.day = 30 then { + if is_31(cyr.mth) then + cyr.day := 31 else { + cyr.mth +:= 1 + cyr.day := 1}} else { + cyr.day := 1 + if cyr.mth ~= 12 then + cyr.mth +:= 1 else { + cyr.mth := 1 + cyr.yr +:= 1 + if cyr.yr = 0 + then cyr.yr := 1}} +return +end + +procedure is_31(n) +#civil months with 31 days +return n = 1 | n = 3 | n = 5 | n = 7 | n = 8 | n = 10 | n = 12 +end + +procedure isleap(n) +#checks for civil leap year + if n > 0 then +return (n % 400 = 0) | ((n % 4 = 0) & (n % 100 ~= 0)) else +return (n % 400 = -1) | ((n % 4 = -1) & (n % 100 ~= -1)) +end + +procedure j_augment() +#increments jewish day. months are numbered from nisan, adar sheni is 13. +#procedure fails at elul to allow determination of type of new year + if jyr.day < 29 then + jyr.day +:= 1 else + if (jyr.day = 30) | always_29(jyr.mth) | ((jyr.mth = 8) & + (days_in_jyr % 5 ~= 0)) | ((jyr.mth = 9) & ((days_in_jyr = 353) | + (days_in_jyr = 383))) then + jyr.mth +:= jyr.day := 1 else + if jyr.mth = 6 then fail else + if ((jyr.mth = 12) & (days_in_jyr < 383)) | (jyr.mth = 13) then + jyr.mth := jyr.day := 1 else + jyr.day := 30 +return +end + +procedure always_29(n) +#uncomplicated jewish months with 29 days +return n = 2 | n = 4 | n = 10 +end + +procedure jyr_augment() +#determines the current time of lunation, using the ancient babylonian unit +#of 1/1080 of an hour. lunation of tishri determines type of year. allows +#for leap year. halaqim = parts of the hour +local days, halaqim + days := current_molad.day + 4 + if days_in_jyr <= 355 then { + halaqim := current_molad.halaqim + 9516 + days := ((days +:= halaqim / 25920) % 7) + if days = 0 then days := 7 + halaqim := halaqim % 25920} else { + days +:= 1 + halaqim := current_molad.halaqim + 23269 + days := ((days +:= halaqim / 25920) % 7) + if days = 0 then days := 7 + halaqim := halaqim % 25920} + current_molad.day := days + current_molad.halaqim := halaqim +#reset the global variable which holds the current jewish date + jyr.yr +:= 1 #increment year + jyr.day := 1 + jyr.mth := 7 + establish_jyr() +return +end + +procedure establish_jyr() +#establish the jewish year from get_rh +local res + res := get_rh(current_molad.day,current_molad.halaqim,no_lunar_yr(jyr.yr)) + days_in_jyr := res[2] + current_day := res[1] +return +end + +procedure isin1(i) +#the isin procedures are sets of years in the Metonic cycle +return i = (1 | 4 | 7 | 9 | 12 | 15 | 18) +end + +procedure isin2(i) +return i = (2 | 5 | 10 | 13 | 16) +end + +procedure isin3(i) +return i = (3 | 6 | 8 | 11 | 14 | 17 | 0) +end + +procedure isin4(i) +return i = (1 | 2 | 4 | 5 | 7 | 9 | 10 | 12 | 13 | 15 | 16 | 18) +end + +procedure isin5(i) +return i = (1 | 4 | 9 | 12 | 15) +end + +procedure isin6(i) +return i = (2 | 5 | 7 | 10 | 13 | 16 | 18) +end + +procedure no_lunar_yr(i) +#what year in the metonic cycle is it? +return i % 19 +end + +procedure get_rh(d,h,yr) +#this is the heart of the program. check the day of lunation of tishri +#and determine where breakpoint is that sets the new moon day in parts +#of the hour. return result in a list where 1 is day of rosh hashana and +#2 is length of jewish year +local c,result + c := no_lunar_yr(yr) + result := list(2) + if d = 1 then { + result[1] := 2 + if (h < 9924) & isin4(c) then result[2] := 353 else + if (h < 22091) & isin3(c) then result[2] := 383 else + if (h > 9923) & (isin1(c) | isin2(c)) then result[2] := 355 else + if (h > 22090) & isin3(c) then result[2] := 385 + } else + if d = 2 then { + if ((h < 16789) & isin1(c)) | + ((h < 19440) & isin2(c)) then { + result[1] := 2 + result[2] := 355 + } else + if (h < 19440) & isin3(c) then { + result[1] := 2 + result[2] := 385 + } else + if ((h > 16788) & isin1(c)) | + ((h > 19439) & isin2(c)) then { + result[1] := 3 + result[2] := 354 + } else + if (h > 19439) & isin3(c) then { + result[1] := 3 + result[2] := 384 + } + } else + if d = 3 then { + if (h < 9924) & (isin1(c) | isin2(c)) then { + result[1] := 3 + result[2] := 354 + } else + if (h < 19440) & isin3(c) then { + result[1] := 3 + result[2] := 384 + } else + if (h > 9923) & isin4(c) then { + result[1] := 5 + result[2] := 354 + } else + if (h > 19439) & isin3(c) then { + result[1] := 5 + result[2] := 383} + } else + if d = 4 then { + result[1] := 5 + if isin4(c) then result[2] := 354 else + if h < 12575 then result[2] := 383 else + result[2] := 385 + } else + if d = 5 then { + if (h < 9924) & isin4(c) then { + result[1] := 5 + result[2] := 354} else + if (h < 19440) & isin3(c) then { + result[1] := 5 + result[2] := 385 + } else + if (9923 < h < 19440) & isin4(c) then { + result[1] := 5 + result[2] := 355 + } else + if h > 19439 then { + result[1] := 7 + if isin3(c) then result[2] := 383 else + result[2] := 353 + } + } else + if d = 6 then { + result[1] := 7 + if ((h < 408) & isin5(c)) | ((h < 9924) & isin6(c)) then + result[2] := 353 else + if ((h < 22091) & isin3(c)) then result[2] := 383 else + if ((h > 407) & isin5(c)) | ((h > 9923) & isin6(c)) then + result[2] := 355 else + if (h > 22090) & isin3(c) then result[2] := 385 + } else + if d = 7 then if (h < 19440) & (isin5(c) | isin6(c)) then { + result[1] := 7 + result[2] := 355 + } else + if (h < 19440) & isin3(c) then { + result[1] := 7 + result[2] := 385 + } else { + result[1] := 2 + if isin4(c) then + result[2] := 353 else + result[2] := 383} +return result +end diff --git a/ipl/progs/hebeng.icn b/ipl/progs/hebeng.icn new file mode 100644 index 0000000..5dca84a --- /dev/null +++ b/ipl/progs/hebeng.icn @@ -0,0 +1,297 @@ +############################################################################ +# +# File: hebeng.icn +# +# Subject: Program to print mixed Hebrew/English text +# +# Author: Alan D. Corre +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is written in ProIcon for the Macintosh computer. Alan D. Corre +# August 1991. It takes input in a transcription of Hebrew which represents +# current pronunciation adequately but mimics the peculiarities of Hebrew +# spelling. Here are some sentences from the beginning of Agnon's story +# "Friendship": marat qliyngel 'i$ah mefursemet haytah umenahelet beyt sefer +# haytah qowdem liymowt hamilHamah. mi$eni$tanu sidrey ha`owlam,neHtexah +# migdulatah..wexol miy $eyac'u low mowniyTiyn ba`owlam haytah mitqarevet +# 'eclow weyowce't wenixneset leveytow" The letter sin is represented by the +# German ess-zed which is alt-s on the Mac and cannot be represented here. +# The tilde (~)toggles between English and Hebrew, so the word "bar" will be +# the English word "bar" or the Hebrew beyt-rey$ according to the current +# mode of the program. Finals are inserted automatically. Justification +# both ways occurs unless the program detects a blank or empty line, in +# which case the previous line is not justified. +# Since I took out non-ASCII chars, and have not rechecked that this +# works with the corresponding octal chars, there could be some slips in +# this text. +# +############################################################################ +# +# Requires: ProIcon +# +############################################################################ + +$ifdef _MACINTOSH + +global outfilename, outvar, outwin,hebrew_string_flag, hebrew_text_flag, + screenwidth,screenheight,markers + +procedure main() +#message() creates a standard Mac message box + if message("Do you wish to create a new text or print an old one?","New", + "Old") then newtext() else + oldtext() +#Empty and hide the interactive window + wset(0,5) + wset(0,0) +end + + +procedure newtext() + set_markers() + get_info() + get_screensize() + create_file() + go() +end + +procedure oldtext() +#getfile() allows selection of a file already available + outfilename := getfile("Please select file.",,) +#attempt to open a window with the name of the file + if not (outwin := wopen(outfilename,"f")) then stop() +#put a font in this window which has Hebrew letters in high ASCII numbers + wfont(outwin,"Ivrit") +#use 12-point + wfontsize(outwin,12) +#show the window. The user wishing to edit must make the window active +#and use the appropriate alt keys to edit the Hebrew text. This is not +#necessary when using the transcription initially + wset(outwin,1) + if message("Do you wish to edit? (Press return when through editing.)","Yes","No") then + read() + if message("Do you wish to print?","Yes","No") then +#send the window to the printer if the user desires + wprint(outwin,1,1) +end + +procedure set_markers() +#five letters preceding these characters take a special final shape + markers := ' ,.;:-\324\"?)]}' +end + + +procedure get_info() +local dimlist + outfilename := gettext("What is the name of your output file?",,"Cancel") + if /outfilename then stop() +#the program has to know what is the principal language in order to leave +#blanks at paragraph endings properly. When the text flag is set, then the +#program overall is operating in Hebrew mode. When the string flag is set +#the current string is Hebrew + if message("What is the principal language of the text?","Hebrew","English") then + hebrew_string_flag := hebrew_text_flag := 1 + if \hebrew_text_flag then { + if not message("The principal language used is Hebrew.","Okay","Cancel") then + stop()} else + if not message("The principal language used is English.","Okay","Cancel") then + stop() +end + +procedure get_screensize() +local dimlist +#&screen is a list. Work with the old standard mac screen + dimlist := &screen + screenheight := dimlist[3] + screenwidth := dimlist[4] + if screenwidth > 470 then screenwidth := 470 +end + + +procedure create_file() +#arrange the various fonts and sizes + outwin := wopen(outfilename,"n") + outvar := open(outfilename,"w") + wsize(0,screenwidth,(screenheight / 2 - 40)) + wsize(outwin,screenwidth,(screenheight / 2 - 40)) + wfont(outwin,"Ivrit") + wfontsize(outwin,12) + wfont(0,"Geneva") + wfontsize(0,12) +#position windows + wmove(0,0,40) + wmove(outwin,0,screenheight / 2 + 20) + wset(outwin,1) #show the output window +end + +procedure process(l) +local cursor,substring,newline +if *l = 0 then return " " + cursor := 1 + newline := "" +#look for a tilde, and piece together a new line accordingly + l ? while substring := tab(upto('~')) do { + move(1) + if \hebrew_string_flag then substring := hebraize(substring) + if /hebrew_text_flag then newline ||:= substring else + newline := (substring || newline) +#string flag toggle + (/hebrew_string_flag := 1) | (hebrew_string_flag := &null) + cursor := &pos} + substring := l[cursor:0] + if \hebrew_string_flag then substring := hebraize(substring) + if /hebrew_text_flag then newline ||:= substring else + newline := (substring || newline) +return newline +end + +procedure justify(l) +#doesn't give perfect right justification, but its good enough +local stringlength,counter,n,increment,newline + stringlength := wtextwidth(outwin,l) + newline := l + increment := 1 + while stringlength < screenwidth do { + counter := 0 + l ? every n := upto(' ') do { + newline[n + (counter * increment)] := " " + counter +:= 1 + stringlength +:= 4 + if stringlength >= screenwidth then break} + increment +:= 1} +return newline +end + +procedure go() +#the appearance of the Hebrew/English window lags one line behind the +#input window +local line,line2,counter,mess + counter := 0 + line := read() +#octal 263 is option-period. + if line == "\263" then stop() + while (line2 := read()) ~== "\263" do { + counter +:= 1 + if ((not match(" ",line2)) & (*line2 ~= 0)) then + line := justify(process(line)) else + if /hebrew_text_flag then line := process(line) else + line := rt(process(line)) + if (wtextwidth(outwin,line) - screenwidth) > 10 then { + mess := "Warning. Line " || counter || " is " || (wtextwidth(outwin,line) - + screenwidth) || " pixels too long." + message(mess,"Okay","")} + write(outvar,line) + line := line2} + if /hebrew_text_flag then line := process(line) else + line := rt(process(line)) + if (wtextwidth(outwin,line) - screenwidth) > 10 then { + mess := "Warning. Last Line is " || (wtextwidth(outwin,line) - + screenwidth) || " pixels too long." + message(mess,"Okay","")} + write(outvar,line) + if message("Do you wish to print?","Yes","No") then wprint(outwin,1,1) + close(outvar) + wclose(outwin,"") +end + +procedure hebraize(l) +static s2,s3 +#' is used for aleph. For the abbreviation sign use either alt-] which gives +#an appropriate sign, or alt-' which is easier to remember but gives a funny +#looking digraph on the screen + initial{ s2 := "u\'\276\324bvgdhwzHTykKlmMnNs`pfFcCqr$\247tx\261\335(){}[]X" + s3 := "\267\324\'\'\272\272\355\266\372\267\275\305\303\264\373\373\302\265_ + \265\176\176\247\322\304\304\304\215\215\317\250\246\244\240_ + \373+$)(}{][\373"} +#the following (1) inserts initial aleph in case the student has forgotten it +#(2) takes care of final x with vowel (all other finals are vowelless in +#modern Hebrew (3) takes out vowels except u which is usually represented in +#modern Hebrew (4) takes care of other finals (5) converts to Hebrew letters +#(6) reverses to Hebrew direction + l := reverse(map(finals(devowel(xa(aleph(l)))),s2,s3)) +return l +end + +procedure aleph(l) +#inserts an aleph in words beginning with vowels only +#this alters the duplicate line; compare procedure devowel which rebuilds +#the line from scratch +local newl,offset + newl := l + offset := 0 + if upto('aeiou',l[1]) then { + offset +:= 1 + newl[1] := ("\'" || l[1])} + l ? while tab(upto(' ')) do { + tab(many(' ')) + if upto('aeiou',l[&pos]) then { + newl[&pos + offset] := ("\'" || l[&pos]) + offset +:= 1}} +return newl +end + +procedure xa(s) +#takes care of the special case of final xa +local substr,newstr + newstr := "" + s ||:= " " + s ? {while substr := tab(find("xa")) || move(2) || tab(any(markers)) do { + substr[-3] := char(170) + newstr ||:= substr} + newstr ||:= s[&pos:-1]} +return newstr +end + + +procedure finals(l) +#arranges the final letters +static finals,corresp +local newline +initial {finals := 'xmncf' + corresp := table("") + corresp["x"] := "\301" + corresp["m"] := "\243" + corresp["n"] := "\242" + corresp["f"] := "\354" + corresp["c"] := "\260"} + newline := l + l ? while tab(upto(finals)) do { + move(1) + if (any(markers)) | (&pos = *l + 1) then + newline[&pos - 1] := corresp[l[&pos - 1]] + } +return newline +end + +procedure rt(l) +#for right justification; chars are of different size +local stringlength,newline + stringlength := wtextwidth(outwin,l) + newline := l + if (screenwidth-stringlength) > 0 then + newline := (repl(" ",(screenwidth-stringlength +2) / 4) || l) +return newline +end + +procedure devowel(l) +local newline,substring + newline := "" + l ? {while substring := tab(upto('aeio')) do { + newline ||:= substring + move(1)} + newline ||:= l[&pos:0]} +return newline +end + +$else # not Macintosh +procedure main() + stop("sorry, ", &progname, " only runs under Macintosh ProIcon") +end +$endif diff --git a/ipl/progs/hotedit.icn b/ipl/progs/hotedit.icn new file mode 100644 index 0000000..16f58d4 --- /dev/null +++ b/ipl/progs/hotedit.icn @@ -0,0 +1,101 @@ +############################################################################ +# +# File: hotedit.icn +# +# Subject: Program to edit a Mosaic hotlist +# +# Author: Gregg M. Townsend +# +# Date: June 23, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# ===> IMPORTANT NOTE: This program was written for "NCSA Mosaic 2.4" +# ===> and is incompatible with the current version of Mosaic. +# +# Hotedit makes it easy to edit the "hotlist" used with NCSA Mosaic, +# a program for grazing the Wide World Web (WWW). The Mosaic hotlist +# is a text file, and it can be edited directly, but this is difficult +# and error-prone. Pairs of lines must be kept together, and the long +# "Uniform Record Locator" (URL) lines make it hard to pick out the +# title lines, which are of more interest. +# +# Hotedit works by extracting the titles, bringing up an editor of the +# user's choice, then processing the results when the editor exits. +# The user can reorder, retitle, or delete lines; adding new entries +# is best done within NCSA Mosaic. It is vital that any editing +# preserve the three-digit number at the front of each line; hotedit +# uses this to reconnect the titles with the corresponding URLs. +# +# The editor is determined by the environment variable VISUAL (or, if +# that is missing, EDITOR). The hotlist file is assumed to be in the +# usual place, $HOME/.mosaic-hotlist-default. Because not all editors +# return a reasonable exit status, the hotlist is *always* rewritten; +# the previous edition is saved in $HOME/.mosaic-hotlist-backup. +# +# Hotedit shouldn't be run while NCSA Mosaic is running; when Mosaic +# exits, it is likely to overwrite the edited hotlist. +# +############################################################################ +# +# Requires: Unix, NCSA Mosaic +# +############################################################################ + +$define TMPFILE "hotlist.tmp" +$define HOTFILE ".mosaic-hotlist-default" +$define HOTOLD ".mosaic-hotlist-backup" +$define HOTNEW ".mosaic-hotlist-revised" +$define HOTFORMAT "ncsa-xmosaic-hotlist-format-1" + +procedure main() + local home, f, t, line, n, editor, command, urllist + + home := getenv("HOME") | stop("no $HOME value") + chdir(home) | stop("can't chdir to ", home) + + f := open(HOTFILE) | stop("can't open ", HOTFILE) + line := read(f) | stop("empty hotlist file") + line == HOTFORMAT | stop("unrecognized hotlist format") + line := read(f) | stop("truncated hotlist file") + line == "Default" | stop("unrecognized hotlist format") + + t := open(TMPFILE, "w") | stop("can't write ", TMPFILE) + + urllist := [] + while put(urllist, read(f)) do { + line := read(f) | stop("ill-formated hotlist file") + if *urllist < 1000 then + n := right(*urllist, 3, "0") + else + n := *urllist + write(t, n, " ", line) + } + close(f) + close(t) + + f := open(HOTNEW, "w") | stop("can't write ", HOTNEW) + + editor := getenv("VISUAL") | getenv("EDITOR") | "/bin/vi" + command := editor || " " || TMPFILE + + system(command) + + t := open(TMPFILE) | stop("can't reopen ", TMPFILE) + write(f, HOTFORMAT) + write(f, "Default") + while line := read(t) do line ? { + if write(f, urllist[tab(many(&digits))]) then + write(f, move(1) & tab(0)) + else + write(&errout, "invalid index: ", line) + } + + remove(HOTOLD) + (rename(HOTFILE, HOTOLD) & rename(HOTNEW, HOTFILE)) | + stop("couldn't rename files; new file left in ", HOTNEW) +end diff --git a/ipl/progs/hr.icn b/ipl/progs/hr.icn new file mode 100644 index 0000000..90a22a2 --- /dev/null +++ b/ipl/progs/hr.icn @@ -0,0 +1,793 @@ +############################################################################ +# +# File: hr.icn +# +# Subject: Program to play horse-race game +# +# Author: Chris Tenaglia +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program implements a horse-race game. +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +global horse1, horse2, horse3, # horses are global + players, money, bets, # player info is global + vectors, leg1, leg2, leg3, # track parameters + front, back, y1 , y2, y3, # horse parameters + pos1, pos2, pos3, # more horse parameters + oops1, oops2, oops3 # accident flags + +procedure main() + local winner + +banner() +if ready() == "no" then stop("Game Over.") # ask if ready +players := get_players() # get player name list +money := table(100) # everyone starts w/$100 +randomize() + +repeat + { + if ready() == "no" then break + writes("\e[2J\e[H") # clear old junk off screen + repeat # choose 3 fresh horses + { + horse1 := get_horse() # get first horse list + horse2 := get_horse() # get second horse list + horse3 := get_horse() # get third horse list + if horse1[1] == horse2[1] | # disallow duplicates + horse2[1] == horse3[1] | # because a horse can't + horse3[1] == horse1[1] then next # race against himself + break # continue... + } + bets := get_bet() # bets initially 0 + winner := race() # race the horses, get winner + pay(winner) # pay winner(s) if any + } +done() +end +# +# +# ask if ready to play the game, return yes or no +# +procedure ready() + local answer + static pass,sh + initial { + pass := 0 # initialize pass counter + sh := "\e[1;7m \e[0;1;33;44m" # initialize a shadow for box + } + if (pass +:= 1) = 1 then + { + writes("\e[0;1;33;44m\e[2J\e[H") + write(" +----------------------------------------------------------+") + write(" | WELCOME TO ICON PARK VIRTUAL RACE TRACK |",sh) + write(" | |",sh) + write(" | The following game allow one or more players to bet on |",sh) + write(" | three Cyberspace steeds that will run on an ANSI VT100 |",sh) + write(" | dirt track. Of course the bets are Cyberspace dollars, |",sh) + write(" | which have no real world value. We use only the oldest |",sh) + write(" | escape sequences to condition the track surface, which |",sh) + write(" | may not appeal to TEK crowds, and I'm sure some fans |",sh) + write(" | will hurl curses. C'est la vie! |",sh) + write(" | |",sh) + write(" +----------------------------------------------------------+",sh) + write(" \e[1;7m \e[0;1;33;44m") + write("") + write(" Are we ready to enter our names, and begin?") + answer := map(input("Enter yes or no:")) + if answer[1] == "n" then return "no" else return "yes" + } + end + +# +# get the names of the players +# +procedure get_players() + local counter, people, who + people := [] + counter := 1 + write("\nEnter Player Names. Enter blank when done.") + repeat + { + (who := input(" Player #" || counter || ":")) | break + if trim(who) == "" then break + put(people,who) + counter +:= 1 + } + if *people < 1 then stop("Not enough players. Need at least one.") + return people + end +# +# +# build a horse list structure +# +procedure get_horse() + local odds, pic, tmp + static stable,photos + initial { + photos := [pick1(),pick2(),pick3(), + pick4(),pick5(),pick6()] + stable := ["Incredible Hash", + "Random Number", + "Floppy Crash", + "RAM Dump", + "Programmers Nightmare", + "Spaghetti Code", + "Infinite Loop", + "User Blues", + "See Plus Plus", + "Press Any Key", + "Paradigm Shift", + "Adricks' Abend", + "Client Server", + "Network Storm", + "Mr. Cobol", + "Forgotten Password", + "Hackers' Byte", + "Chad Hollerith", + "ASCII Question", + "EBCDIC Object", + "Recursive Instance", + "RunTime Error"] + } + name := ?stable # pick a horse name + odds := 1 + real((?30)/real(10.0)) # calculate the odds + tmp := ?photos # choose a photo file + pic := [name,odds] + every put(pic,!tmp) + return pic + end +# +# +# obtain bets from the players +# +procedure get_bet() + local items, person, summation, wager + (&features == "MS-DOS") | writes("\e[?25h") + bets := table(0) + summation := 0 + every person := !players do + { + if money[person] <= 0 then next + summation +:= money[person] + write("\e[2J\e[H",person,", enter your bet. You have $",money[person],"\n") + write("1. ",left(horse1[1],32)," odds = ",horse1[2]," : 1") + write("2. ",left(horse2[1],32)," \" = ",horse2[2]," : 1") + write("3. ",left(horse3[1],32)," \" = ",horse3[2]," : 1") + write("\n (enter 5 on 2 for $5 on ",horse2[1],")\n") + wager := trim(map(input("Your decision : "))) + if wager == "" then next + if wager == "q" then done() + items := parse(wager,' ') + if not(numeric(items[1])) | not(numeric(items[3])) then + { + input("\7Wager Improperly Entered. No wager made. Press RETURN") + next + } + if (*items ~= 3) | + (items[2] ~== "on") | + (items[1] > money[person]) | + (1 > items[3] > 3) then + { + input("\7Wager Improperly Entered. No wager made. Press RETURN") + next + } + bets[person] := wager + money[person] -:= parse(wager,' ')[1] + } + if summation = 0 then + { + write("\e[2J\e[HICON PARK CYBER RACE TRACK BIDS YOU ADIEU\n") + write("It looks you'all lost all your money here today.") + write("Take it easy now. Better luck next time") + stop("Game Over") + } + input("Done Entering Wagers. Press RETURN to Continue.") + end +# +# +# determine the victor and pay out winnings. if there is a tie +# then nothing gets payed out (bets are refunded) +# +procedure pay(victor) + local check, i, msg, nag, odds, pair, player, prize, test + local wager, winner, winnings, y + + (&features == "MS-DOS") | writes("\e[?25h") # turn on cursor again + winner := case victor of + { + 1 : horse1 + 2 : horse2 + 3 : horse3 + default : ["tie"] + } + if victor = 4 then + { + writes(at(12,14),"All The Steeds Fell Down! Too many injuries!\7") + wait(1) + writes(at(12,14),"The judges are coming to a decision....") + wait(2) + writes(at(12,14),"All bets will be refunded. Sorry.......") + check := sort(bets,1) + every pair := !check do + { + name := pair[1] + wager := pair[2] + odds := winner[2] + prize := parse(bets[name],' ')[1] + money[name] +:= integer(prize) + } + test := map(input(at(13,1) || "Press RETURN to Continue.")) + if test[1] == "q" then done() + return + } + if winner[1] == "tie" then + { + writes(at(12,14),"It was a photo finish!\7") + wait(1) + writes(at(12,14),"The judges are coming to a decision....") + wait(2) + writes(at(12,14),"All bets will be refunded. Sorry.......") + check := sort(bets,1) + every pair := !check do + { + name := pair[1] + wager := pair[2] + odds := winner[2] + prize := parse(bets[name],' ')[1] + money[name] +:= integer(prize) + } + test := map(input(at(13,1) || "Press RETURN to Continue.")) + if test[1] == "q" then done() + return + } else { + writes(at(12,14),winner[1]," WINS! ") + writes(at(victor+21,1),"\e[1;5;33;44m",victor," : ",left(winner[1],32),"\e[0;1;33;44m") + wait(2) + writes(at(12,14),"And now for a closeup of the winner....") + wait(3) + y := 4 + writes(at((y+:=1),40),"+",repl("-",35),"+") + every i := 3 to *winner do + writes(at((y+:=1),40),"|",left(winner[i],35),"|") + writes(at(y,40),"+",repl("-",35),"+") + } + check := sort(bets,1) + every pair := !check do + { + name := pair[1] + wager := pair[2] + nag := parse(wager,' ')[3] + if nag = victor then + { + odds := winner[2] + prize := odds * parse(bets[name],' ')[1] + money[name] +:= integer(prize) + } + } + test := map(input(at(13,1) || "Press RETURN to Continue.")) + if test[1] == "q" then + { + # + # evaluate results from todays races + # + write("\e[2J\e[HICON PARK CYBER RACE TRACK BIDS YOU ADIEU\n") + write(" We all started with $100. And now for the results...\n") + every player := !players do + { + winnings := money[player] + if winnings < 100 then msg := "Looks like you lost some $ today." + if winnings = 0 then msg := "Lost all your money today." + if winnings = 100 then msg := "Looks like you broke even today." + if winnings > 100 then msg := "Looks like a winner. Stop at the IRS window please!" + if winnings > 300 then msg := "Wow! The IRS agent will escort you to his office." + write("OK ",player,", you have $",winnings," left. ",msg) + } + } + end +# +# +# run the race and return the winning horse # (1, 2, or 3) +# +procedure race() + local diamx, diamy, finish, inc1, inc2, inc3, platform, result + + vectors := draw_track() + # + # set up starting positions + # + pos1 := 1 + pos2 := 1 + pos3 := 1 + + # + # select lanes to run in + # + y1 := 5 + y2 := 7 + y3 := 9 + + # + # set up for the legs of the race, 3 normal + 3 accidentsal + # + leg1 := 1 + leg2 := 1 + leg3 := 1 + + # + # set up accident multipliers + # + oops1 := 1 + oops2 := 1 + oops3 := 1 + + # + # designate vector milestones, marking legs of the race + # + diamx := 68 + diamy := 10 + finish := 146 + + # + # design horse bodies from different vantage points + # + front := list(6) + front[1] := "#^" + front[2] := "V" + front[3] := "#' " + front[4] := "_X " + front[5] := "X" + front[6] := "_X " + + back := list(6) + back[1] := " `#" + back[2] := "/" + back[3] := "^#" + back[4] := " X_" + back[5] := "X" + back[6] := " X_" + + # + # display the starting positions and fire the gun to begin! + # + (&features == "MS-DOS") | writes("\e[?25l") # deactivate cursor + writes(at(5,1),back[1],1,front[1]) # horse 1 + writes(at(22,6),left(horse1[1],32)," / ",horse1[2]," : 1 / ") + + writes(at(7,1),back[1],2,front[1]) # horse 2 + writes(at(23,6),left(horse2[1],32)," / ",horse2[2]," : 1 / ") + + writes(at(9,1),back[1],3,front[1]) # horse 3 + writes(at(24,6),left(horse3[1],32)," / ",horse3[2]," : 1 / ") + + writes(at(12,14),"ON YOUR MARK... GET SET...") + wait(1) + writes("\7",at(12,14),"AND THEY'RE OFF! ") + # + # run the race + # + repeat + { + case &features of + { + "VMS" : delay(500) # delay 10,000/sec VMS + "UNIX": delay(50) # delay 1,000/sec UNIX + default : platform := &features # not on DOS icon 8.5 + } + inc1 := ?3-1 * oops1 + if oops1 = 1 then pos1 +:= inc1 + + inc2 := ?3-1 * oops2 + if oops2 = 1 then pos2 +:= inc2 + + inc3 := ?3-1 * oops3 + if oops3 = 1 then pos3 +:= inc3 + + if (pos1 >= 68) & (leg1 = 1) then leg1 := 2 + if (pos2 >= 68) & (leg2 = 1) then leg2 := 2 + if (pos3 >= 68) & (leg3 = 1) then leg3 := 2 + if (pos1 > 78) & (leg1 = 2) then leg1 := 3 + if (pos2 > 78) & (leg2 = 2) then leg2 := 3 + if (pos3 > 78) & (leg3 = 2) then leg3 := 3 + + if (78 >= pos1 >= 68) then y1 +:= inc1 + if (78 >= pos2 >= 68) then y2 +:= inc2 + if (78 >= pos3 >= 68) then y3 +:= inc3 + + if y1 > 15 then y1 := 15 + if y2 > 17 then y2 := 17 + if y3 > 19 then y3 := 19 + + result := accident() + display() + + if result = 0 then return 4 + if (pos1 >= finish) & (pos2 < finish) & (pos3 < finish) then return 1 + if (pos2 >= finish) & (pos1 < finish) & (pos3 < finish) then return 2 + if (pos3 >= finish) & (pos1 < finish) & (pos2 < finish) then return 3 + + if (pos1 >= finish) & (pos2 >= finish) | + (pos2 >= finish) & (pos3 >= finish) | + (pos3 >= finish) & (pos1 >= finish) then return 0 + } + end +# +# +# display the horses at different legs of the race +# +procedure display() + static oldy1,oldy2,oldy3,blanks + initial { + oldy1 := 5 + oldy2 := 7 + oldy3 := 9 + blanks:= " " + } + if leg1 = 2 then + { + writes(at(5,68),blanks) + writes(at(oldy1,68),blanks) + if y1 < 12 then + { + writes(at(y1,68)," ",back[2]," ") + writes(at(y1+1,68)," 1 ") + writes(at(y1+2,68)," ",front[2]," ") + } + oldy1 := y1 + } else { + writes(at(y1,vectors[pos1]),back[leg1],1,front[leg1]) + } + + if leg2 = 2 then + { + writes(at(7,68),blanks) + writes(at(oldy2,68),blanks) + if y2 < 14 then + { + writes(at(y2,69)," ",back[2]," ") + writes(at(y2+1,69)," 2 ") + writes(at(y2+2,69)," ",front[2]," ") + } + oldy2 := y2 + } else { + writes(at(y2,vectors[pos2]),back[leg2],2,front[leg2]) + } + if leg3 = 2 then + { + writes(at(9,68),blanks) + writes(at(oldy3,68),blanks) + if y3 < 16 then + { + writes(at(y3,70)," ",back[2]," ") + writes(at(y3+1,70)," 3 ") + writes(at(y3+2,70)," ",front[2]," ") + } + oldy3 := y3 + } else { + writes(at(y3,vectors[pos3]),back[leg3],3,front[leg3]) + } + end + +# +# simulate rare freakish accidents +# +procedure accident() + if (?2000 = 111) & (leg1 ~= 2) then + { + oops1 := 0 + leg1 +:= 3 + write(at(13,1),"\7OH NO! ",horse1[1]," fell down!") + } + + if (?2000 = 111) & (leg2 ~= 2) then + { + oops2 := 0 + leg2 +:= 3 + write(at(13,1),"\7OH NO! ",horse2[1]," fell down!") + } + + if (?2000 = 111) & (leg3 ~= 2) then + { + oops3 := 0 + leg3 +:= 3 + write(at(13,1),"\7OH NO! ",horse3[1]," fell down!") + } + + if oops1+oops2+oops3 = 0 then return 0 + return 1 + end +# +# +# return a list of track x positions +# +procedure draw_track() + local i, offset + static pavement + initial pavement := copy(mktrack()) + offset := [] + every i := 1 to 68 do put(offset,i) + every i := 1 to 10 do put(offset,72) + every i := 68 to 1 by -1 do put(offset,i) + offset |||:= [1,1,1,1,1] + writes("\e[0;1;33;44m\e[2J\e[H") + every i := 1 to *pavement do + writes(at(i,1),pavement[i]) + return offset + end + +# +# generate racing track +# +procedure mktrack() + local track + track := [] + put(track," WELCOME TO ICON PARK CYBER STEED RACE TRACK") + put(track,"") + put(track,"___________________________________________________________________________") + put(track," \\") + put(track,"`#1#^ \\") + put(track," \\") + put(track,"`#2#^ \\") + put(track," |") + put(track,"`#3#^ |") + put(track,"_________________________________________________________________ |") + put(track," \\ |") + put(track,"Commentator: | |") + put(track," | |") + put(track,"_________________________________________________________________/ |") + put(track," |") + put(track," |") + put(track," /") + put(track," /") + put(track," /") + put(track," /") + put(track,"__________________________________________________________________________/") + put(track,"1 :") + put(track,"2 :") + put(track,"3 :") + return track + end + +# +# final wrapup procedure, summarize winnings +# +procedure done() + local msg, player, winnings + write("\e[2J\e[HICON PARK CYBER RACE TRACK BIDS YOU ADIEU\n") + write(" We all started with $100. And now for the results...\n") + every player := !players do + { + winnings := money[player] + if winnings < 100 then msg := "\nLooks like you lost some $ today.\n" + if winnings = 100 then msg := "\nLooks like you broke even today.\n" + if winnings > 100 then msg := "\nLooks like a winner. Stop at the IRS window please!\n" + write("OK ",player,", you have $",winnings," left. ",msg) + } + stop("Game Over.") + end +# +# +# generate horse 1 portraite +# +procedure pick1() + local pferd + + pferd := [] + put(pferd,"") + put(pferd," /\\") + put(pferd," |||/ \\") + put(pferd," / \\\\") + put(pferd," / \\\\\\\\") + put(pferd," / o \\\\\\\\\\\\") + put(pferd," / \\\\\\\\\\\\") + put(pferd," / \\\\\\\\\\\\\\") + put(pferd," / \\\\\\\\\\\\") + put(pferd," O /-----\\ \\\\\\\\\\___") + put(pferd," \\/|_/ \\") + put(pferd," \\") + put(pferd," \\") + put(pferd," \\") + return pferd + end + +# +# generate horse 2 portraite +# +procedure pick2() + local pferd + + pferd := [] + put(pferd,"") + put(pferd," /\\") + put(pferd," |||/ \\") + put(pferd," / \\\\") + put(pferd," / / \\\\\\\\") + put(pferd," / O \\\\\\\\") + put(pferd," / \\\\\\\\") + put(pferd," / \\\\\\\\") + put(pferd," / \\\\\\\\") + put(pferd," o /----\\\\ \\\\\\\\\\___") + put(pferd," \\/|_/ \\\\") + put(pferd," \\\\\\") + put(pferd," \\") + put(pferd," \\") + put(pferd,"") + return pferd + end + +# +# generate horse 3 portraite +# +procedure pick3() + local pferd + + pferd := [] + put(pferd," \\/ ") + put(pferd," \\ /||| ") + put(pferd," \\ / ") + put(pferd," \\\\ / ") + put(pferd," \\\\\\ o / ") + put(pferd," \\\\\\\\ / ") + put(pferd," \\\\\\\\\\ / ") + put(pferd," \\\\\\\\\\ / ") + put(pferd," ___\\\\\\\\ \\\\-----/ O") + put(pferd," \\\\ /_|/\\ ") + put(pferd," \\ ") + put(pferd," \\ ") + put(pferd," \\ ") + put(pferd,"") + return pferd + end +# +# +# generate horse 4 portraite +# +procedure pick4() + local pferd + + pferd := [] + put(pferd," \\/ ") + put(pferd," \\\\//||| ") + put(pferd," \\\\ / ") + put(pferd," \\\\\\ / / ") + put(pferd," \\\\\\ O / ") + put(pferd," \\\\\\ / ") + put(pferd," \\\\\\ / ") + put(pferd," \\\\\\ /") + put(pferd," ___\\\\\\ \\----/ o") + put(pferd," \\\\ /_|/\\ ") + put(pferd," \\\\ ") + put(pferd," \\ ") + put(pferd," \\ ") + put(pferd,"") + return pferd + end + +# +# generate horse 5 portraite +# +procedure pick5() + local pferd + + pferd := [] + put(pferd," /\\ /\\") + put(pferd," | ||||| |") + put(pferd," | ||| |") + put(pferd," | || |\\") + put(pferd," | | \\") + put(pferd," | 0 0 | |\\") + put(pferd," | | |\\") + put(pferd," | | |\\") + put(pferd," | | |\\") + put(pferd," | | |") + put(pferd," | o o |\\") + put(pferd," \\ ____ / \\") + put(pferd," \\______/ \\") + put(pferd,"") + return pferd + end + +# +# generate horse 6 portraite +# +procedure pick6() + local pferd + + pferd := [] + put(pferd," \\/ \\/ ") + put(pferd," | ||||| | ") + put(pferd," | ||| | ") + put(pferd," \\| || | ") + put(pferd," \\ | | ") + put(pferd," \\| | 0 0 | ") + put(pferd," \\| | | ") + put(pferd," \\| | | ") + put(pferd," \\| | | ") + put(pferd," | | | ") + put(pferd," \\| o o | ") + put(pferd," \\ / ____ \\") + put(pferd," \\ /______\\ ") + put(pferd,"") + return pferd + end + +procedure banner() + write("\e[0;1;33;44m\e[2J\e[H") + write("###############################################################################") + write(" ") + write(" **** * * **** ***** **** **** ***** ***** ***** **** ") + write(" * * * * * * * * * * * * * * ") + write(" * * **** *** **** *** * *** *** * * ") + write(" * * * * * * * * * * * * * ") + write(" **** * **** ***** * * **** * ***** ***** **** ") + write(" ") + write(" **** * **** *** * * **** ") + write(" * * * * * * ** * * ") + write(" **** ***** * * * * * * *** ") + write(" * * * * * * * ** * * ") + write(" * * * * **** *** * * **** ") + write(" ") + write(" \e[1;5m by tenaglia\e[0;1;33;44m") + write(" ") + write("###############################################################################") + wait(3) + end +# +# +# move cursor to specified screen position +# +procedure at(row,column) + return "\e[" || row || ";" || column || "f" + end + +# +# procedure to wait n seconds +# +procedure wait(n) + local now, secs + + secs := &clock[-2:0] + n + if secs > 60 then secs -:= 60 + repeat + { + now := &clock[-2:0] + if now = secs then break + } + return + end + +# +# this procedure prompts for an input string +# +procedure input(prompt) + writes(prompt) + return read() + end + +# +# parse a string into a list with respect to a delimiter +# +procedure parse(line,delims) + local tokens + static chars + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end + diff --git a/ipl/progs/htget.icn b/ipl/progs/htget.icn new file mode 100644 index 0000000..09746a0 --- /dev/null +++ b/ipl/progs/htget.icn @@ -0,0 +1,83 @@ +############################################################################ +# +# File: htget.icn +# +# Subject: Program to get Web file using HTTP protocol +# +# Author: Gregg M. Townsend +# +# Date: May 15, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Htget retrieves the raw text of a file from the world wide web using +# HTTP protocol. (Other protocols such as FTP are not supported.) +# +# usage: htget [-h | -b] URL +# +# The URL may be given with or without the "http://" prefix. +# +# If -h is given, a HEAD request is sent, requesting only information +# instead of the complete file. +# +# If -b is given, the header is stripped and the body is copied +# in binary mode. +# +############################################################################ +# +# Links: cfunc, options +# +############################################################################ +# +# Requires: UNIX, dynamic loading +# +############################################################################ + +link cfunc +link options + +procedure main(args) + local opts, req, url, host, port, path, f + + opts := options(args, "hb") + if \opts["h"] then + req := "HEAD" + else + req := "GET" + + url := \args[1] | stop("usage: ", &progname, " [-h] url") + + url ? { + ="http:" | ="HTTP:" # skip optional http: + tab(many('/')) # skip optional // + host := tab(upto(':/') | 0) + if *host = 0 then + host := "localhost" + if not (=":" & (port := integer(tab(upto('/'))))) then + port := 80 + if pos(0) then + path := "/" + else + path := tab(0) + } + + if not (f := tconnect(host, port)) then + stop ("cannot connect to ", host, ":", port) + + writes(f, req, " ", path, " HTTP/1.0\r\n") + writes(f, "Host: ", host, "\r\n") + writes(f, "\r\n") + flush(f) + seek(f, 1) + + if \opts["b"] then { + while *read(f) > 0 + while writes(reads(f, 32768)) + } + else + while write(read(f)) +end diff --git a/ipl/progs/htprep.icn b/ipl/progs/htprep.icn new file mode 100644 index 0000000..fbe7b32 --- /dev/null +++ b/ipl/progs/htprep.icn @@ -0,0 +1,327 @@ +############################################################################ +# +# File: htprep.icn +# +# Subject: Program to prepare HTML files +# +# Author: Gregg M. Townsend +# +# Date: November 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# usage: htprep [file] +# +# Htprep is a filter for preparing HTML files (used, e.g., by Mosaic) +# from a simpler and less error-prone input language. +# +# The following transformations are applied: +# +# input output +# ------------ ------------ +# {} +# {!comment} <!--comment--> +# {tag} <tag> +# {tag ... } <tag> ... <\tag> +# att=val... att="val"... +# {@url ... <a href="url" ... +# {:lbl ... <a name="lbl" ... +# +# Any input character can be preceded by a backslash (\) to prevent +# special interpretation by htprep. +# +# Output is normally to stdout, but the command +# {divert fname} +# redirects output to the named file. This can be used to produce +# multiple related output files from a single input file. +# +############################################################################ + +$define SIGNATURE "<!-- Created by HTPREP -->" +$define WSPACE ' \t' # whitespace cset + + +record tag(label, line) # tag record +global tagstack # currently open tags + +global cmdtable # table of known special commands + +global infile # input file +global outfile # output file +global stdout # standard output, if usable + +global lineno # current input line number +global errors # error count + +global idset # identifier characters + + +# main procedure + +procedure main(args) + local line, t + + idset := &letters ++ &digits ++ '.-_:' + + lineno := 0 + errors := 0 + tagstack := [] + + stdout := &output + + cmdtable := table() + cmdtable["divert"] := divert + + if *args = 0 then + infile := &input + else + infile := open(args[1]) | stop("can't open ", args[1]) + + while line := in() do { + lineno +:= 1 + line := braces(line) + out(line) + } + + while t := pop(tagstack) do + warn("unclosed tag {", t.label, "} from line ", t.line) + + if errors > 0 then + stop + else + return +end + + + +# braces(line) -- process items identified by braces ('{}') + +procedure braces(line) + local c, s, t + + line ? { + s := "" + while s ||:= tab(upto('{}')) do { + c := move(1) + if c == "{" then + s ||:= newtag() + else { # "}" + if t := pop(tagstack) then { + if t.label == "!" then + s ||:= "-->" + else + s ||:= "</" || t.label || ">" + } + else + lwarn("tag stack underflow") + } + } + return s ||:= tab(0) + } +end + + + +# newtag() -- process text following left brace ('{') + +procedure newtag() + local label, s, c + + if ="}" then + return "" + if ="!" then { + push(tagstack, tag("!", lineno)) + return "<!--" + } + + if c := tab(any('@:')) then { + label := "a" + if c == "@" then + s := "<a href=" + else + s := "<a name=" + s ||:= attval() + } + else { + label := tab(many(idset)) | (lwarn("unlabeled tag") & "noname") + s := "<" || label + } + + if \cmdtable[map(label)] then + return s := docommand(label) + + while s ||:= attrib() + tab(many(WSPACE)) + ="}" | push(tagstack, tag(label, lineno)) + return s || ">" +end + + + +# attrib() -- match and return attribute + +procedure attrib() + return tab(many(WSPACE)) || tab(many(idset)) || ="=" || attval() +end + + + +# attval() -- match and return attribute value + +procedure attval() + static valset + initial valset := &cset[34+:94] -- '\'\\"{}' + return (="\"" || tab(upto('"')) || move(1)) | + (="'" || tab(upto('\'')) || move(1)) | + aquote(tab(many(valset))) +end + + + +# aquote(s) -- quote attribute value, but only if needed + +procedure aquote(s) + if many(idset, s) = *s + 1 then + return s + else + return '"' || s || '"' +end + + + +# docommand(label) -- process a tag recognized as a command + +procedure docommand(label) + local p, atts, words, id, s + + p := cmdtable[label] + atts := table() + words := [] + while s := attrib() do s ? { + tab(many(WSPACE)) + id := tab(many(idset)) + move(2) + atts[id] := tab(-1) + } + while tab(many(WSPACE)) & (s := tab(bal(' }', '{', '}'))) do + put(words, s) + tab(many(WSPACE)) + ="}" | lwarn(label, ": unterminated command") + return p(atts, words) | "" +end + + + +# in() -- read next line, interpreting escapes +# +# Reads the next line from infile, removing leading and trailing whitespace. +# +# If an ASCII character is preceded by a backslash, the character's eighth +# bit is set to prevent its recognition as a special character, and the +# backslash is retained. If it's not an ASCII character (that is, if the +# eighth bit is already set) the backslash is simply discarded. + +procedure in() + local s + + trim(read(infile), WSPACE) ? { + tab(many(WSPACE)) + s := "" + while s ||:= tab(upto('\\')) do { + move(1) + if any(&ascii) then + s ||:= "\\" || char(128 + ord(move(1))) + else + s ||:= move(1) + } + return s ||:= tab(0) + } + fail +end + + + +# divert(attlist, wordlist) -- process "divert" command +# +# If an error is seen, a message is issued and subsequent output is +# simply discarded. + +procedure divert(atts, words) + local fname, f + + close(\outfile) # always close current file + outfile := stdout := &null # no current file, and no fallback + + if *words ~= 1 then { + lwarn("usage: {divert filename}") + fail + } + + fname := get(words) + if f := open(fname) then { + if read(f) ~== SIGNATURE then { + lwarn("divert: won't overwrite non-htprep file ", fname) + close(f) + fail + } + close(f) + } + + if outfile := open(fname, "w") then { + out(SIGNATURE) + return "" + } + else { + lwarn("divert: can't open ", fname) + fail + } +end + + + +# out(s) -- write line, interpreting escapes +# +# When a backslash is seen, the backslash is discarded and the eighth +# bit of the following character is cleared. + +procedure out(s) + local c + + if /outfile := (\stdout | fail) then + write(outfile, SIGNATURE) # if first write to &output + + s ? { + while writes(outfile, tab(upto('\\'))) do { + move(1) + writes(outfile, char(iand(127, ord(move(1))))) + } + write(outfile, tab(0)) + } + return +end + + + +# lwarn(s, ...) -- issue warning with line number + +procedure lwarn(a[]) + push(a, "line " || lineno || ": ") + warn ! a + return +end + + + +# warn(s,...) -- issue warning message + +procedure warn(a[]) + push(a, " ") + push(a, &errout) + write ! a + errors +:= 1 + return +end diff --git a/ipl/progs/huffstuf.icn b/ipl/progs/huffstuf.icn new file mode 100644 index 0000000..aaf7f0a --- /dev/null +++ b/ipl/progs/huffstuf.icn @@ -0,0 +1,386 @@ +############################################################################ +# +# File: huffstuf.icn +# +# Subject: Program for huffman coding +# +# Author: Richard L. Goerwitz +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.2 +# +############################################################################ +# +# An odd assortment of tools that lets me compress text using an +# Iconish version of a generic Huffman algorithm. +# +############################################################################ +# +# Links: codeobj, outbits, inbits +# +############################################################################ +# +# See also: hufftab.icn, press.icn +# +############################################################################ + +link codeobj +link inbits +link outbits + +# Necessary records. +record nodE(l,r,n) +record _ND(l,r) +record leaF(c,n) +record huffcode(c,i,len) + +# For debugging purposes. +# link ximage + +# Count of chars in input file. +global count_of_all_chars + + +procedure main(a) + + local direction, usage, size, char_tbl, heap, tree, h_tbl, intext + usage := "huffcode -i|o filename1" + + direction := pop(a) | stop(usage) + direction ?:= { ="-"; tab(any('oi')) } | stop(usage) + *a = 1 | stop(usage) + + intext := open(a[1]) | quitprog("huffcode", "can't open "||a[1], 1) + size := 80 + + if direction == "o" then { + + char_tbl := table() + while count_chars_in_s(reads(intext), char_tbl) + heap := initialize_heap(char_tbl) + tree := heap_2_tree(heap) + h_tbl := hash_codes(tree) + + put_tree(&output, tree) + seek(intext, 1) + every writes(&output, encode_string(|reads(intext, size), h_tbl)) + + } + else { + tree := get_tree(intext) + every writes(&output, decode_rest_of_file(intext, size, tree)) + } + +end + + +procedure count_chars_in_s(s, char_tbl) + + # + # Count chars in s, placing stats in char_tbl (keys = chars in + # s, values = leaF records, with the counts for each chr in s + # contained in char_tbl[chr].n). + # + local chr + initial { + /char_tbl & + quitprog("count_chars_in_s", "need 2 args - 1 string, 2 table", 9) + *char_tbl ~= 0 & + quitprog("count_chars_in_s","start me with an empty table",8) + count_of_all_chars := 0 + } + + # Reset character count on no-arg invocation. + /s & /char_tbl & { + count_of_all_chars := 0 + return + } + + # Insert counts for characters into char_tbl. Note that we don't + # just put them into the table as-is. Rather, we put them into + # a record which contains the character associated with the count. + # These records are later used by the Huffman encoding algorithm. + s ? { + while chr := move(1) do { + count_of_all_chars +:= 1 + /char_tbl[chr] := leaF(chr,0) + char_tbl[chr].n +:= 1 + } + } + return *char_tbl # for lack of anything better + +end + + +procedure initialize_heap(char_tbl) + + # + # Create heap data structure out of the table filled out by + # successive calls to count_chars_in_s(s,t). The heap is just a + # list. Naturally, it's size can be obtained via *heap. + # + local heap + + heap := list() + every push(heap, !char_tbl) do + reshuffle_heap(heap, 1) + return heap + +end + + +procedure reshuffle_heap(h, k) + + # + # Based loosely on Sedgewick (2nd. ed., 1988), p. 160. Take k-th + # node on the heap, and walk down the heap, switching this node + # along the way with the child whose value is the least AND whose + # value is less than this node's. Stop when you find no children + # whose value is less than that of the original node. Elements on + # heap are records of type leaF, with the values contained in the + # "n" field. + # + local j + + # While we haven't spilled off the end of the heap (the size of the + # heap is *h; *h / 2 is the biggest k we need to look at)... + while k <= (*h / 2) do { + + # ...double k, assign the result to j. + j := k+k + + # If we aren't at the end of the heap... + if j < *h then { + # ...check to see which of h[k]'s children is the smallest, + # and make j point to it. + if h[j].n > h[j+1].n then + # h[j] :=: h[j+1] + j +:= 1 + } + + # If the current parent (h[k]) has a value less than those of its + # children, then break; we're done. + if h[k].n <= h[j].n then break + + # Otherwise, switch the parent for the child, and loop around + # again, with k (the pointer to the parent) now pointing to the + # new offset of the element we have been working on. + h[k] :=: h[j] + k := j + + } + + return k + +end + + +procedure heap_2_tree(h) + + # + # Construct the Huffman tree out of heap h. Find the smallest + # element, pop it off the heap, then reshuffle the heap. After + # reshuffling, replace the top record on the stack with a nodE() + # record whose n field equal to the sum of the n fields for the + # element popped off the stack originally, and the one that is + # now about to be replaced. Link the new nodE record to the 2 + # elements on the heap it is now replacing. Reshuffle the heap + # again, then repeat. You're done when the size of the heap is + # 1. That one element remaining (h[1]) is your Huffman tree. + # + # Based loosely on Sedgewick (2nd ed., 1988), p. 328-9. + # + local frst, scnd, count + + until *h = 1 do { + + h[1] :=: h[*h] # Reverse first and last elements. + frst := pull(h) # Pop last elem off & save it. + reshuffle_heap(h, 1) # Resettle the heap. + scnd := !h # Save (but don't clobber) top element. + + count := frst.n + scnd.n + frst := { if *frst = 2 then frst.c else _ND(frst.l, frst.r) } + scnd := { if *scnd = 2 then scnd.c else _ND(scnd.l, scnd.r) } + + h[1] := nodE(frst, scnd, count) # Create new nodE(). + reshuffle_heap(h, 1) # Resettle once again. + } + + # H is no longer a stack. It's single element - the root of a + # Huffman tree made up of nodE()s and leaF()s. Put the l and r + # fields of that element into an _ND record, and return the new + # record. + return _ND(h[1].l, h[1].r) + +end + + +procedure hash_codes(tr) + local huff_tbl + + # + # Hash Huffman codes. Tr (arg 1) is a Huffman tree created by + # heap_2_tree(heap). Output is a table, with the keys + # representing characters, and the values being records of type + # huffcode(i,len), where i is the Huffcode (an integer) and len is + # the number of bits it occupies. + # + local code + + huff_tbl := table() + every code := collect_bits(tr) do + insert(huff_tbl, code.c, code) + return huff_tbl + +end + + +procedure collect_bits(tr, i, len) + + # + # Decompose Huffman tree tr into huffcode() records which contain + # 3 fields: c (the character encoded), i (its integer code), + # and len (the number of bytes the integer code occupies). Sus- + # pend one such record for each character encoded in tree tr. + # + + if type(tr) == "string" then + return huffcode(tr, i, len) + else { + (/len := 1) | (len +:= 1) + (/i := 0) | (i *:= 2) + suspend collect_bits(tr.l, i, len) + i +:= 1 + suspend collect_bits(tr.r, i, len) + } + +end + + +procedure put_tree(f, tr) + + # + # Writes Huffman tree tr to file f. Uses first two bits to store + # the size of the tree. + # + local stringized_tr + # global count_of_all_chars + + /f | /tr & quitprog("put_tree","I need two nonnull arguments",7) + + stringized_tr := encode(tr) + every writes(f, outbits(*stringized_tr, 16)) # use two bytes + outbits() # just in case + writes(f, stringized_tr) + # How many characters are there in the input file? + every writes(f, outbits(count_of_all_chars, 32)) + outbits() + +end + + +procedure get_tree(f) + + # + # Reads in Huffman tree from file f, sets pointer to the first + # encoded bit (as opposed to the bits which form the tree des- + # cription) in file f. + # + local stringized_tr_size, tr + # global count_of_all_chars + + stringized_tr_size := inbits(f, 16) + tr := decode(reads(f, stringized_tr_size)) | + quitprog("get_tree", "can't decode tree", 6) + count_of_all_chars := inbits(f, 32) | + quitprog("get_tree", "garbled input file", 10) + return tr + +end + + +procedure encode_string(s, huffman_table) + + # + # Encode string s using the codes in huffman_table (created by + # hash_codes, which in turns uses the Huffman tree created by + # heap_2_tree). + # + # Make sure you are using reads() and not read, unless you don't + # want to preserve newlines. + # + local s2, chr, hcode # hcode stores huffcode records + static chars_written + initial chars_written := 0 + + s2 := "" + s ? { + while chr := move(1) do { + chars_written +:= 1 + hcode := \huffman_table[chr] | + quitprog("encode_string", "unexpected char, "||image(chr), 11) + every s2 ||:= outbits(hcode.i, hcode.len) + } + # If at end of output stream, then flush outbits buffer. + if chars_written = count_of_all_chars then { + chars_written := 0 + s2 ||:= outbits() + } else { + if chars_written > count_of_all_chars then { + chars_written := 0 + quitprog("encode_string", "you're trying to write _ + more chars than you originally tabulated", 12) + } + } + } + return s2 + +end + + +procedure decode_rest_of_file(f, size, huffman_tree) + + local s2, line, E, chr, bit + static chars_decoded + initial chars_decoded := 0 + + E := huffman_tree + while line := reads(f, size) do { + line ? { + s2 := "" + while chr := move(1) do { + every bit := iand(1, ishift(ord(chr), -7 to 0)) do { + E := { if bit = 0 then E.l else E.r } + if s2 ||:= string(E) then { + chars_decoded +:= 1 + if chars_decoded = count_of_all_chars then { + chars_decoded := 0 + break { break break } + } + else E := huffman_tree + } + } + } + suspend s2 + } + } + suspend s2 + +end + + +procedure quitprog(p, m, c) + + /m := "program error" + write(&errout, p, ": ", m) + exit(\c | 1) + +end diff --git a/ipl/progs/hufftab.icn b/ipl/progs/hufftab.icn new file mode 100644 index 0000000..1fc58b3 --- /dev/null +++ b/ipl/progs/hufftab.icn @@ -0,0 +1,89 @@ +############################################################################ +# +# File: hufftab.icn +# +# Subject: Program to compute Huffman state transitions +# +# Author: Gregg M. Townsend +# +# Date: November 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/ibar.icn b/ipl/progs/ibar.icn new file mode 100644 index 0000000..be469d7 --- /dev/null +++ b/ipl/progs/ibar.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: ibar.icn +# +# Subject: Program to equalize comment bars in Icon programs +# +# Author: Ralph E. Griswold +# +# Date: June 8, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program replaces comment bars in Icon programs by bars 76 characters +# long -- the program library standard. +# +############################################################################ + +procedure main() + local bar, short_bar, line, notcom + + bar := repl("#", 76) + short_bar := repl("#", 60) + notcom := ~'#' + + while line := read() do + line ? { + if =short_bar & not(upto(notcom)) & *line ~= 76 then write(bar) + else write(line) + } + +end diff --git a/ipl/progs/ibrow.icn b/ipl/progs/ibrow.icn new file mode 100644 index 0000000..7714469 --- /dev/null +++ b/ipl/progs/ibrow.icn @@ -0,0 +1,186 @@ +############################################################################ +# +# File: ibrow.icn +# +# Subject: Program to browse Icon files for declarations +# +# Author: Robert J. Alexander +# +# Date: September 7, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: ibrow [<Icon source file name>...] +# +# If no source file names are provided on the command line, all *.icn +# files in the current directory are browsed. +# +# The program facilitates browsing of Icon programs. It was originally +# written to browse the Icon Program Library, for which purpose it +# serves quite well. The user interface is self-explanatory -- just +# remember to use "?" for help if you're confused. +# +############################################################################ +# +# Links: colmize +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +link colmize + +procedure main(arg) + local p, proctab, doneNames, fn, f, foundNonEmptyLine, block, lineNbr + local line, keywd, startLine, proclist, w, i, x, proclines, cmd, b + + if not (&features == "UNIX") then stop("Runs only under UNIX") + if *arg = 0 then { + p := open("ls *.icn","rp") + while put(arg,read(p)) + close(p) + } + proctab := table() + # + # Loop to scan all of the specified source files and save their + # procedures and records. + # + doneNames := set() # This set is used to prevent scanning twice if + # both a source and a suffixless icode file are + # passed as arguments (e.g. mydir/*). + write("Icon Browser -- scanning files:") + every fn := !arg do { + if not (fn[-4:0] == ".icn") then fn ||:= ".icn" + if member(doneNames,fn) then next + insert(doneNames,fn) + f := if fn == "-" then &input else open(fn) | next + write(" ",fn) + # + # Loop to process lines of file (in string scanning mode). + # + foundNonEmptyLine := &null + block := [] + lineNbr := 0 + while line := read(f) do line ? { + lineNbr +:= 1 + if not pos(0) then { + foundNonEmptyLine := 1 + if (tab(many(' \t')) | "")\1 & + (keywd := =("end" | "global" | "link")\1) | + (keywd := =("procedure" | "record")\1 & + tab(many(' \t')) & name := tab(upto(' \t('))\1) then { + if keywd == ("procedure" | "record") then startLine := lineNbr + if keywd == "record" then { + until find(")",line) do { + put(block,line) + line := read(f) | break + lineNbr +:= 1 + } + } + if proctab[name || case keywd of {"end": "()"; "record": "."}] := + [block,fn,startLine] then put(block,line) + if keywd ~== "procedure" then { + foundNonEmptyLine := &null + block := [] + } + } + } + if \foundNonEmptyLine then put(block,line) + } + # + # Close this file. + # + close(f) + } + doneNames := &null + # + # Reorganize the data. + # + proctab := sort(proctab) + proclist := [] + w := **proctab + i := 0 + every x := !proctab do + put(proclist,right(i +:= 1,w) || ". " || x[1]) + proclines := [] + every put(proclines,colmize(proclist)) + proclist := [] + every put(proclist,(!proctab)[2]) + proctab := &null + # + # Interact with the user to browse. + # + repeat { + write() + every write(!proclines) + write() + repeat { + # + # Prompt for, read, and analyze the user's command. + # + writes("\nq,nn,nn[fmev],<return> (? for help): ") + line := read() | exit() + case line of { + "q": exit() + "?": help() & next + "": break + } + if integer(line) then line ||:= "f" + if cmd := line[-1] & any('fmev',cmd) & + block := proclist[0 < integer(line[1:-1])] then { + case cmd of { + "f": { + # + # Write the file name containing the procedure and the + # first line of the procedure. + # + b := block[1] + every line := b[1 to *b] do { + line ? (if (tab(many(' \t')) | "")\1 & + =("procedure" | "record") then break) + } + write(block[2],": ",line) + } + "m": { + # + # List the procedure using "more". + # + write() + p := open("more","pw") | stop("Can't popen") + every write(p,!block[1]) + close(p) + } + "e" | "v": { + # + # Invoke ex or vi positioned at the first line + # of procedure or record. + # + system((if cmd == "e" then "ex" else "vi") || + " +" || block[3] || " " || block[2]) + } + } + } + } + } +end + +procedure help() + write( +"\nEnter:_ +\n q Quit_ +\n ? Display help message (this message)_ +\n <return> Redisplay the list of procedure and record names_ +\n <number from list>[f] Display the file name and first line of_ +\n procedure or record_ +\n <number from list>m Display the procedure or record using \"more\"_ +\n <number from list>e Invoke \"ex\" positioned to procedure or record_ +\n <number from list>v Invoke \"vi\" positioned to procedure or record" + ) + return +end diff --git a/ipl/progs/icalc.icn b/ipl/progs/icalc.icn new file mode 100644 index 0000000..fa7cacb --- /dev/null +++ b/ipl/progs/icalc.icn @@ -0,0 +1,477 @@ +############################################################################ +# +# File: icalc.icn +# +# Subject: Program to simulate infix desk calculator +# +# Author: Stephen B. Wampler +# +# Date: January 3, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This is a simple infix calculator with control structures and +# compound statements. It illustrates a technique that can be +# easily used in Icon to greatly reduce the performance cost +# associated with recursive-descent parsing with backtracking. +# There are numerous improvements and enhancements that can be +# made. +# +# Features include: +# +# - integer and real value arithmetic +# - variables +# - function calls to Icon functions +# - strings allowed as function arguments +# - unary operators: +# + (absolute value), - (negation) +# - assignment: +# := +# - binary operators: +# +,-,*,/,%,^, +# - relational operators: +# =, !=, <, <=, >, >= +# (all return 1 for true and 0 for false) +# - compound statements in curly braces with semicolon separators +# - if-then and if-then-else +# - while-do +# - limited form of multiline input +# +# The grammar at the start of the 'parser' proper provides more +# details. +# +# Normally, the input is processed one line at a time, in calculator +# fashion. However, compound statements can be continued across +# line boundaries. +# +# Examples: +# +# Here is a simple input: +# +# { +# a := 10; +# while a >= 0 do { +# write(a); +# a := a - 1 +# }; +# write("Blastoff") +# } +# +# (execution is delayed until entire compound statement is entered) +# +# Another one: +# +# write(pi := 3.14159) +# write(sin(pi/2)) +# +# (execution done as each line is entered) +# +############################################################################ + +invocable all + + # the types for parse tree nodes: + +record trinary(op,first,second,third) +record binop(op,left,right) +record unary(op,opnd) +record id(name) +record const(value) + + # a global table for holding variable values: + +global sym_tab + + +procedure main() + local line, sline + + sym_tab := table() + + every line := getbs() do { # a 'line' may be more + # than one input line + if *(sline := trim(line)) > 0 then { # skip empty lines + process(parse(sline)) + } + } +end + +### Input routines... + +## getbs - read enough input to ensure that it is +# balanced with respect to curly braces, allowing +# compound statements to extend across lines... +# This can be made considerably more sophisticated, +# but handles the more common cases. +# +procedure getbs() +static tmp + initial tmp := (("" ~== |read()) || " ") | fail + + repeat { + while not checkbal(tmp,'{','}') do { + if more('}','{',tmp) then break + tmp ||:= (("" ~== |read()) || " ") | break + } + suspend tmp + tmp := (("" ~== |read()) || " ") | fail + } +end + +## checkbal(s) - quick check to see if s is +# balanced w.r.t. braces or parens +# +procedure checkbal(s,l,r) + return (s ? 1(tab(bal(&cset,l,r)),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 + + +### Parser routines... Implementing an efficient recursive-descent +### parser with backtracking. + +# Parser -- Based on following CFG, but modified to +# avoid useless backtracking... (see comments +# preceding procedures 'save' and 'restore') + +# Statement ::= Expr | If | While | Compound +# +# Compound ::= {Statement_list} +# +# Statement_list ::= Statement | Statement ; Statement_list +# +# If ::= if Expr then Statement Else +# +# Else ::= else Statement | "" +# +# While ::= while Expr do Statement +# +# Expr ::= R | Id := Expr +# +# R ::= X [=,!=,<,>,>=,<=] X | X +# +# X ::= T [+-] X | T +# +# T ::= F [*/%] T | F +# +# F ::= E ^ F | E +# +# E ::= L | [+,-] L +# +# L ::= Func | Id | Constant | ( Expr ) | String +# +# Func ::= Id ( Arglist ) +# +# Arglist ::= "" | Expr | Expr , arglist + +# +# Note, this version correctly handles left-associativity +# despite the fact that the above grammar doesn't +# handle it correctly. (Cannot embed left-associativity +# into a recursive descent parser!) +# + +procedure parse(s) # must match entire line + local tree + + if s ? ((tree := Statement()) & (ws(),pos(0))) then { + return tree + } + write("Syntax error.") +end + +procedure Statement() + suspend If() | While() | Compound() | Expr() +end + +procedure Compound() + suspend unary("{",2(litmat("{"),Statement_list(),litmat("}"))) +end + +procedure Statement_list() + local t + t := scan() + suspend binary(save(Statement,t), litmat(";"), Statement_list()) | restore(t) +end + +procedure If() + suspend trinary(keymat("if"),Expr(),2(keymat("then"),Statement()), + 2(keymat("else"),Statement())|&null) +end + +procedure While() + suspend binary(2(keymat("while"),Expr()),"while",2(keymat("do"),Statement())) +end + +procedure Expr() + suspend binary(Id(),litmat(":="),Expr()) | R() +end + +procedure R() + local t + t := scan() + suspend binary(save(X,t),litmat(!["=","!=","<=",">=","<",">"]),X()) | + restore(t) +end + +procedure X() + local t + t := scan() + suspend binary(save(T,t),litmat(!"+-"),X()) | restore(t) +end + +procedure T() + local t + t := scan() + suspend binary(save(F,t),litmat(!"*/%"),T()) | restore(t) +end + +procedure F() + local t + t := scan() + suspend binary(save(E,t),litmat("^"),F()) | restore(t) +end + +procedure E() + suspend unary(litmat(!"+-"),L()) | L() +end + +procedure L() + # keep track of fact expression was parenthesized, + # so we don't accidently override the parens when + # handling left-associativity + suspend Func() | Id() | Const() | + unary("(",2(litmat("("), Expr(), litmat(")"))) | + String() +end + +procedure Func() + suspend binary(Id(),litmat("("),1(Arglist(),litmat(")"))) +end + +procedure Arglist() + local a + a := [] + suspend (a <- ([Expr()] | [Expr()] ||| 2(litmat(","),Arglist()))) | a +end + +procedure Id() + static first, rest + + initial { + first := &letters ++ "_" + rest := first ++ &digits + } + + suspend 2(ws(),id(tab(any(first))||tab(many(rest)) | tab(any(first)))) +end + +procedure Const() + local t + + t := scan() + + suspend 2(ws(),const((save(digitseq,t)||="."||digitseq()) | restore(t))) + +end + +procedure digitseq() + suspend tab(many(&digits)) +end + +procedure String() + # can be MUCH smarter, see calc.icn (by Ralph Griswold) for + # example of how to do so... + suspend 2(litmat("\""),tab(upto('"')),move(1)) +end + +procedure litmat(s) + suspend 2(ws(),=s) +end + +procedure keymat(key) + suspend 2(ws(),key==tab(many(&letters))) +end + +procedure ws() + static wsp + initial wsp := ' \t' + suspend ""|tab(many(wsp)) +end + +procedure binary(l,o,r) + local lm + + # if operator is left-associative, then alter tree to + # reflect that fact, since it isn't parsed that way + # (this isn't the most efficient way to do this, but + # it is a simple way...) + + if (type(r) == "binop") & samelop(o,r.op) then { + + # ok, have to add node to far left end of chain for r + + # ...do so by first finding leftmost node of chain for r + lm := r + while (type(lm.left) == "binop") & samelop(o,lm.left.op) do { + lm := lm.left + } + + # ...add new node as new left-most node in chain + lm.left := binop(o,l,lm.left) + + # ...and return original right child as root of tower + return r + } + + # nothing to do, just return 'normal' tree + return binop(o,l,r) +end + +procedure samelop(o1,o2) + # both operators are left associative at the same precedence level + return (any('+-',o1) & any('+-',o2)) | + (any('*/%',o1) & any('*/%',o2)) +end + +## Speed up tools for recursive descent parsing... +# +# The following two routines make it possible to 'defer' +# the backtracking into a parsing procedure (at least +# so far as restoring &pos). This makes it easy to +# reuse the result of a parsing procedure if needed. +# +# For example, the grammar rules: +# +# X := T | T + F +# +# can be processed as: +# +# X := save(T,t) | restore(t) + F +# +# The net effect is a very substantial speedup in processing +# such rules. +# + +record scan(val,pos) # used to avoid repeating a successful scan + # (see the use of save() and restore()) + +# save the current scanning position and result of parsing procedure P +# and then prevent backtracking into P +# +procedure save(P,t) + return (t.pos <- &pos, t.val := P()) +end + +# +# if t has in it the saved result of a parsing procedure, then +# suspend it. if backtracked into reset position back to +# start of original call to that parsing procedure. +# +procedure restore(t) + suspend \t.val + &pos := \t.pos +end + +### execution of infix expression... + +## process -- given an expression tree - walk it to produce a result +# + + # The only tricky part is in the assignment operator. + # Here, since we know the left-hand side is an identifier + # We avoid processing it, since process(id(name)) will + # return the value of id(name), not it's address. + + # This version just relies upon the icon interpreter to + # catch runtime errors. It would be better to catch them + # here. + +procedure process(t) + local a, val + + return case type(t) of { + "trinary" : case t.op of { # has to be an 'if'! + "if": if process(t.first) ~= 0 then + process(t.second) + else + process(t.third) + } + + "binop" : case t.op of { + # the relation operators + "=" : if process(t.left) = process(t.right) then 1 else 0 + "!=": if process(t.left) ~= process(t.right) then 1 else 0 + "<=": if process(t.left) <= process(t.right) then 1 else 0 + ">=": if process(t.left) >= process(t.right) then 1 else 0 + "<" : if process(t.left) < process(t.right) then 1 else 0 + ">" : if process(t.left) > process(t.right) then 1 else 0 + + # the arithmetic operators + "+" : process(t.left) + process(t.right) + "-" : process(t.left) - process(t.right) + "*" : process(t.left) * process(t.right) + "/" : process(t.left) / process(t.right) + "%" : process(t.left) % process(t.right) + "^" : process(t.left) ^ process(t.right) + + # assignment + ":=": sym_tab[t.left.name] := process(t.right) + + # statements in a statement list + ";" : { + process(t.left) + process(t.right) + } + + # while loop + "while" : while process(t.left) ~= 0 do + process(t.right) + + # function calls + "(" : t.left.name ! process(t.right) + } + + "unary" : case t.op of { + "-" : -process(t.opnd) + "+" : if val := process(t.opnd) then + return if val < 0 then -val else val + # parenthesized expression + "(" : process(t.opnd) + # compound statement + "{" : process(t.opnd) + } + + "id" : \sym_tab[t.name] | (write(t.name," is undefined!"),&fail) + + "const" : numeric(t.value) + + "list" : { # argument list for function call + # evaluate each argument into a new list + a := [] + every put(a,process(!t)) + a + } + + default: t # anything else (right now, just strings) + } + +end diff --git a/ipl/progs/icalls.icn b/ipl/progs/icalls.icn new file mode 100644 index 0000000..3a9d03c --- /dev/null +++ b/ipl/progs/icalls.icn @@ -0,0 +1,47 @@ +############################################################################ +# +# File: icalls.icn +# +# Subject: Program to tabulate Icon calls +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program processes trace output and tabulates calls of procedures +# +############################################################################ + +procedure main() + local procs, name, args + + procs := table() + + every !&input ? { + while tab(find("| ") + 2) # get rid of level bars + if name := tab(upto('(')) then { # if call + move(1) + args := tab(-1) + /procs[name] := table(0) # new table if necessary + procs[name][args] +:= 1 + } + } + + procs := sort(procs, 3) + + while write(get(procs)) do { # write the procedure name + write() + args := sort(get(procs), 3) # sorted arguments + while write(left(get(args), 20), right(get(args),6)) + write() + } + +end + + diff --git a/ipl/progs/icn2c.icn b/ipl/progs/icn2c.icn new file mode 100644 index 0000000..e668988 --- /dev/null +++ b/ipl/progs/icn2c.icn @@ -0,0 +1,97 @@ +############################################################################ +# +# File: icn2c.icn +# +# Subject: Program to assist Icon-to-C porting +# +# Author: Robert J. Alexander +# +# Date: March 11, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Filter to do some mundane aspects of conversion of Icon to C. +# +# - Reformats comments +# - Reformats line-continued strings +# - Changes := to = +# - Reformats procedure declarations +# - Changes end to "}" +# +############################################################################ + +procedure main(arg) + local c, comment, line, parenLevel, suffix, tline + + parenLevel := 0 + while line := trim(read(),' \t') do line ? { + line := comment := suffix := "" + ="procedure" & tab(many(' \t')) & suffix := " {" + ="end" & tab(many(' \t')) | pos(0) & line ||:= "}" + while line ||:= tab(upto('\'":#')) do { + case c := move(1) of { + "\"" | "'": { + # + # Handle character strings. + # + line ||:= c + repeat { + until line ||:= tab(find(c) + 1) do { + line ||:= tab(0) + if line[-1] == "_" then line[-1] := "\"" + else stop("unbalanced quotes") + Out(line) + line := "" + &subject := read() + line := (tab(many(' \t')) | "") || "\"" + } + if not (line[-2] == "\\" & not (line[-3] == "\\")) then break + } + } + "#": { + # + # Handle comments. + # + comment := trim(tab(0),' \t') + } + ":": { + # + # Change := to = + # + if ="=" then line ||:= "=" + else line ||:= c + } + "(": { + parenLevel +:= 1 + line ||:= c + } + ")": { + parenLevel -:= 1 + line ||:= c + } + default: line ||:= c + } + } + line ||:= tab(0) || suffix + tline := trim(line,' \t') + if not (parenLevel > 0 | *tline = 0 | + any('{}(!%&*+,-./:<=>?@\\^',tline,-1) | + (tline[-4:0] == ("else" | "then") & + not tline[-5] | any(' \t',tline[-5]))) then { + line := tline || ";" || line[*tline + 1:0] + } + Out(line,comment) + } +end + + +procedure Out(line,comment) + line ||:= "/*" || ("" ~== \comment) || " */" + line := trim(line,' \t') + write(line) + return +end diff --git a/ipl/progs/icontent.icn b/ipl/progs/icontent.icn new file mode 100644 index 0000000..51f461a --- /dev/null +++ b/ipl/progs/icontent.icn @@ -0,0 +1,75 @@ +############################################################################ +# +# File: icontent.icn +# +# Subject: Program to list Icon procedures +# +# Author: Robert J. Alexander +# +# Date: August 17, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Builds a list, in Icon comment format, of procedures and records +# in an Icon source file. +# +# 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. +# +# usage: icontent <options> <Icon source file>... +# options: -s sort names alphabetically (default is in +# order of occurrence) +# -l list in single column (default is to list +# in multiple columns) +# + +link options,colmize + +procedure main(arg) + local opt,linear,Colmize,Sort,namechar,fn,f,names,line,name,type + # + # Process command line options and file names. + # + opt := options(arg,"sl") + linear := opt["l"] + Colmize := if \opt["l"] then proc("!",1) else colmize + Sort := if \opt["s"] then sort else 1 + if *arg = 0 then arg := ["-"] # if no arguments, standard input + namechar := &letters ++ &digits ++ "_" + # + # Loop to process files. + # + every fn := !arg do { + f := if fn == "-" then &input else { + if not (fn[-4:0] == ".icn") then fn ||:= ".icn" + open(fn) | stop("Can't open input file \"",fn,"\"") + } + names := [] + write("# Procedures and Records", + if f === &input then "" else " in " || fn,":") + # + # Loop to process lines of file (in string scanning mode). + # + while line := read(f) do line ? { + if (tab(many(' \t')) | "")\1 & + type := (=("procedure" | "record"))\1 & + (tab(many(' \t')) | "")\1 & name := tab(many(namechar)) & + (tab(many(' \t')) | "")\1 & ="(" then { + put(names,name || if type == "procedure" then "()" else ".") + } + } + # + # Close this file. + # + close(&input ~=== f) + every write("# ",Colmize(Sort(names),71)) + } + # + # End of program. + # +end diff --git a/ipl/progs/icvt.icn b/ipl/progs/icvt.icn new file mode 100644 index 0000000..e7326d4 --- /dev/null +++ b/ipl/progs/icvt.icn @@ -0,0 +1,97 @@ +############################################################################ +# +# File: icvt.icn +# +# Subject: Program for ASCII/EBCDIC program conversion +# +# Author: Cheyenne Wills, modified by Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program converts Icon programs from ASCII syntax to EBCDIC syntax +# or vice versa. The option -a converts to ASCII, while the option +# -e converts to EBCDIC. The program given in standard input is written +# in converted form to standard output. +# +############################################################################ + +global outf,process,bb,quotechar +global nrbrack,nlbrack,nrbrace,nlbrace,rbrack,lbrack,rbrace,lbrace + +procedure main(args) + local line + + case map(args[1]) | stop("Usage: icvt -a | -e") of { + "-a" : { + lbrace := "$("; nlbrace := "{" + rbrace := "$)"; nrbrace := "}" + lbrack := "$<"; nlbrack := "[" + rbrack := "$>"; nrbrack := "]" + bb := '$' + } + "-e" : { + lbrace := "{"; nlbrace := "$("; + rbrace := "}"; nrbrace := "$)"; + lbrack := "["; nlbrack := "$<"; + rbrack := "]"; nrbrack := "$>"; + bb := '[]{}' + } + default : + stop("Usage: icvt -a | -e") + } + + process := standard + + while line := read() do { + line ||:= "\n" + line ? while not pos(0) do + process() + } + +end + +procedure standard() + writes(tab(upto( '"\'#' ++ bb))) | (writes(tab(0)) & return) + + if match("#") then { + writes(tab(0)) + } + else if any('\'"') then { + process := inquote + quotechar := move(1) + writes(quotechar) + } + else if match(lbrack) then { + move(*lbrack) + writes(nlbrack) + } + else if match(rbrack) then { + move(*rbrack) + writes(nrbrack) + } + else if match(lbrace) then { + move(*lbrace) + writes(nlbrace) + } + else if match(rbrace) then { + move(*rbrace) + writes(nrbrace) + } + else writes(move(1)) + return +end + +procedure inquote() + writes( tab(upto( quotechar ++ '\\')) ) | + (writes(tab(0)) & return) + writes(="\\") & writes(move(1)) & return + writes( =quotechar ) + process := standard + return +end diff --git a/ipl/progs/idepth.icn b/ipl/progs/idepth.icn new file mode 100644 index 0000000..cf3cd52 --- /dev/null +++ b/ipl/progs/idepth.icn @@ -0,0 +1,38 @@ +############################################################################ +# +# File: idepth.icn +# +# Subject: Program to report maximum recursion depth +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program processes trace output and reports the maximum depth of +# recursion. +# +############################################################################ + +procedure main() + local i, max + + max := 0 + + every !&input ? { + tab(upto('(')) ? { + i := 0 + every find("| ") do + i +:= 1 + max <:= i + } + } + + write(max) + +end diff --git a/ipl/progs/idxtext.icn b/ipl/progs/idxtext.icn new file mode 100644 index 0000000..c31bae0 --- /dev/null +++ b/ipl/progs/idxtext.icn @@ -0,0 +1,155 @@ +############################################################################ +# +# File: idxtext.icn +# +# Subject: Program for creating indexed text-base +# +# Author: Richard L. Goerwitz +# +# Date: July 9, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.15 +# +############################################################################ +# +# idxtext turns a file associated with gettext() routine into an +# indexed text-base. Though gettext() will work fine with files +# that haven't been indexed via idxtext(), access is faster if the +# indexing is done if the file is, say, over 10k (on my system the +# crossover point is actually about 5k). +# +# Usage is simply "idxtext [-a] file1 [file2 [...]]," where file1, +# file2, etc are the names of gettext-format files that are to be +# (re-)indexed. The -a flag tells idxtext to abort if an index file +# already exists. +# +# Indexed files have a very simple format: keyname delimiter offset +# [delimiter offset [etc.]]\n. The first line of the index file is a +# pointer to the last indexed byte of the text-base file it indexes. +# +# BUGS: Index files are too large. Also, I've yet to find a portable +# way of creating unique index names that are capable of being +# uniquely identified with their original text file. It might be +# sensible to hard code the name into the index. The chances of a +# conflict seem remote enough that I haven't bothered. If you're +# worried, use the -a flag. (RLG) +############################################################################ +# +# Links: adjuncts +# +# Tested with: MS-DOS, MS-DOS/386, OS/2, ProIcon, UNIX +# +# See also: gettext.icn +# +# Modified by Phillip Lee Thomas +# History: modified link and local statements. +# modified to run under OS/2 and ProIcon. +# Added exit() statement. +# Move OS declarations to Set_OS() in adjuncts.icn. +# Allow multiple indexed values. +# +# Version 1.15 (August 5, 1995) +# Use preprocessor include statement rather than link. +# Allow multiple index keys for a stretch of text: +# Example: +# ::key one ::key two ::another key +# Multiple lines of text which are retrieved +# by searching for these three keys. +# ::key for another stretch of text +# A second bit of text. +# +# +############################################################################ +# +# Links: adjuncts +# +############################################################################ + +link adjuncts + +# declared in adjuncts.icn +# global _slash, _baselen, _delimiter + +procedure main(a) + + local ABORT, idxfile_name, fname, infile, outfile + + Set_OS() + + if \a[1] == "-a" then ABORT := pop(a) + + # Check to see if we have any arguments. + + if find("Macintosh", &features) then { + writes("Enter file name for indexing: ") + a := [read()] + } + else { + *a = 0 & stop("usage: idxtext [-a] file1 [file2 [...]]") + } + + # Start popping filenames off of the argument list. + + while fname := pop(a) do { + + # Open input file. + + infile := open(fname) | + { write(&errout, "idxtext: ",fname," not found"); next } + + # Get index file name. + + idxfile_name := Pathname(fname) || getidxname(fname) + if \ABORT then if close(open(idxfile_name)) then + stop("idxtext: index file ",idxfile_name, " already exists") + outfile := open(idxfile_name, "w") | + stop("idxtext: can't open ", idxfile_name) + + # Write index to index.IDX file. + + write_index(infile, outfile) + every close(infile | outfile) + } + exit() +end + + +procedure write_index(in, out) + + local key_offset_table, w, line, KEY + + # Write to out all keys in file "in," with their byte + # offsets. + + key_offset_table := table() + + while (w := where(in), line := read(in)) do { + line ? { + while ="::" do { + KEY := trim(tab(find("::") | 0)) + if not (/key_offset_table[KEY] := KEY || _delimiter || w) + then key_offset_table[KEY] ||:= _delimiter || w + } + } + } + + # First line of index contains the offset of the last + # indexed byte in write_index, so that we can still + # search unindexed parts of in. + + write(out, where(in)) + + # Write sorted KEY\toffset lines. + + if *key_offset_table > 0 then { + every write(out, (!sort(key_offset_table))[2]) + return + } + else stop("No indexed items found.") +end diff --git a/ipl/progs/ifilter.icn b/ipl/progs/ifilter.icn new file mode 100644 index 0000000..484be42 --- /dev/null +++ b/ipl/progs/ifilter.icn @@ -0,0 +1,86 @@ +############################################################################ +# +# File: ifilter.icn +# +# Subject: Program to filter lines of file +# +# Author: Ralph E. Griswold +# +# Date: January 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program applies the operation given as a command-line argument +# to each line of standard input, writing out the results. For example, +# +# ifilter reverse <foo +# +# writes out the lines of foo reversed end-for-end. +# +# Trailing arguments can be given on the command line, as in +# +# ifilter right 10 0 <foo # right(*, "10", "0") +# ifilter "%" 11 <foo # * % "11" +# +# The modules strings and numbers are linked to provide access to the +# procedures they contain. Except for these and operators and (built-in) +# functions, this program needs to be linked with procedures to be +# used with it. +# +# The following options are supported: +# +# -a i argument position for strings read in; default 1 +# -o i resolution of ambiguous operator string names, 1 for unary, 2 +# for binary; default 2 +# -l i limit on generation, with nonpositive indicating +# no limitation; default 1 +# +############################################################################ +# +# Note: This is a renaming of an earlier program, filter.icn, to +# avoid name collisions on systems where there already is a utility +# named filter. +# +############################################################################ +# +# Links: lists, numbers, options, and strings +# +############################################################################ + +invocable all + +link lists +link numbers +link options +link strings + +procedure main(args) + local op, opts, i, interp, limit + + opts := options(args, "a+o+l+") + i := \opts["a"] | 1 + limit := \opts["l"] | 1 + if limit < 1 then limit := 2 ^ 31 + + if opts["o"] === (&null | 2) then { + op := proc(pop(args), 2 | 1 | 3) | + stop("*** invalid or missing operation") + } + else if opts["o"] = 1 then { + op := proc(pop(args), 1 | 2 | 3) | + stop("*** invalid or missing operation") + } + else stop("*** invalid -o option") + + lextend(args, i - 1) # be sure list is long enough + + args := args[1:i] ||| [&null] ||| args[i:0] # make room for input argument + + while args[i] := read() do + every write(op ! args) \ limit + +end diff --git a/ipl/progs/ifncsgen.icn b/ipl/progs/ifncsgen.icn new file mode 100644 index 0000000..ad4950f --- /dev/null +++ b/ipl/progs/ifncsgen.icn @@ -0,0 +1,67 @@ +############################################################################ +# +# File: ifncsgen.icn +# +# Subject: Program to generate procedure wrappers for functions +# +# Author: Ralph E. Griswold +# +# Date: September 28, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program generates a procedure for every (built-in) function +# that calls the function. +# +############################################################################ + +procedure main() + local name, args, uname + static case1, case2 + + initial { + case1 := &lcase || &ucase + case2 := &ucase || &lcase + } + + every name := function() do { + args := arglist(name) + uname := { + name ? { + map(move(1), case1, case2) || tab(0) + } + } + write("procedure ", uname, args) + write(" static ", "__fnc_", name) + write(" initial __fnc_", name, " := proc(", image(name), ", 0)") + if args == "(a[])" then write(" suspend __fnc_", name, " ! a") + else write(" suspend __fnc_", name, args) + write("end") + write() + } + +end + +procedure arglist(name) + local result, i, arg + + i := args(proc(name, 0)) + + if i < 0 then return "(a[])" + else if i = 0 then return "()" + else { + result := "(" + every arg := ("a" || (1 to i)) do { + result ||:= arg || ", " + } + } + + result[-2:0] := ")" + + return result + +end diff --git a/ipl/progs/igrep.icn b/ipl/progs/igrep.icn new file mode 100644 index 0000000..2b17313 --- /dev/null +++ b/ipl/progs/igrep.icn @@ -0,0 +1,187 @@ +############################################################################ +# +# File: igrep.icn +# +# Subject: Program for string search similar to egrep +# +# Author: Robert J. Alexander +# +# Date: May 1, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to emulate UNIX egrep, but using the enhanced regular +# expressions supported by regexp.icn. Options supported are nearly +# identical to those supported by egrep (no -b: print disk block +# number). There is one additional option, -E, to allow Icon-type +# (hence C-type) string escape sequences in the pattern string. +# BEWARE: when -E is used, backslashes that are meant to be processed +# in the regular expression context must be doubled. The following +# patterns are equivalent: +# +# without -E: '\bFred\b' +# with -E: '\\bFred\\b' +# +# To enable the -D option (intended mainly for debugging), the Icon +# Program Library file "ximage" must be linked with this program. +# +############################################################################ + +procedure Usage(n) + write(&errout, + "igrep -- emulates UNIX egrep\n_ + Usage: igrep -Options [expression] filename..._ + \n Options:_ + \n c print count of matching lines rather than actual lines_ + \n h don't display file names_ + \n i ignore case of letters_ + \n l list only the names of files containing matching lines_ + \n n precede lines with line numbers_ + \n s work silently -- display nothing_ + \n v invert search to display only lines that don't match_ + \n e expr useful if expressions starts with -_ + \n E expr expresson containing Icon escape sequences_ + \n f file take list of alternated expressions from \"file\"" +# ,if \xdump then +# "\n D dump compiled pattern and quit" else "" +) + exit(n) +end + +link options,regexp + +procedure main(arg) + local compiledPattern + if *arg = 0 then Usage() + Options(arg) + compiledPattern := GetPattern(arg) | + {write(&errout,"Bad pattern ",image(Pattern)) ; exit(2)} +# if \Dump then (\xdump)(compiledPattern) + exit(ScanFiles(arg,compiledPattern)) +end + +global CountOnly,NoNames,NamesOnly,NumberLines,Out,Invert,Escapes, + Pattern,PatternFile,Dump,Re_LeftmostShortest + +procedure Options(arg) + local opt + opt := options(arg,"chilnsve:E:f:DS") + CountOnly := opt["c"] + NoNames := opt["h"] + if \opt["i"] then Re_Filter := map + NamesOnly := opt["l"] + NumberLines := opt["n"] + Out := if \opt["s"] then &null else &output + Invert := opt["v"] + Pattern := \opt["e" | "E"] + Escapes := opt["E"] + PatternFile := opt["f"] + Dump := opt["D"] + Re_LeftmostShortest := (\opt["S"],&null) | 1 + return opt +end + +procedure GetPattern(arg) + local f,sep + if \PatternFile then { + f := open(PatternFile) | + stop("Can't open pattern file \"",PatternFile,"\"") + (/Pattern := "" & sep := "") | (sep := "|") + while Pattern ||:= sep || read(f) do sep := "|" + close(f) + } + /Pattern := get(arg) + if /Pattern then Usage(2) + return RePat(if \Escapes then istring(Pattern) else Pattern) +end + +procedure ScanFiles(arg,pattern) + local errors,totalCount,fn,f,header,lineNbr,count,line,fLine,status, + lineNbrTag + totalCount := 0 + if *arg = 0 then arg := ["-"] + every fn := !arg do { + f := if fn == "-" then &input else open(fn) | + {write(&errout,"Can't open \"",fn,"\" -- skipped") ; errors := 2 ; + next} + header := if \NoNames | *arg = 1 then &null else fn || ":" + lineNbr := count := 0 + while line := read(f) do { + lineNbr +:= 1 + fLine := (\Re_Filter)(line) | line + status := ReFind(pattern,fLine) | &null + status := if \Invert then (\status,&null) | 1 + if \status then { + count +:= 1 + if count = 1 & \NamesOnly then {write(\Out,fn) ; next} + lineNbrTag := if \NumberLines then lineNbr || ":" else &null + if not \(CountOnly | NamesOnly) then + write(\Out,header,lineNbrTag,line) + } + } + close(f) + if \CountOnly then write(header,count) + totalCount +:= count + } + ## if \CountOnly & *arg > 1 then write(\Out,"** Total ** ",totalCount) + return \errors | if totalCount = 0 then 1 else 0 +end + +# +# istring() -- Procedure to convert a string containing special escape +# constructs, of the same format as Icon source language character +# strings, to their true string representation. Value returned is the +# string with special constructs converted to their respective +# characters. +# + +procedure istring(s) + local r,c + r := "" + s ? { + while r ||:= tab(upto('\\')) do { + move(1) + r ||:= case c := map(move(1)) of { + "b": "\b" # backspace + "d": "\d" # delete (rubout) + "e": "\e" # escape (altmode) + "f": "\f" # formfeed + "l": "\l" # linefeed (newline) + "n": "\n" # newline (linefeed) + "r": "\r" # carriage return + "t": "\t" # horizontal tab + "v": "\v" # vertical tab + "x": istring_radix(16,2)# hexadecimal code + "^": char(ord(move(1)) % 32) | break # control code + default: { # either octal code or non-escaped character + if any('01234567',c) then { # if octal digit + move(-1) + istring_radix(8,3) + } + else c # else non-escaped character + } | break + } + } + r ||:= tab(0) + } + return r +end + +procedure istring_radix(r,max) + local n,d,i,c + d := "0123456789abcdef"[1:r + 1] + n := 0 + every 1 to max do { + c := move(1) | break + if not (i := find(map(c),d) - 1) then { + move(-1) + break + } + n := n * r + i + } + return char(n) +end diff --git a/ipl/progs/iheader.icn b/ipl/progs/iheader.icn new file mode 100644 index 0000000..2bc3fb8 --- /dev/null +++ b/ipl/progs/iheader.icn @@ -0,0 +1,56 @@ +############################################################################ +# +# File: iheader.icn +# +# Subject: Program to list Icon program library headers +# +# Author: Ralph E. Griswold +# +# Date: June 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists the headers of Icon programs whose file names are +# given on the command line. It complains if the header does not start +# correctly but otherwise does not check the syntax of what follows. +# +############################################################################ + +global input + +procedure main(args) + local file, line, bar + + bar := repl("#", 76) + + every file := !args do { + write(file, ":") + input := open(file) | { + write("*** cannot open file") + close(\input) + next + } + line := read(input) | { + write("*** empty file") + close(\input) + next + } + if line ~== bar then { + write("*** invalid first line") + close(\input) + next + } + while line := read(input) do { + if line == bar then { + close(input) + break + } + else write(line) + } + } + +end diff --git a/ipl/progs/ihelp.icn b/ipl/progs/ihelp.icn new file mode 100644 index 0000000..71a905c --- /dev/null +++ b/ipl/progs/ihelp.icn @@ -0,0 +1,94 @@ +############################################################################ +# +# File: ihelp.icn +# +# Subject: Program to give on-line help for Icon +# +# Author: Robert J. Alexander +# +# Date: December 5, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# ihelp -- Program to display "help" information +# +# ihelp [-f helpfile] [item] [keyword ...] +# +# The optional item name specifies the section of the help file which +# is to be displayed. If no item name is specified a default section +# will be displayed, which usually lists the help items that are +# available. An initial substring of the item name that differentiates +# it from other items is sufficient. +# +# If keyword(s) are specified, then only lines that contain all of the +# keywords, in any order, are displayed. The keywords do not have to +# correspond to whole words in the help text; only to text fragments. +# +# All item name and keyword matches are case independent. +# +# The help file name is taken from environment variable "HELPFILE". If +# HELPFILE is not in the environment, file "help" in the current +# directory is used. A help file name specified in the -f option +# overrides. +# +# The help files are formatted as follows: +# +# default text lines +# - +# one +# item "one" text lines +# - +# two +# item "two" text lines +# ... +# +# Sections are separated by lines containing a single "-". Item names +# are the first line following a separator line. +# +############################################################################ +# +# Links: options +# +############################################################################ + + +link options + + +procedure main(arg) + local defaultHelpFile, opts, fn, f, item, line, keywords, i, lline, k + + # + # Initialize. + # + defaultHelpFile := "ihelp.dat" + opts := options(arg,"f:") + fn := \opts["f"] | "" ~== getenv("HELPFILE") | defaultHelpFile + f := open(fn) | stop("Can't open help file \"",fn,"\"") + # + # Look for the specified section, if one was. + # + if item := map(arg[1]) then { + line := "" + until item == map(line[1:*item + 1]) do { + while read(f) ~== "-" + line := read(f) | stop("No help for ",item) + } + } + # + # Output the section lines that contain the keywords. + # + write(line) + keywords := arg[2:0] | [] + every i := 1 to *keywords do keywords[i] := map(keywords[i]) + while "-" ~== (line := read(f)) do { + lline := map(line) + if not (every k := !keywords do if not find(k,lline) then break) then + write(line) + } +end + diff --git a/ipl/progs/iidecode.icn b/ipl/progs/iidecode.icn new file mode 100644 index 0000000..3aaa760 --- /dev/null +++ b/ipl/progs/iidecode.icn @@ -0,0 +1,248 @@ +############################################################################ +# +# File: iidecode.icn +# +# Subject: Program to decode text in style of uudecode +# +# Author: Richard L. Goerwitz, enhanced by Frank J. Lhota +# +# Date: May 2, 2001 +# +########################################################################### +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 2.0 +# +########################################################################### +# +# This is an Icon port of the UNIX/C uudecode utility. Since +# uudecode is publicly distributable BSD code, I simply grabbed a +# copy, and rewrote it in Icon. The only basic functional changes I +# made to the program were: (1) To simplify the notion of file mode +# (everything is encoded with 0644 permissions), and (2) to add a +# command-line switch for xxencoded files (similar to uuencoded +# files, but capable of passing unscathed through non-ASCII EBCDIC +# sites). +# +# usage: iidecode [infile] [-x] +# +# Usage is compatible with that of the UNIX uudecode command, i.e. a +# first (optional) argument gives the name the file to be decoded. +# If this is omitted, iidecode just uses the standard input. The -x +# switch (peculiar to iidecode) forces use of the the xxdecoding +# algorithm. If you try to decode an xxencoded file without speci- +# -x on the command line, iidecode will try to forge ahead anyway. +# If it thinks you've made a mistake, iidecode will inform you after +# the decode is finished. +# +# +# FIXES: Speeded up substantially (more than twice as fast on my +# machine) by using a more icon-ish algorithm. We decode in two +# steps: +# +# 1) The coded characters are mapped to "small bytes", +# each with 2 zero high bits, i.e. <<= "\x3F". +# 2) We then 'pack' the small bytes by taking groups of 4 small bytes +# (each with 2 zero high bits and 6 data bits) and packing +# the data bits into groups of 3 bytes. +# +# There are numerous advantages to this approach. The icon map +# function is much faster than the 'C'-ish alternatives. We can +# process things one line at a time. Also, the different decoding +# mechanisms (old BSD, new BSD, xxdecode) can be produces by simply +# using different map parameters. +# +############################################################################ +# +# See also: iiencode.icn +# +############################################################################ + +link options + +global oversizes + +procedure main ( a ) + + local opt, in, out, dest, is_xx + initial oversizes := 0 + + + opt := options ( a, "-x" ) + is_xx := opt [ "x" ] + + # Check for correct number of args. + case *a of + { + 0 : in := &input + 1 : in := open ( a [ 1 ], "r" ) | + { + write ( &errout, "Can't open input file, ", a [ 1 ], ".\n_ + usage: iidecode [infile] [-x]" ) + exit ( 1 ) + } + default : + { + write ( &errout, "usage: iidecode [infile] [-x]" ) + exit ( 2 ) + } + } + + + # Find the "begin" line, and determine the destination file name. + !in ? { + ="begin " & + tab ( many ( &digits ) ) & # mode ignored + tab ( many ( ' ' ) ) & + dest := tab ( 0 ) + } + + # If dest is null, the begin line either isn't present, or is + # corrupt (which necessitates our aborting with an error msg.). + if /dest then { + write ( &errout, "No begin line." ) + exit ( 3 ) + } + + # Tilde expansion is heavily UNIX dependent, and we can't always + # safely write the file to the current directory. Our only choice + # is to abort. + if match ( "~", dest ) then { + write ( &errout, "Please remove ~ from input file begin line." ) + exit ( 4 ) + } + + out := open ( dest, "wu" ) + decode ( in, out, is_xx ) # decode checks for "end" line + if not match ( "end", !in ) then { + write ( &errout, "No end line.\n" ) + exit ( 5 ) + } + + # Check global variable oversizes (set by decode) + # to see if we used the correct decoding algorithm. + if oversizes > 0 then { + if \is_xx then { + write ( &errout, "Input file appears to have been uuencoded.\n_ + Try invoking iidecode without the -x arg." ) + } + else { + write ( &errout, "Input file is either corrupt, or xxencoded.\n_ + Please check the output; try the -x option." ) + } + } + + every close ( ( &input ~=== in ) | out ) + + exit ( 0 ) + +end + +########################################################################### +# +# Reads encoded lines from file in, decodes them, +# and writes the decoded data# to out. +# "uu" decoding is done unless \is_xx, in which case "xx" decoding is done. +# +########################################################################### +procedure decode(in, out, is_xx) + + # Copy from in to out, decoding as you go along. + + + local line, n, coded, unpacked, badchars + + if \is_xx then { + coded := "_ + +-0123456789ABCD_ + EFGHIJKLMNOPQRST_ + UVWXYZabcdefghij_ + klmnopqrstuvwxyz" + unpacked := "_ + \x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F_ + \x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F_ + \x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F_ + \x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F" + } + else { + # + # To be safe, we map both " " and "`" to "\x00" + # + coded := " _ + !\"#$%&'()*+,-./_ + 0123456789:;<=>?_ + @ABCDEFGHIJKLMNO_ + PQRSTUVWXYZ[\\]^_`" + unpacked := "_ + \x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F_ + \x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F_ + \x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F_ + \x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F\x00" + } + + badchars := ~ coded + + while line := read ( in ) do { + + if *line = 0 then { + write ( &errout, "Short file.\n" ) + exit ( 10 ) + } + + line ? while tab ( upto ( badchars ) + 1 ) do oversizes +:= 1 + + map ( line, coded, unpacked ) ? { + n := ord ( move ( 1 ) ) + line := tab ( 0 ) + + if not ( *line % 4 = 0, n <= ( ( *line / 4 ) * 3 ) ) then { + write ( &errout, "Short and/or corrupt line:\n", line ) + if /is_xx & oversizes > 0 then + write ( &errout, "Try -x option?" ) + exit ( 15 ) + } + + # Uuencode signals the end of the coded text by a space + # and a line (i.e. a zero-length line, coded as a space). + if n <= 0 then break + + writes ( out, left ( repack ( line ), n ) ) + } + } + + return + +end + + +########################################################################### +# +# Takes groups of 4 bytes in s (each byte should have 2 zero high bits) +# and packs the 6 lower data bits into group of 3 bytes. +# +########################################################################### +procedure repack ( s ) + + local n, grp + + s ? { + s := "" + while grp := move ( 4 ) do + { + n := 0 + grp ? while n := ord ( move ( 1 ) ) % 16r40 + ( n * 16r40 ) + + s ||:= + char ( ishift ( iand ( n, 16rFF0000 ), -16 ) ) || + char ( ishift ( iand ( n, 16r00FF00 ), - 8 ) ) || + char ( iand ( n, 16r0000FF ) ) + } + } + + return s + +end + diff --git a/ipl/progs/iiencode.icn b/ipl/progs/iiencode.icn new file mode 100644 index 0000000..706b846 --- /dev/null +++ b/ipl/progs/iiencode.icn @@ -0,0 +1,217 @@ +############################################################################ +# +# File: iiencode.icn +# +# Subject: Program to encode text in the style of uuencode +# +# Author: Richard L. Goerwitz, enhanced by Frank J. Lhota +# +# Date: May 2, 2001 +# +########################################################################### +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 2.0 +# +########################################################################### +# +# This is an Icon port of the UNIX/C uuencode utility. Since +# uuencode is publicly distributable BSD code, I simply grabbed a +# copy, and rewrote it in Icon. The only basic functional changes I +# made to the program were: (1) To simplify the notion of file mode +# (everything is encoded with 0644 permissions), and (2) to add sup- +# port for xxencode format (which will generally pass unscathed even +# through EBCDIC sites). +# +# Iiencode's usage is compatible with that of the UNIX uuencode +# command, i.e. a first (optional) argument gives the name the file +# to be encoded. If this is omitted, iiencode just uses the standard +# input. The second argument specifies the name the encoded file +# should be given when it is ultimately decoded. +# +# Extensions to the base uuencode command options include -x and -o. +# An -x tells iiencode to use xxencode (rather than uuencode) format. +# Option -o causes the following argument to be used as the file +# iiencode is to write its output to (the default is &output). Note +# that, on systems with newline translation (e.g. MS-DOS), the -o +# argument should always be used. +# +# iiencode [infile] [-x] remote-filename [-o output-filename] +# +# +# FIXES: Speeded up substantially (more than twice as fast on my +# machine) by using a more icon-ish algorithm. We encode in two +# steps: +# +# 1) We first "unpack" the bytes by taking groups of 3 bytes (24 +# bits) and spreading them out by inserting two 0 bits before +# every block of 6 bits. The result is that each group of 3 +# bytes is unpacked to 4 "small bytes", each <<= "\x3F". +# 2) The unpacked bytes are mapped to the coded line by using the +# Icon map function. +# +# There are numerous advantages to this approach. The Icon map +# function is much faster than the 'C'-ish alternatives. We can +# process the file one line at a time. Also, the different encoding +# mechanisms (old BSD, new BSD, xxencode) can be produces by simply +# using different map parameters. +# +############################################################################ +# +# See also: iidecode.icn +# +############################################################################ + +link options + +procedure main ( a ) + + local in_filename, out_filename, in, out, is_xx, remotename, opt + + # Parse arguments. + + opt := options ( a, "-o:-x", Usage ) + is_xx := opt [ "x" ] + out_filename := opt [ "o" ] + case *a of { + 1 : + in_filename := remotename := a [ 1 ] + 2 : + { + in_filename := a [ 1 ] + remotename := a [ 2 ] + } + default : + Usage ( "", write, 2 ) + } + + # If no input filename was supplied, use &input. + if /in_filename then + in := &input + else + in := open ( in_filename, "ru" ) | + Usage ( "Can't open input file " || in_filename || "." ) + + # If an output filename was specified, open it for writing. + if /out_filename then + out := &output + else + out := open ( out_filename, "w" ) | + Usage ( "Can't open output file " || out_filename || "." ) + + # This generic version of uuencode treats file modes in a primitive + # manner so as to be usable in a number of environments. Please + # don't get fancy and change this unless you plan on keeping your + # modified version on-site (or else modifying the code in such a + # way as to avoid dependence on a specific operating system). + write ( out, "begin 644 ", remotename ) + encode ( out, in, is_xx ) + write ( out, "end" ) + + every close ( ( &input ~=== in ) | ( &output ~=== out ) ) + exit ( 0 ) + +end + +########################################################################### +# +# Writes msg and the Usage line to &errout using the output procedure Show, +# which defaults to stop. If Show does not stop processing and \errcode, +# exit with errcode. +# +########################################################################### +procedure Usage ( msg, Show, errcode ) + static usage + initial usage := "usage: iiencode [infile] [-x] _ + remote-filename [-o output-filename]" + + /Show := stop + Show ( &errout, msg, "\n", usage ) + exit ( \errcode ) + return msg +end + +########################################################################### +# +# Reads all of file in, encodes it, and writes the encoded lines to out. +# "uu" encoding is used unless \is_xx, in which case "xx" encoding is used. +# +########################################################################### +procedure encode ( out, in, is_xx ) + + # Copy from in to out, encoding as you go along. + + local line, coded + static unpacked + initial unpacked := "_ + \x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F_ + \x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F_ + \x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F_ + \x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F" + + if \is_xx then { + coded := "_ + +-0123456789ABCD_ + EFGHIJKLMNOPQRST_ + UVWXYZabcdefghij_ + klmnopqrstuvwxyz" + } + else { + # + # To get the BSD old code, replace the next 2 lines with: + # coded := " _ + # !\"#$%&'()*+,-./_ + # + coded := "_ + `!\"#$%&'()*+,-./_ + 0123456789:;<=>?_ + @ABCDEFGHIJKLMNO_ + PQRSTUVWXYZ[\\]^_" + } + + # 1 (up to) 45 character segment + while line := reads ( in, 45 ) do { + write ( out, + map ( char ( *line ) || unpack ( line ), unpacked, coded ) + ) + } + + # Output a zero-length line. + write ( out, coded [ 1 ] ) + +end + +########################################################################### +# +# Takes groups of 3 bytes in s and expands the groups to 4 bytes. Each +# byte in the unpacked group has 2 zero high bits, i.e. is <<= "\x3F". +# If *s is not divisible by 3, we pad s with blanks on the right +# to make up the last group. +# +########################################################################### +procedure unpack ( s ) + + local n, grp + + s ? { + s := "" + + while grp := ( move ( 3 ) | left ( "" ~== tab ( 0 ), 3 ) ) do + { + n := 0 + grp ? while n := ord ( move ( 1 ) ) + ( n * 16r100 ) + + s ||:= + char ( ishift ( iand ( n, 16rFC0000 ), -18 ) ) || + char ( ishift ( iand ( n, 16r03F000 ), -12 ) ) || + char ( ishift ( iand ( n, 16r000FC0 ), - 6 ) ) || + char ( iand ( n, 16r00003F ) ) + } + } + + return s + +end diff --git a/ipl/progs/ilnkxref.icn b/ipl/progs/ilnkxref.icn new file mode 100644 index 0000000..73b0d85 --- /dev/null +++ b/ipl/progs/ilnkxref.icn @@ -0,0 +1,108 @@ +############################################################################ +# +# File: ilnkxref.icn +# +# Subject: Program to produce Icon link cross reference +# +# Author: Robert J. Alexander +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Utility to create cross reference of library files used in Icon +# programs (i.e., those files named in "link" declarations). +# +# ilnkxref [-options] <icon source file>... +# +# options: +# +# -p sort by "popularity" +# -v report progress information +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ +# +# Links: wrap, options, sort +# +############################################################################ + +link wrap, options, sort + +procedure main(arg) +local comma, f, fill, fn, head, heads, i, libname, line, linesize, maxfile, + maxlib, opt, p, popularity, proctable, root, sep, spaces, verbose, x + # + # Initialize + # + opt := options(arg,"pv") + popularity := opt["p"] # sort by popularity + verbose := opt["v"] # report progress + 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 { + if \verbose then 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 { + if \verbose 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() + proctable := sort(proctable) + if \popularity then proctable := isort(proctable,popproc) + every x := !proctable do { + head := left(x[1],maxlib + 3) + heads := [left("(" || *x[2] || ")",maxlib + 3), + fill := repl(" ",*head)] + linesize := 78 - *head + every x := !sort(x[2]) do + if write(head,wrap(left(x,maxfile + 2),linesize)) then + head := get(heads) + write(head,wrap()) + } +end + +procedure popproc(x) + return -*x[2] +end diff --git a/ipl/progs/ilump.icn b/ipl/progs/ilump.icn new file mode 100644 index 0000000..caf9c4a --- /dev/null +++ b/ipl/progs/ilump.icn @@ -0,0 +1,104 @@ +############################################################################ +# +# File: ilump.icn +# +# Subject: Program to lump linked Icon source files +# +# Author: Gregg M. Townsend +# +# Date: November 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# usage: ilump [file...] +# +# ilump copies one or more Icon source files, incorporating recursively +# the source code for files named by "link" directives. This produces a +# standalone source program in one file, which is useful with certain +# profiling and visualization tools. +# +# Searching for link'd source files is similar to the action of Iconc +# under UNIX. If a link'd file is not found in the current directory, +# directories specified by the LPATH environment variable are tried. +# +############################################################################ + + +global path, todo + + +procedure main(args) + local fname + + path := [""] + getenv("LPATH") ? repeat { + tab(many(' ')) + if pos(0) then + break + put(path, tab(upto(' ')|0) || "/") + } + todo := args + if *todo = 0 then + dofile(&input) + while fname := get(todo) do + dofile(newfile(fname)) +end + + +# newfile(fname) -- open and return a file, if it wasn't seen earlier + +procedure newfile(fname) + local f, fullname + static done + initial done := set() + + if member(done, fname) then + fail + insert(done, fname) + if f := open(fullname := !path || fname) then { + write("\n\n\n#", right(" " || fullname, 78, "="), "\n\n\n") + return f + } + else { + write(&errout, "can't open ", fname) + write("\n\n\n#", right(" can't open " || fname, 78, "="), "\n\n\n") + fail + } +end + + +# dofile(f) -- copy one file, stacking file names seen on link directives + +procedure dofile(f) + local line, base + static idset + initial idset := &letters ++ &digits ++ '_' + + while line := read(f) do { + line ? { + tab(many(' \t')) + if ="link" & not any(idset) then { + write("#====== ", line) + repeat { + tab(many(' \t,')) + if pos(0) | ="#" then + break + if ="\"" then + base := tab(upto('"')|0) + else + base := tab(many(idset)) | break + put(todo, base || ".icn") + } + } + else { + write(line) + } + } + } + + close(f) +end diff --git a/ipl/progs/imagetyp.icn b/ipl/progs/imagetyp.icn new file mode 100644 index 0000000..15e702e --- /dev/null +++ b/ipl/progs/imagetyp.icn @@ -0,0 +1,109 @@ +############################################################################ +# +# File: imagetyp.icn +# +# Subject: Program to show types of image files +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program accepts file names from standard input and writes their +# image type to standard output. +# +# imagetyp(s) attempts to determine the type of image file named s. +# This is, of course, problematical and corrupted or fake files can +# easily fool it. Furthermore, examples of some image files types +# were not available for testing. +# +# The types presently recognized are: +# +# value returned image file type +# +# ps PostScript document +# cgm text Computer Graphics Metafile, text +# cgm binary Computer Graphics Metafile, binary +# cgm char Computer Graphics Metafile, character +# sundraw SunDraw document +# ras UNIX raster image +# iris Iris image +# rle UNIX RLE image +# pbm PBM image +# pgm PGM image +# ppm PPM image +# xwd X Window dump +# gif Compuserv GIF image +# bmp BMP image +# xmp XMP image +# xpm XPM image +# pcx PCX image +# tiff TIFF image +# iff IFF/ILBM image +# ? unknown type +# +# If the file cannot be opened or is empty, imagetyp() fails. +# +############################################################################ +# +# Links: bincvt +# +############################################################################ + +link bincvt + +procedure main() + local s + + while s := writes(read()) do write(" ", imagetyp(s)) + +end + +procedure imagetyp(s) + local input, header, type + + input := open(s, "u") | fail # must be untranslated + + header := reads(input, 640) | fail + + type := { + header ? { + if ="%!" then "ps" + else if ="\x59\xa6\x6a\x95" then "ras" + else if ="\122\314" then "rle" + else if ="GIF8" then "gif" + else if =("\111\111\52\0" | "\115\115\0\52") then "tiff" + else if find("BMHD") then "iff" + else if find("PNTG") then "mac paint" + else if ="BEGMF" then "cgm text" + else if ="\001\332" then "iris" + else if ="#define" & find("width ") then "xbm" + else if ="/* XPM */" then "xpm" + else if =("P1" | "P4") then "pbm" + else if =("P2" | "P5") then "pgm" + else if =("P3" | "P6") then "ppm" + else if move(4) & raw(move(4)) = 7 then "xwd" + else if move(10) & ="sundraw" then "sundraw" + else if raw(move(2)) = 12320 then "cgm char" + else if iand(raw(move(2)), 65504) = 32 then "cgm binary" + else if ="\x0a" & raw(move(1)) = (0 | 2 | 3 | 4 | 5) & tab(65) & + raw(move(1)) = 0 then "pcx" + else if move(512) & move(11) & =("\x11" | "\x00\x11") then "pict" + else &fail # none of that worked + } + } + + if \type then return type + + seek(input, -17) # and now for one at the end ... + + if read(input) == "TRUEVISION-TARGA\x0" then return "targa" + + return "?" # who knows? + +end diff --git a/ipl/progs/indxcomp.icn b/ipl/progs/indxcomp.icn new file mode 100644 index 0000000..cc89de7 --- /dev/null +++ b/ipl/progs/indxcomp.icn @@ -0,0 +1,103 @@ +############################################################################ +# +# File: indxcomp.icn +# +# Subject: Program to assist in index compilation +# +# Author: Ralph E. Griswold +# +# Date: June 23, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to assist in the compilation of indexes. +# +# It takes input from standard input and expects lines that either consist +# of an integer (taken to be a page number) or text (to be indexed on +# page of the last page number. +# +# The idea is to go through the work to be indexed and create a file +# in which the page number is entered followed by items to be indexed +# on that page. Page numbers (which need not be numeric) are prefixed +# by "=". For example, the file might consist of +# +# =1 +# warts +# moles +# scratches +# =2 +# scratches +# dents +# bumps +# =3 +# hickies +# +# The output of this program for that input is: +# +# bumps, 2 +# dents, 2 +# hickies, 3 +# moles, 1 +# scratches, 1, 2 +# warts, 1 +# +# Leading blanks are stripped from index items. Therefore to enter +# an index item that begins with "=" start with " =" instead. +# +# This program is unsophisticated. It contains no provisions for +# formatting index entries nor any way to indicated inclusive page +# ranges. Such things have to be done in post-processing. +# +# non-numeric page "numbers" appear before numeric ones. +# +# Obviously, there is room for improvement, embellishment, and creeping +# featurism. +# +############################################################################ + +procedure main() + local index, page, line, lines, temp1, temp2, x, xcase + local lline + + index := table() + xcase := table(" *** empty line") + page := "<no page number>" # in case file doesn't start with a page number + + while line := read() do { + line ? { + if ="=" then { + page := tab(0) + page := integer(page) # for sorting; may fail + if page === "" then page := "<empty page number>" + next + } + } + line ?:= (tab(many(' ')), tab(0)) # trim leading blanks + if *line = 0 then next + lline := map(line) + xcase[lline] := line + if lline == "" then lline := " *** empty line" + /index[lline] := set() + insert(index[lline], page) + } + + index := sort(index, 3) + + while writes(xcase[get(index)]) do { + lines := sort(get(index)) + temp1 := [] + temp2 := [] + while x := get(lines) do { + if type(x) == "string" then put(temp1, x) + else put(temp2, x) + } + lines := temp1 ||| temp2 + while writes(", ", get(lines)) + write() + } + +end diff --git a/ipl/progs/ineeds.icn b/ipl/progs/ineeds.icn new file mode 100644 index 0000000..3f0f1cd --- /dev/null +++ b/ipl/progs/ineeds.icn @@ -0,0 +1,86 @@ +############################################################################ +# +# File: ineeds.icn +# +# Subject: Program to print modules required by an Icon program +# +# Author: Robert J. Alexander +# +# Date: May 18, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# +# Program to determine Icon modules required by an Icon module. Expects +# environment variable LPATH to be set properly as for the Icon Compiler. +# +############################################################################ + +procedure main(arg) + local linkSet,doneSet,fn,f,line,linkName,libSet,a + libSet := set() + linkSet := set() + while a := get(arg) do { + if match("-I",a) then { + insert(libSet,"" ~== a[3:0] | get(arg)) + } + else insert(linkSet,a) + } + every insert(libSet,PathDirs()) + doneSet := set() + while fn := !linkSet do { + delete(linkSet,fn) + insert(doneSet,fn) + f := open(("" | !libSet) || fn || ".icn") | { + write(&errout,"Can't find \"",fn,"\"") + next + } + while line := read(f) do line ? { + if ="link" & tab(many(' \t')) then { + while linkName := trim(tab(upto(', \t#')) | + (not pos(0),tab(0)),' \t') do { + if not member(doneSet,linkName) then insert(linkSet,linkName) + if not ="," then break + tab(many(' \t')) + } + } + } + close(f) + } + every write(!sort(doneSet)) +end + +procedure PathDirs(s) +# +# Generate the directory names in a "path" string. +# + local pathDir + static pathSep,fileSep + initial { + if match("MS-DOS" | "OS/2",&features) then { + pathSep := ";" + fileSep := "\\" + } + else if match("Macintosh",&features) then { + pathSep := "," + fileSep := ":" + } + else if match("UNIX",&features) then { + pathSep := ":" + fileSep := "/" + } + } + /s := getenv("LPATH") + \s ? { + until pos(0) do { + pathDir := tab(find(pathSep) | 0) + if not match(fileSep,pathDir,-1) then pathDir ||:= fileSep + suspend "" ~== pathDir + move(*pathSep) + } + } +end diff --git a/ipl/progs/inter.icn b/ipl/progs/inter.icn new file mode 100644 index 0000000..87e6225 --- /dev/null +++ b/ipl/progs/inter.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: inter.icn +# +# Subject: Program to find common values in two lists +# +# Author: Ralph E. Griswold +# +# Date: August 13, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists lines common to two files. +# +############################################################################ + +procedure main(args) + local in1, in2, one, two + + in1 := open(args[1]) | stop("*** cannot open file 1") + in2 := open(args[2]) | stop("*** cannot open file 2") + + one := set() + two := set() + + every insert(one, !in1) + every insert(two, !in2) + + every write(!sort(one ** two)) + +end diff --git a/ipl/progs/interpe.icn b/ipl/progs/interpe.icn new file mode 100644 index 0000000..ef317ea --- /dev/null +++ b/ipl/progs/interpe.icn @@ -0,0 +1,57 @@ +############################################################################ +# +# File: interpe.icn +# +# Subject: Program to interpret Icon expressions +# +# Author: Ralph E. Griswold +# +# Date: December 30, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is a crude but effective interpreter for Icon expressions. +# Each line entered from standard input is presumed to be an Icon +# expression, is wrapped with a main procedure, and written to a pipe +# that compiles and executes the resulting program. +# +# If the expression is a generator, all its results are produced. +# If the command-line option -e is given, the expression is echoed. +# +# This technique is, of course, inefficient and may be painfully +# slow except on the fastest platforms. This technique is, however, +# completely general and as correct as Icon itself. +# +# Note: This programs creates files with the names stdin, stdin.u1, +# and stdin.u2. It removes them before terminating, but, of course, +# overwrites any pre-existing files by these names. +# +############################################################################ +# +# Requires: UNIX +# +# See also: interpp.icn +# +############################################################################ + +procedure main(args) + local line, run, echo + + if args[1] == "-e" then echo := 1 + + while line := read() do { + run := open("icont -s - -x","pw") + write(run,"procedure main()") + if \echo then write(run," write(",image(line),")") + write(run," every write(image(",line,"))") + write(run,"end") + close(run) + } + + system("rm -f stdin stdin.u1 stdin.u2") + +end diff --git a/ipl/progs/interpp.icn b/ipl/progs/interpp.icn new file mode 100644 index 0000000..1718cc5 --- /dev/null +++ b/ipl/progs/interpp.icn @@ -0,0 +1,382 @@ +############################################################################ +# +# File: interpp.icn +# +# Subject: Program to interpret Icon programs +# +# Author: Jerry Nowlin +# +# Date: December 30, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is kind of like an interactive version of BASIC in that Icon +# expressions are entered with line numbers and you can resequence them list +# them etc. and execute all the lines entered. There is no editor built +# in. You have to retype a line to change it. +# +# Documentation is lacking but there is a "?" help command that lists all +# the other commands. +# +############################################################################ +# +# See also: interpe.icn +# +############################################################################ + +global WHITE, # the white space cset + MFLAG, # the modified flag + PRTBL # the program table + +procedure main(arg) + local line, lno, pline + +# define the needed cset + WHITE := ' \t\n\f' + +# initialize the program table + PRTBL := table() + +# initialize the modified flag + MFLAG := 0 + +# get all the input + writes("Icon> ") + while line := read() do { + +# scan the input line + line ? { + +# skip any initial white space + tab(many(WHITE)) + +# check for program lines (they have line numbers) + if lno := tab(many(&digits)) & tab(many(WHITE)) then { + +# get the program line + pline := tab(0) + +# store the line in the program table + PRTBL[numeric(lno)] := pline + +# set the modified flag + MFLAG +:= 1 + } + +# read command + else if (tab(upto(WHITE)) | tab(0)) == + ("read" | "r") then { + readprog() + +# clear the modified flag + MFLAG := 0 + } + +# write command + else if (tab(upto(WHITE)) | tab(0)) == + ("write" | "w") then { + writeprog() + +# clear the modified flag + MFLAG := 0 + } + +# delete command + else if (tab(upto(WHITE)) | tab(0)) == + ("delete" | "d") then { + delprog() + +# set the modified flag + MFLAG +:= 1 + } + +# sequence command + else if (tab(upto(WHITE)) | tab(0)) == + ("sequence" | "s") then { + seqprog() + } + +# list command + else if (tab(upto(WHITE)) | tab(0)) == + ("list" | "l") then { + listprog() + } + +# execute command + else if (tab(upto(WHITE)) | tab(0)) == + ("execute" | "e") then { + execprog() + } + +# help command + else if (tab(upto(WHITE)) | tab(0)) == + ("help" | "h" | "?") then { + helpprog() + } + +# quit command + else if (tab(upto(WHITE)) | tab(0)) == + ("quit" | "q") then { + quitprog() + } + +# invalid syntax input + else { + write("Syntax Error: ",line) + helpprog() + } + } + writes("Icon> ") + } + +end + +procedure execprog() + local runargs, out, prog, line, command + + static tmpfile + + initial tmpfile := "TMPFILE.icn" + +# get any runtime arguments + runargs := tab(0) + +# create the temporary Icon file + (out := open(tmpfile,"w")) | + +# or mention the problem and fail + (write("I can't open '",tmpfile,"' for writing") & fail) + +# sort the program table + prog := sort(PRTBL) + +# put the program in the file + every line := !prog do { + write(out,line[2]) + } + close(out) + +# format the command to execute the program + command := "icont -s " || tmpfile || " -x " || runargs + +# add the command to remove the temporary file + command ||:= " ; rm -f " || tmpfile + +# execute the command + system(command) + +end + +procedure seqprog() + local begno, incno, prog, lno, l + +# initialize the sequencing numbers + begno := incno := 10 + +# skip any white space + tab(many(WHITE)) + +# get an initial line number + begno := numeric(tab(many(&digits))) + +# skip any white space + tab(many(WHITE)) + +# get a increment number + incno := numeric(tab(many(&digits))) + +# sort the program table + prog := sort(PRTBL) + +# reinitialize it + PRTBL := table() + +# sequence the program lines starting with begno by incno + lno := begno + every l := !prog do { + PRTBL[lno] := l[2] + lno +:= incno + } + +end + +procedure readprog() + local readfile, response, in, lno, line + +# get a possible command line file name + tab(many(WHITE)) + readfile := tab(upto(WHITE) | 0) + +# if there was no file with the command get one + if /readfile | *readfile = 0 then { + writes("Read file name: ") + readfile := read() + } + +# make sure a modified file has been written + if MFLAG > 0 then { + writes("Write before reading over current program? ") + response := read() + if any('yY',response) then + writeprog() + } + +# initialize the program table + PRTBL := table() + +# read the program from the read file + in := open(readfile,"r") + lno := 10 + every line := !in do { + PRTBL[lno] := line + lno +:= 10 + } + close(in) + +# tell them what you did + write("Read '",readfile,"'...",*PRTBL," lines") + +end + +procedure writeprog() + local writefile, prog, out, l + +# get a possible command line file name + tab(many(WHITE)) + writefile := tab(upto(WHITE) | 0) + +# if there was no file with the command get one + if /writefile | *writefile = 0 then { + writes("Write file name: ") + writefile := read() + } + +# sort the program table + prog := sort(PRTBL) + +# write the program to the write file + out := open(writefile,"w") + every l := !prog do { + write(out,l[2]) + } + close(out) + +# tell them what you did + write("Write '",writefile,"'...",*PRTBL," lines") + +end + +procedure delprog() + local begno, endno, prog, l, lno + +# initialize the line numbers + begno := 0 + endno := 99999 + +# skip any white space + tab(many(WHITE)) + +# get an initial line number + begno := endno := numeric(tab(many(&digits))) + +# skip any white space + tab(many(WHITE)) + +# get a final line number + endno := numeric(tab(many(&digits))) + +# sort the program table + prog := sort(PRTBL) + +# reinitialize it + PRTBL := table() + +# delete the program lines between the optional numbers + every l := !prog do { + lno := numeric(l[1]) + if (lno < begno) | (lno > endno) then PRTBL[lno] := l[2] + } + +end + +procedure listprog() + local begno, endno, prog, l, lno + +# initialize the line numbers + begno := 0 + endno := 99999 + +# skip any white space + tab(many(WHITE)) + +# get an initial line number + begno := endno := numeric(tab(many(&digits))) + +# skip any white space + tab(many(WHITE)) + +# get a final line number + endno := numeric(tab(many(&digits))) + +# sort the program table + prog := sort(PRTBL) + +# list the program lines between the optional numbers + every l := !prog do { + lno := numeric(l[1]) + if (lno >= begno) & (lno <= endno) then + write(right(lno,5),": ",l[2]) + if lno > endno then break + } + +end + +procedure helpprog() + + static helpmsg + +# define the help message + initial { + helpmsg := [ + "<<< Icon Expression Syntax >>>", + "", + "lineno expression", + "", + "<<< Command Summary >>>", + " (1st character works)", + "", + "read [ file ]", + "write [ file ]", + "list [ begno [ endno ] ]", + "delete [ begno [ endno ] ]", + "sequence [ begno [ increment ] ]", + "execute [ args ]", + "quit", + "help" + ] + } + +# print it + every write(!helpmsg) + +end + +procedure quitprog() + local response + +# make sure a modified file has been written + if MFLAG > 0 then { + writes("Write before quitting? ") + response := read() + if any('yY',response) then + writeprog() + } + + stop("Goodbye.") + +end + diff --git a/ipl/progs/ipatch.icn b/ipl/progs/ipatch.icn new file mode 100644 index 0000000..d234d6b --- /dev/null +++ b/ipl/progs/ipatch.icn @@ -0,0 +1,71 @@ +############################################################################ +# +# File: ipatch.icn +# +# Subject: Program to patch iconx path in executable +# +# Author: Gregg M. Townsend +# +# Date: November 15, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: ipatch file path +# +# Ipatch changes the path to iconx, the Icon interpreter, that is +# embedded in an Icon executable file under Unix. Icon 9.4 headers are +# rewritten in the same form. Because headers from earlier versions of +# Icon contain no room for expansion, they are rewritten in a different +# form to accommodate a possibly-longer path. +# +############################################################################ +# +# Requires: Unix +# +############################################################################ + +procedure main(args) + local fname, path, f, header, hlength, pfx + + if *args ~= 2 then + stop("usage: ", &progname, " file iconx") + fname := get(args) + path := get(args) + + f := open(fname, "rwu") | stop("cannot open ", fname, " for writing") + header := reads(f, 1000) | stop(fname, ": empty file") + + header ? { + (tab(find("\n[executable Icon binary follows]\n")) & tab(find("\f\n\0"))) | + stop(fname, ": not an Icon executable") + hlength := &pos - 1 + tab(1) + if pfx := tab(find("IXBIN=") + 6) then { + # Icon 9.4 or later binary + tab(upto('\n')) + header := pfx || path || tab(hlength + 1) + } + else { + # Icon 9.3 or earlier binary + header := "#!/bin/sh" || + "\n" || + "\nexec ${ICONX-" || path || "} $0 ${1+\"$@\"}" || + "\n\n\n\n\n" || + "\n[executable Icon binary follows]" || # must appear exactly + "\n" + } + } + + if *header + 3 > hlength then + stop("cannot patch: path is too long to fit") + + if not close(open(path)) then + write(&errout, "warning: cannot open ", path, "; patching anyway") + + seek(f, 1) | stop("cannot reposition ", fname) + writes(f, left(header, hlength)) | stop("write failed") +end diff --git a/ipl/progs/ipldoc.icn b/ipl/progs/ipldoc.icn new file mode 100644 index 0000000..f148204 --- /dev/null +++ b/ipl/progs/ipldoc.icn @@ -0,0 +1,93 @@ +############################################################################ +# +# File: ipldoc.icn +# +# Subject: Program to collect library documentation +# +# Author: Ralph E. Griswold +# +# Date: November 26, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program collects selected information from documentation headers +# for Icon procedure files named on the command line. +# +# The following options are supported: +# +# -s skip file headers +# -f sort procedure list by file; default sort by procedure +# name +# +############################################################################ +# +# Links: options, sort +# +############################################################################ + +link options +link sort + +record ref(proc, file) + +procedure main(args) + local procedures, file, program, line, dir, input, max + local reference, opts, writep, way1, way2 + + opts := options(args, "sf") + + writep := if \opts["s"] then 1 else write + if \opts["f"] then { + way1 := 2 + way2 := 1 + } + else { + way1 := 1 + way2 := 2 + } + + + procedures := set() + + every file := !args do { + + program := open(file) | { + write(&error, "*** cannot open program ", image(file)) + next + } + + writep() + writep() + + while line := read(program) | break do + if *line = 0 then break else writep(line) + + while line := read(program) | break do + line ? { + if ="procedure" then { + tab(many(' \t')) + if ="main(" then next + insert(procedures, ref(tab(upto(')') + 1), file)) + } + } + close(program) + } + + writep() + writep(repl("=", 76)) + writep() + write("Procedure List") + write() + + max := 60 + + procedures := sortff(procedures, way1, way2) + + every reference := !procedures do + write(left(reference.proc, max), reference.file) + +end diff --git a/ipl/progs/iplindex.icn b/ipl/progs/iplindex.icn new file mode 100644 index 0000000..cc3ac05 --- /dev/null +++ b/ipl/progs/iplindex.icn @@ -0,0 +1,131 @@ +############################################################################ +# +# File: iplindex.icn +# +# Subject: Program to produce indexed listing of the program library +# +# Author: Ralph E. Griswold +# +# Date: March 3, 1996 +# +########################################################################### +# +# This file is in the public domain. +# +############################################################################ +# +# The following options are supported: +# +# -k i width keyword field, default 16 +# -p i width of field for program name, default 12 +# +# Some noise words are omitted (see "exceptions" in the program text). +# If a file named except.wrd is open and readable in the 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". +# +# This program was derived from kwic.icn by Steve Wampler. +# +# The format of the output was suggested by Gregg Townsend. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +global line, loc, exceptions, key_width, program_width, tag + +record pair(name, line) + +procedure main(args) + local exceptfile, opts + + opts := options(args, "k+p+") + key_width := \opts["k"] | 16 + program_width := \opts["p"] | 12 + + if exceptfile := open("except.wrd") then { + exceptions := set() + every insert(exceptions, lcword(exceptfile)) + close(exceptfile) + } + else + exceptions := set(["and", "for", "into", "all", "from", "get", "put", + "compute", "perform", "apply", "model", "value", "model", "operator", + "out", "problem", "produce", "such", "use", "operation", + "between", "data", "different", "down", "miscellaneous", "non", + "obtaining", "using", "value", "values", "various", "with", + "begin", "end", "not", "way", "possible", "required", "until", + "that", "within", "once", "the" + ]) + + write(left("keyword", key_width), left("location", program_width), + "description") + write() + + every write(filter(indexer(&input))) + +end + +procedure indexer(file) + local index, word + +# Each word, in lowercase form, is a key in the table "index". +# The corresponding values are lists of the lines for that word. + + index := table() + + every word := lcword(file) do { + if not member(exceptions,word) then { + /index[word] := [] + index[word] := put(index[word],line) + } + } + + index := sort(index,3) + +# while get(index) do +# suspend !get(index) + + while name := get(index) do + suspend pair(name, !get(index)) + +end + +procedure lcword(file) + local name, word + static chars + + initial { + chars := &letters ++ &digits + tag := table() + } + + every line := !file do { + line ?:= { + name := tab(find(": ")) # program name + move(2) # skip trash + tab(0) # rest is now line + } + tag[line] := name # name for the line + line ? { + while tab(loc := upto(chars)) do { + word := map(tab(many(chars))) + if *word > 2 & not(any('(')) then suspend word + } + } + } +end + +procedure filter(result) + + return left(result.name, key_width) || + left(tag[result.line], program_width) || result.line + +end diff --git a/ipl/progs/iplkwic.icn b/ipl/progs/iplkwic.icn new file mode 100644 index 0000000..cfd91df --- /dev/null +++ b/ipl/progs/iplkwic.icn @@ -0,0 +1,138 @@ +############################################################################ +# +# File: iplkwic.icn +# +# Subject: Program to produce keywords in context for IPL +# +# Author: Stephen B. Wampler, modified by Ralph E. Griswold +# +# Date: May 2, 2001 +# +########################################################################### +# +# This file is in the public domain. +# +############################################################################ +# +# +# NOTE: This is a specialized version used for producing kwic listings +# for the Icon program library. +# +# This is a simple keyword-in-context (KWIC) program. It reads from +# standard input and writes to standard output. The "key" words are +# aligned at a specified column, 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. +# +# The following options are supported: +# +# -c i column at which keywords are aligned, default 30 +# -h i width of identifying column at left, default 20 +# +# Some noise words are omitted (see "exceptions" in the program text). +# If a file named except.wrd is open and readable in the 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". +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +global line, loc, exceptions, width, tag, head + +record pair(new, old) + +procedure main(args) + local exceptfile, opts + + opts := options(args, "c+h+") + width := \opts["c"] | 30 + head := \opts["h"] | 20 + + if exceptfile := open("except.wrd") then { + exceptions := set() + every insert(exceptions, lcword(exceptfile)) + close(exceptfile) + } + else + exceptions := set(["and", "for", "into", "all", "from", "get", "put", + "compute", "perform", "apply", "model", "value", "model", "operator", + "out", "problem", "produce", "such", "use", "operation"]) + + every write(filter(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) + local name, word + static chars + + initial { + chars := &letters ++ &digits ++ '\'' + tag := table() + } + + every line := !file do { + line ?:= { + name := tab(find(": ")) # program name + move(2) # skip trash + tab(0) # rest is now line + } + tag[line] := name # name for the line + line ? { + while tab(loc := upto(chars)) do { + word := map(tab(many(chars))) + if *word > 2 & not(any('(')) then suspend word + } + } + } +end + +procedure position() + local offset + +# Note that "line" and "loc" are global. + + offset := width - loc + if offset >= 0 then return pair(repl(" ",offset) || line, line) + else return pair(line[-offset + 1:0], line) +end + +procedure filter(result) + + return left(tag[result.old], head) || result.new + +end diff --git a/ipl/progs/iplweb.icn b/ipl/progs/iplweb.icn new file mode 100644 index 0000000..70b25ce --- /dev/null +++ b/ipl/progs/iplweb.icn @@ -0,0 +1,185 @@ +############################################################################### +# +# File: iplweb.icn +# +# Subject: Program to generate web pages from IPL header comments +# +# Author: Justin Kolb +# +# Date: May 2, 2001 +# +############################################################################### +# +# This file is in the public domain. +# +############################################################################### +# +# iplweb [-ipl source] [dest] +# +# Uses an environment variable IPL which is a path to the Icon Program Library +# as a default if -ipl is not specified, dest is the current directory if not +# specified. +# +# Generates HTML directory in dest and makes an index to gprogs, gprocs, +# procs, and progs directories under HTML. In each of these directories +# is a .html file for each of the .icn files in the referenced directory. +# A index to all of these files is also generated. Each of the .html files +# contains the IPL standard comment header info inside. +# +############################################################################### + +link options + +procedure main(arglist) + local opts, source, dest + + if opts := options(arglist, "-ipl:", errorproc) then { + source := opts["ipl"] + /source := getenv("IPL") + if /source then errorproc() + } + else errorproc() + + if *arglist > 0 then { + dest := arglist[1] || "/HTML" + } + else { + dest := "HTML" + } + + Build_HTML_Files(source, dest) +end + +procedure errorproc() + stop("Set IPL environment variable or use\n", + "iplweb [-ipl source] [destination]") +end + +procedure Build_HTML_Files(source_dir, dest) + local directory, dir_index_file, dir, dirlist, file_index_file, + prev_dir, full_path, file, file_info_file, source_file + + directory := ["/gprogs", "/gprocs", "/progs", "/procs"] + + system("mkdir " || dest) + + dir_index_file := open(dest || "/dirindex.html", "w") + + Init_Dir_Index(dir_index_file) + + every dir := !directory do { + dirlist := open("ls " || source_dir || dir || "/*.icn", "p") + + file_index_file := &null + prev_dir := "" + + while full_path := read(dirlist) do { + write(full_path) + + file := strip_file(full_path) + + if not (dir == prev_dir) then { + #Prev Dir + if not /file_index_file then { + Close_File_Index(file_index_file) + + close(file_index_file) + } + + # Next Dir + Index_Dir(dir_index_file, dir) + + system("mkdir " || dest || dir) + + file_index_file := open(dest || dir || "/fileindex.html", "w") + + Init_File_Index(file_index_file, dir) + } + + Index_File(file_index_file, file) + + file_info_file := open(dest || dir || file || ".html", "w") + + source_file := open(full_path) + + ProcessFileInfo(file_info_file, source_file) + + close(source_file) + + close(file_info_file) + + prev_dir := dir + } + + close(file_index_file) + } + Close_Dir_Index(dir_index_file) + close(dir_index_file) +end + +procedure Init_Dir_Index(file) + write(file, "<TITLE>IPL: The Icon Program Library Comment Documentaion</TITLE>") + write(file, "<H1>The Icon Program Library</H1><P>") + write(file, "<H2>Source Directorys</H2><P>") + write(file, "<UL>") +end + +procedure Index_Dir(file, dir) + write(file, "<LI><A HREF=\"" || dir[2:0] || "/fileindex.html\">" || dir[2:0] || "</A></LI>") +end + +procedure Close_Dir_Index(file) + write(file, "</UL>") +end + +procedure Init_File_Index(file, dir) + write(file, "<TITLE>IPL: The Icon Program Library Comment Documentation</TITLE>") + write(file, "<H1>The Icon Program Library</H1><P>") + write(file, "<H2>The " || dir[2:0] || " directory listing</H2><P>") + write(file, "<UL>") +end + +procedure Index_File(index, file) + write(index, "<LI><A HREF=\"" || file[2:0] || ".html\">" || file[2:0] || ".icn</A></LI>") +end + +procedure Close_File_Index(file) + write(file, "</UL>") +end + +procedure ProcessFileInfo(file, source) + local line, keywd, text + + write(file, "<TITLE>IPL: The Icon Program Library Comment Domumentaion</TITLE>") + + write(file, "<H1>The Icon Program Libary</H1><P>") + + while line := read(source) do line ? { + if not pos(0) then { + if tab(many('# \t')) & + (keywd := =("File:" | "Subject:" | "Author:" | "Date:" | "Authors:")\1) & + tab(many(' \t')) & + text := tab(0) + then { + case keywd of { + "File:" : write(file, "<H2>" || text || "</H2><P>") + "Subject:" : write(file, "<H3>" || text || "</H3><P>") + "Author:" : write(file, "<H3>" || text || "</H3><P>") + "Authors:" : write(file, "<H3>" || text || "</H3><P>") + "Date:" : write(file, "<H3>" || text || "</H3><P>") + } + } + else if tab(many('#'))\1 & tab(many(' \t')) & text := tab(0) then + write(file, "<PRE>" || text || "</PRE>") + } + } +end + +procedure strip_file(path) + local local_dir + + path ? { + every local_dir := tab(upto('/')) + return path[*local_dir + 1 : -4] + } +end diff --git a/ipl/progs/ipower.icn b/ipl/progs/ipower.icn new file mode 100644 index 0000000..2931d10 --- /dev/null +++ b/ipl/progs/ipower.icn @@ -0,0 +1,52 @@ +############################################################################ +# +# File: ipower.icn +# +# Subject: Program to write sequence of powers +# +# Author: Ralph E. Griswold +# +# Date: December 29, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program generates integers in sequence. +# +# The following options are supported: +# +# -v i value to be raise to power; default 2 +# -b i beginning power; default 1 +# -e i ending power; default no end +# -i i increment; default 1 +# -l i limit on number of powers generated; default no limit +# +# Large integer values are not supported. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, limit, start, stop, incr, i, base + + opts := options(args, "v+b+e+i+l+") + + limit := \opts["l"] | (2 ^ 32) # good enough + base := \opts["v"] | 2 + start := \opts["b"] | 1 + stop := \opts["e"] | (2 ^ 64) # sort of good enough + incr := \opts["i"] | 1 + + every i := seq(start, incr) \ limit do + if i > stop then exit() + else write(base ^ i) + +end diff --git a/ipl/progs/ipp.icn b/ipl/progs/ipp.icn new file mode 100644 index 0000000..16c8a44 --- /dev/null +++ b/ipl/progs/ipp.icn @@ -0,0 +1,1178 @@ +############################################################################ +# +# File: ipp.icn +# +# Subject: Program to preprocess Icon programs +# +# Author: Robert C. Wieland, revised by Frank J. Lhota +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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'. +# +# Ipp will also set _LINE_ and _FILE_ from the "#line" directives it +# encounters, and will insert line directives to indicate source origins. +# +# 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. On a UNIX system names enclosed in "" are +# searched for by trying in order the directories specified by the +# PATH environment variable, and names enclosed in <> are always +# expected to be in the /usr/icon/src directory. On other systems +# names enclosed in <> are searched for by trying in order the +# directories specified by the IPATH environment variable; names +# in "" are searched for in a similar fashion, except that the +# current directory is tried first. 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 a line that has '$' as its first non-space +# character. The name of the command must follow the '$'. White space +# (any number of spaces or tabs) may be used to separate the '$' and the +# command name. 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 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 occurrences 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 occurrence 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 +# on 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'. +# +# $warning: +# This command issues a warning, with the text coming from the +# argument field of the command. +# +# $error: This command issues a error, with the text coming from the +# argument field of the command. As with all errors, processing +# is terminated. +# +# $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 output 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. +# +# The following comparison operators may be used on integer +# operands: +# +# > >= = < <= ~= +# +# Also provided are alternation (|), conjunction (&), and +# negation (not). The following table lists all operators with +# regard to decreasing precedence: +# +# not + - (unary) +# ^ (associates right to left) +# * / % +# + - (binary) +# > >= = < <= ~= +# | +# & +# +# The precedence of '|' and '&' are the same as the corresponding +# Icon counterparts. Parentheses may be used for grouping. +# Backtracking is performed, so that the expression +# +# FOO = (1|2) +# +# will produce a result precisely when FOO is either 1 or 2. +# +# $elif: Invoked as 'elif constant-expression'. If the lines preceding +# this command were processed, this command and the lines following +# it up to the matching $endif command are ignored. Otherwise, +# the constant-expression is evaluated, and the lines following this +# command are processed only if it produces a result. +# +# $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. +# +# $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. +# +# 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. +# Expr_node Node of a parse tree for $if / $elif expressions. +# Holds the operator, or a string representing the +# control structure. Also, holds a list of the args for +# the operation / control structure, which are either +# scalars or other Expr_node records. +# 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, line) +record Opt_rec(options, pairs, ifile, ofile) +record Defs_rec(arg_list, text) +record Expr_node(op, arg) + +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, DIR_SEP + +procedure main(arg_list) + local line, source + + init(arg_list) + + repeat { + while line := get_line(Ifile) do + line ? process_cmd(get_cmd()) + + # Get new source + close(Ifile) + if source := pop(Src_stack) then { + Ifile := source.fd + Ifile_name := source.fname + Line_no := source.line + } + else break + } +end + +procedure conditional(expr) + + return if eval(expr) then + true_cond() + else + false_cond() +end + +# +# In order to simplify the parsing the four operators that are longer +# than one character (<= ~= >= not) are replaced by one character +# 'aliases'. Also, all white space is removed. +# + +procedure const_expr(expr) + local new + + static White_space_plus + + initial White_space_plus := White_space ++ '<>~n' + + new := "" + expr ? { + while new ||:= tab(upto(White_space_plus)) || + if any(White_space) then { + tab(many(White_space)) + "" + } + else if =">=" then "\x01" + else if ="<=" then "\x02" + else if ="~=" then "\x03" + else if not any(Name_char, ,&pos - 1) & + ="not" & + not any(Name_char) then "\x04" + else move (1) + new ||:= tab(0) + } + # + # Now recursively parse the transformed string. + # + return parse(new) + +end + +procedure decoded(op) + return case op of { + "\x01": ">=" + "\x02": "<=" + "\x03": "~=" + "\x04": "not" + default: op + } +end + +procedure def_opt(s) + local name, text + + s ? { + name := tab(find("=")) | 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 not name ? (get_name() & pos(0)) then + error(name, " : Illegal name argument to -D option") + if member(Defs, name) then + warning(name, " : redefined by -D option") + insert(Defs, name, Defs_rec(, text)) +end + +procedure define() + local args, name, text + + get_opt_ws() + if name := get_name() & (any(White_space ++ '(') | pos(0)) then { + if name == ("_LINE_" | "_FILE_") then + error(name, " is a reserved name and can not be redefined") + + if match("(") then # A macro + args := get_formals() + text := get_text(args) + + if member(Defs,name) then + warning(name, " redefined") + insert(Defs, name, Defs_rec(args, text)) + } + else + error("Illegal or missing name in define") +end + +procedure dump() + if not pos(0) then + warning("Extraneous characters after dump command") + every write(&errout, (!sort(Defs))[1]) +end + +procedure error(s1, s2) + s1 ||:= \s2 + stop(Ifile_name, ": ", Line_no, ": ", "Error ", s1) +end + +procedure eval(node) + suspend case type(node) of { + "Expr_node": { + case node.op of { + "|" : eval(node.arg[1]) | eval(node.arg[2]) + "&" : eval(node.arg[1]) & eval(node.arg[2]) + "not" : not eval(node.arg[1]) + "def" : member(Defs, node.arg[1]) + "ndef" : not member(Defs, node.arg[1]) + default : + case *node.arg of { + 1 : node.op(eval(node.arg[1])) + 2 : node.op(eval(node.arg[1]), eval(node.arg[2])) + } + } + } + default: node + } +end + +procedure false_cond() + local cmd, line + + # Skip to next $else / $elif branch, or $endif + cmd := skip_to("elif", "else", "endif") + case cmd of { + "elif" : return if_cond(cmd) + "else" : { + while line := get_line(Ifile) do + line ? { + cmd := get_cmd() + case cmd of { + "elif" : + error("'elif' encountered after 'else'") + "else" : + error("multiple 'else' sections") + "endif" : return + default : process_cmd(cmd) + } + } + error("'endif' not encountered before end of file") + } + "endif": return + } +end + +procedure find_file(fname, path_list) + local ifile, ifname, path + + every path := !path_list do { + ifname := + if path == ("" | ".") then + fname + else + path || DIR_SEP || 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, Line_no)) + Ifile := ifile + Ifile_name := ifname + Line_no := 0 + return + } + } + error("Can not open include file ", fname) +end + +procedure func(expr) + local op, arg + + expr ? { + if op := tab(find("(")) & move(1) & + arg := get_name() & =")" & pos(0) then { + if op == ("def" | "ndef") then + return Expr_node(op, [arg]) + else + error("Invalid function name") + } + } +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 + +procedure get_cmd() + local cmd + static no_arg_cmds + initial no_arg_cmds := set(["dump", "else", "endif"]) + + if ="#" & cmd := ="line" then + get_opt_ws() + else if (get_opt_ws()) & ="$" then { + get_opt_ws() + (cmd := tab(many(Chars))) | error("Missing command") + get_opt_ws() + if not pos(0) & member(no_arg_cmds, cmd) then + warning("Extraneous characters after argument to '" || cmd || "'") + } + else + tab (1) + return cmd +end + +procedure get_formals() + local formal, arglist, ch + + arglist := [] + ="(" + get_opt_ws() + if not =")" then + repeat { + if (formal := get_name()) & get_opt_ws() & any(',)') then + put(arglist, formal) + else + error("Invalid formal argument in macro definition") + if =")" then break + ="," + get_opt_ws() + } + get_opt_ws() + return arglist +end + +procedure get_line(Ifile) + return 1(read(Ifile), Line_no +:= 1) +end + +procedure get_name() + return tab(any(Init_name_char)) || (tab(many(Name_char)) | "") +end + +procedure get_opt_ws() + return (tab(many(White_space)) | "") || (="#" || tab(0) | "") +end + +procedure get_text(is_macro) + local text + + if \is_macro then + text := tab(0) + else + text := (tab(any(White_space)) & tab(0)) | "" + while (text[-1] == "\\") do + (text := text[1:-1] || get_line(Ifile)) | + error("Continuation line not found before end of file") + return text +end + +# if_cond is the procedure for $if or $elif. +# +# 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 an $elif, $else, or $endif. If $elif or $else is encountered, lines +# are skipped until the matching $endif 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 an $elif, $else, or, $endif. If $else is encountered, lines are +# processed until the $endif matching the $else is encountered. + +procedure if_cond(cmd) + if pos(0) then + error("Constant expression argument to '" || cmd || "' missing") + else + return conditional(const_expr(tab(0))) +end + +procedure ifdef() + local name + + if name := get_name() then + { + get_opt_ws() + if not pos(0) then + warning("Extraneous characters after argument to 'ifdef'") + return conditional(Expr_node("def", [name])) + } + else + error("Argument to 'ifdef' is not a valid name") +end + +procedure ifndef() + local name + + if name := get_name() then { + get_opt_ws() + if not pos(0) then + warning("Extraneous characters after argument to 'ifndef'") + return conditional(Expr_node("ndef", [name])) + } + else + error("Argument to 'ifndef' is not a valid name") +end + +procedure in_text(name, text) + return text ? + tab(find(name)) & + (if move(-1) then tab(any(Non_name_char)) else "") & + move(*name) & + (tab(any(Non_name_char)) | pos(0)) +end + +procedure include() + local ch, fname + static fname_chars, stopper + + initial { + fname_chars := Chars -- '<>"' + stopper := table() + insert(stopper, "\"", "\"") + insert(stopper, "<", ">") + } + + if (ch := tab(any('"<'))) & + (fname := tab(many(fname_chars))) & + =stopper[ch] then { + get_opt_ws() + if not pos(0) then + warning("Extraneous characters after include file name") + find_file(fname, + case ch of { + "\"" : Path_list + "<" : Std_include_paths + } + ) + } + else + error("Missing or invalid include file name") +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 + + # Predefine features + every s := &features do { + s := map(s, " -/", "___") + insert(Defs, s, Defs_rec(, "1")) + } + + # Set path list for $include files given in "", <> + if member(Defs, "UNIX") then { + Path_list := [] + getenv("PATH") ? while put(Path_list, 1(tab(find(":")), move(1))) + Std_include_paths := ["/usr/icon/src"] + } + else { + Std_include_paths := [] + (getenv("IPATH") || " ") ? + while put(Std_include_paths, tab(find(" "))) do move(1) + Path_list := [""] ||| Std_include_paths + } + + process_options(arg_list) +end + +procedure lassoc(expr, op) + local j, arg1, arg2 + + expr ? { + every j := bal(op) + # Succeeds if op found. + if arg1 := tab(\j) & op := decoded(move(1)) & arg2 := tab(0) then { + op := proc(op, 2) # Fails for control structures + return Expr_node(op, [parse(arg1), parse(arg2)]) + } + } +end + +# +# Programmer's note: Ifile_name and Line_no should not be assigned new +# values until the very end, so that if there is an error, the error +# message will include the file/line no of the current line directive, +# instead of the file/line of the text that follows the directive. +# +procedure line() + local new_line, new_file + + new_line := tab(many(&digits)) | error("No line number in line directive") + get_opt_ws() + if ="\"" then { + new_file := "" + # + # Get escaped chars. We assume that the only escaped chars + # appearing in a file name would be \\ or \", where the actual + # character to be used is simply the character following the slash. + # In the unlikely event that other escape sequences are encountered, + # this section would have to revised. + # + while new_file ||:= tab(find("\\")) || (move(1) & move(1)) + new_file ||:= tab(find("\"")) | + error("Invalid file name in line directive") + } + + Line_no := integer(new_line) + Ifile_name := \new_file + return +end + +procedure macro_call(entry, args) + local i, value, result, token + + value := table() + every i := 1 to *entry.arg_list do + insert(value, entry.arg_list[i], args[i] | "") + + entry.text ? { + result := tab(upto(Name_char) | 0) + while token := tab(many(Name_char)) do { + result ||:= \value[token] | token + result ||:= tab(many(Non_name_char)) + } + } + return result +end + +procedure no_endif_error() + error("'endif' not encountered before end of file") +end + +procedure parse(expr) + # strip surrounding parens. + while expr ?:= 2(="(", tab(bal (')')), pos(-1)) + + return lassoc(expr, '&' | '|') | + lassoc(expr, '<=>\x01\x02\x03' | '+-' | '*/%') | + rassoc(expr, '^') | + unary(expr, '+-\x04') | + func(expr) | + integer(process_text(expr)) | + error(expr, " : Integer expected") +end + +procedure process_cmd(cmd) + static last_cmd + initial last_cmd := "" + + case cmd of { + "dump" : dump() + "define" : define() + "undef" : undefine() + "include" : include() + "line" : line() + "error" : error(tab(0)) + "warning" : warning(tab(0)) + "if" : if_cond( last_cmd := cmd ) + "ifdef" : ifdef( last_cmd := cmd ) + "ifndef" : ifndef( last_cmd := cmd ) + "elif" | + "else" | + "endif" : error("No previous 'if' expression") + &null : { + if \last_cmd then + put_linedir(Ofile, Line_no, Ifile_name) + write(Ofile, process_text(tab(0))) + } + default : error("Undefined command") + } + last_cmd := cmd + return +end + +procedure process_macro(name, entry, s) + local arg, args, new_entry, news, token + + s ? { + args := [] + if ="(" then { + # + # Get args if list is not empty. + # + get_opt_ws () + if not =")" then + repeat { + arg := get_opt_ws() + if token := tab(many(Chars -- '(,)')) then { + if /(new_entry := Defs[token]) then + arg ||:= token + else if /new_entry.arg_list then + arg ||:= new_entry.text + else { # Macro with arguments + if news := tab(bal(White_space ++ ',)')) then + arg ||:= process_macro(token, new_entry, news) + else + error(token, ": Error in arguments to macro call") + } # if + } # if + else if not any(',)') then + error(name, ": Incomplete macro call") + arg ||:= tab(many(White_space)) + put(args, arg) + if match(")") 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 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 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 { + # Ignore escaped chars + while new ||:= tab(find("\\")) || move(2) + if new ||:= tab(find("\"")) || move(1) then + in_string := &null + else { + new ||:= tab(0) + if line[-1] ~== "_" then { + in_string := &null + warning("Unclosed double quote") + } + } + } + else if \in_cset then { + # Ignore escaped chars. + while new ||:= tab(find("\\")) || move(2) + if new ||:= (tab(find("'")) || 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)) + case token := tab(many(Name_char) | any(Non_name_char)) of { + "\"": { + new ||:= "\"" + if \in_string then + in_string := &null + else if not pos(0) then { + in_string := TRUE + } + else { + warning("Unclosed double quote") + } + add ||:= tab(0) + } + "'": { + new ||:= "'" + if \in_cset then + in_cset := &null + else if not pos(0) then { + in_cset := TRUE + } + else { + warning("Unclosed double quote") + } + add ||:= tab(0) + } + "#": { + new ||:= if any(Options, 'C') then token || tab(0) + else tab(0) & token ? tab(find("#")) + } + "__LINE__": + new ||:= Line_no + "__FILE__": + new ||:= Ifile_name + default: { + if /(entry := Defs[token]) then + new ||:= token + else if /entry.arg_list then + if in_text(token, entry.text) then + error("Recursive textual substitution") + else + add := entry.text + 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) + } + } # default + } # case + add || tab(0) + } # ?:= + } # while + return new +end + +procedure put_linedir(Ofile, Line_no, Ifile_name) + static last_filename + initial last_filename := "" + + writes(Ofile, "#line ", Line_no - 1) + # + # Output file name part only if the + # filename differs from the last one used. + # + if last_filename ~==:= Ifile_name then + writes(Ofile, " ", image(last_filename)) + write(Ofile) + return +end + +procedure rassoc(expr, op) + local arg1, arg2 + + + # Succeeds if op found. + expr ? if arg1 := tab(bal(op)) & op := move(1) & arg2 := tab(0) then { + op := decoded(op) + op := proc(op, 2) # Fails for control structures + return Expr_node(op, [parse(arg1), parse(arg2)]) + } +end + +# +# skip_to is used to skip over parts of the an '$if' structure. targets +# are the $if - related commands to skip to, and should always include +# "endif". +# +# We do not, of course, wish to skip to a command in an $if structure +# that is embedded in the current one; also, we want to make sure that +# embedded $if structures, even in skipped lines, are well formed. We +# therefore maintain a stack, if_sects, of the currently applicable $if +# structure commands encountered in the skipped lines. For example, if +# we have skipped over the commands +# +# $ifdef ... +# $if ... +# $elif ... +# $if ... +# $else +# +# if_sect would be ["else", "elif", "ifdef"]. +# +procedure skip_to(targets[]) + local cmd, if_sects, line, argpos + + if_sects := [] + while line := get_line(Ifile) | no_endif_error () do + line ? { + cmd := get_cmd() + if *if_sects = 0 & \cmd == !targets then { + argpos := &pos + break + } + + case cmd of { + "if" | + "ifdef" | + "ifndef" : { + if pos(0) then + error("Argument to '" || cmd || "' missing") + push(if_sects, cmd) + } + "elif" : { + if pos(0) then + error("Argument to '" || cmd || "' missing") + if if_sects[1] == "else" then + error("'elif' encountered after 'else'") + else + if_sects[1] := cmd + } + "else" : { + if if_sects[1] == "else" then + error("multiple 'else' sections") + else + if_sects[1] := cmd + } + "endif" : pop(if_sects) + } + } + + # + # Now reset the &subject to the current line, and &pos to the argument + # field of the current line, so that if we skipped to a line which will + # require further processing (such as $elif), the scanning functions can + # be used. + # + &subject := line + &pos := argpos + return cmd + +end + +procedure true_cond() + local cmd, line + + while line := get_line(Ifile) | no_endif_error () do + line ? { + case cmd := get_cmd() of { + "elif" | + "else" : return skip_to("endif") + "endif" : return cmd + default : process_cmd(cmd) + } + } + +end + +procedure unary(expr, op) + local arg1 + + + # Succeeds if op found. + expr ? + if op := decoded(tab(any(op))) & arg1 := tab(0) then { + op := proc(op, 1) # fails for control structures + return Expr_node(op, [parse(arg1)]) + } +end + +procedure undefine() + local name + + if name := get_name() then { + get_opt_ws() + if not pos(0) then + warning("Extraneous characters after argument to undef") + if name == ("_LINE_" | "_FILE_") then + error(name, " is a reserved name that can not be undefined") + delete(Defs, name) + } + else + error("Name missing in undefine") +end + +procedure warning(s1, s2) + s1 ||:= \s2 + write(&errout, Ifile_name, ": ", Line_no, ": ", "Warning " || s1) +end diff --git a/ipl/progs/iprint.icn b/ipl/progs/iprint.icn new file mode 100644 index 0000000..2bddc84 --- /dev/null +++ b/ipl/progs/iprint.icn @@ -0,0 +1,258 @@ +############################################################################ +# +# File: iprint.icn +# +# Subject: Program to print Icon program +# +# Author: Robert J. Alexander +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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) embedded 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. +# +############################################################################ + +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 + diff --git a/ipl/progs/iprofile.icn b/ipl/progs/iprofile.icn new file mode 100644 index 0000000..98e0ded --- /dev/null +++ b/ipl/progs/iprofile.icn @@ -0,0 +1,381 @@ +############################################################################ +# +# File: iprofile.icn +# +# Subject: Program to profile Icon procedure usage +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.5 +# +############################################################################ +# +# This very simple profiler takes a single argument - an Icon program +# compiled with the -t option. Displays stats on which procedures +# were called the most often, and from what lines in what files they +# were called. Use this program to figure out what procedures are +# getting worked the hardest and why. Counts only invocations and +# resumptions; not suspensions, returns, failures. +# +# If you are running a program that reads from a file, be sure to +# protect the redirection symbol from the shell (i.e. "profile +# 'myprog < input'" instead of "profile myprog < input"). If a given +# program normally reads &input, please redirect stdin to read from +# another tty than the one you are running profile from. If you +# forget to do this, the results might be very interesting.... Also, +# don't redirect stderr, as this contains the trace that profile will +# be reading and using to obtain run-time statistics. Profile +# automatically redirects stdout to /dev/null. +# +# Currently runs only under UNIX, but with some tweaking could be +# made to run elsewhere as well. +# +# The display should be pretty much self-explanatory. Filenames and +# procedures get truncated at nineteen characters (if the display +# gets too wide, it can become hard to read). A star is prepended to +# procedures whose statistics have changed since the last screen +# update. +# +############################################################################ +# +# Requires: co-expressions, keyboard functions, pipes, UNIX +# +############################################################################ +# +# Links: itlib, iscreen +# +############################################################################ + +link itlib +link iscreen +global CM, LI, CO, CE + +procedure main(a) + + local whitespace, firstidchars, idchars, usage, in_data, + cmd, line, filename, linenum, procname, t, threshhold + + whitespace := '\t ' + firstidchars := &letters ++ '_' + idchars := &digits ++ &letters ++ '_' + usage := "usage: profile filename _ + (filename = Icon program compiled with -t option)" + + # + # If called with a program name as the first argument, open it, + # and pipe the trace output back to this program. Assume the + # user knew enough to compile it with the "-t" option. + # + if *a > 0 then { + if find("UNIX", &features) then { + cmd := ""; every cmd ||:= !a || " " + if find("2>", cmd) then + stop("profile: Please don't redirect stderr!") + in_data := open(cmd || " 2>&1 1> /dev/null", "pr") | + stop("profile: Can't find or execute ", cmd, ".") + } else stop("profile: Your OS is not (yet) supported.") + } + else stop(usage) + + # clear screen, set up global variables; initialize table + setup_screen() + t := table() + + threshhold := 0 + while line := read(in_data) do { + threshhold +:= 1 + # + # Break each line down into a file name, line number, and + # procedure name. + # + line ? { + tab(many(whitespace)) + match(":") & next + { + filename := trim(tab(find(":"))) & + tab(many(whitespace ++ ':')) & + linenum := tab(many(&digits)) & + tab(many(whitespace ++ '|')) & + procname := tab(any(firstidchars)) || tab(many(idchars)) + } | next + tab(many(whitespace)) + # Count only invocations and resumptions. + match("suspended"|"failed"|"returned") & next + } + + # + # Enter statistics into table. + # + /t[procname] := table() + /t[procname][filename] := table(0) + t[procname][filename][linenum] +:= 1 + + # + # Display stats interactively. + # + if threshhold > 90 then { + threshhold := 0 + display_stats(t) + } + } + + display_stats(t) + # Write a nice exit message. + goodbye() + +end + + +# +# display_stats: display the information in t interactively +# +procedure display_stats(t) + + local l, input, c + static top, len, firstline + # sets global variables CM, LI, CO, and CE + initial { + top := 1 + # The first line we can write data to on the screen. + firstline := 3 + len := LI - 4 - firstline + } + + # + # Structure the information in t into a list. Note that to obtain + # the number of procedures, one must divide l in half. + # + l := sort_table(t) + + # + # Check for user input. + # + while kbhit() do { + iputs(igoto(CM, 1, LI-1)) + writes("Press j/k/^/$/p/q: ") + iputs(CE) + writes(input := map(getch())) + case input of { + # Increase or decrease top by 4; don't go beyond 0 or + # *l; no even numbers for top (the 4 also must be even). + "j" : top := (*l > (top+2) | *l-1) + "\r" : top := (*l > (top+2) | *l-1) + "\n" : top := (*l > (top+2) | *l-1) + "k" : top := (0 < (top-2) | 1) + "\x02" : top := (0 < (top-4) | 1) + "\x15": top := (0 < (top-4) | 1) + " " : top := (*l > (top+4) | *l-1) + "\x06" : top := (*l > (top+4) | *l-1) + "\x04" : top := (*l > (top+4) | *l-1) + "^" : top := 1 + "$" : top := *l-1 + "p" : { + iputs(igoto(CM, 1, LI-1)) + writes("Press any key to continue: "); iputs(CE) + until kbhit() & getch() do delay(500) + } + "q" : goodbye() + "\x0C" : setup_screen() + "\x012": setup_screen() + default: { + if any(&digits, input) then { + while c := getche() do { + if c == ("\n"|"\r") then { + if not (input <:= 1) then + input +:= input % 2 - 1 + top := (0 < input | 1) + top := (*l > input | *l-1) + break + } else { + if any(&digits, c) + then input ||:= c & next + else break + } + } + } + } + } + iputs(igoto(CM, 1, LI-1)) + writes("Press j/k/^/$/p/q: ") + iputs(CE) + } + + # + # Display the information contained in table t via list l2. + # + write_list(l, top, len, firstline) + return + +end + + +# +# sort_table: structure the info in t into a list +# +# What a mess. T is a table, keys = procedure names, values = +# another table. These other tables are tables where keys = file +# names and values = yet another table. These yet other tables +# are structured as follows: keys = line numbers, values = number +# of invocations. The idea is to collapse all of these tables +# into sorted lists, and at the same time count up the total +# number of invocations for a given procedure name (going through +# all its invocations at every line in every file). A new table +# is then created where keys = procedure names and values = total +# number of invocations. Yet another sort is done on the basis of +# total number of invocations. +# +procedure sort_table(t) + + local t2, total_t, k, total, i, l, l2 + static old_totals + initial old_totals := table() + + t2 := copy(t) + total_t := table() + every k := key(t2) do { + t2[k] := sort(t2[k], 3) + total := 0 + every i := 2 to *t2[k] by 2 do { + every total +:= !t2[k][i] + t2[k][i] := sort(t2[k][i], 3) + } + insert(total_t, k, total) + } + l2 := list(); l := sort(total_t, 4) + every i := 1 to *l-1 by 2 do { + push(l2, t2[l[i]]) + if not (total_t[l[i]] <= \old_totals[l[i]]) then + l[i] := "*" || l[i] + push(l2, l[i]) + } + + old_totals := total_t + return l2 + +end + + +# +# write_list: write statistics in the upper part of the screen +# +procedure write_list(l, top, len, firstline) + + local i, j, k, z, w + static last_i + #global CM, CE + initial last_i := 2 + + # Arg1, l, is a sorted table of sorted tables of sorted tables! + # Firstline is the first line on the screen we can write data to. + # + i := firstline + iputs(igoto(CM, 1, i)); iputs(CE) + every j := top to *l by 2 do { + writes(left(l[j], 19, " ")) + every k := 1 to *l[j+1]-1 by 2 do { + iputs(igoto(CM, 20, i)) + writes(left(l[j+1][k], 19, " ")) + every z := 1 to *l[j+1][k+1]-1 by 2 do { + iputs(igoto(CM, 40, i)) + writes(left(l[j+1][k+1][z], 7, " ")) + iputs(igoto(CM, 48, i)) + writes(l[j+1][k+1][z+1]) + if (i +:= 1) > (firstline + len) then + break break break + else iputs(igoto(CM, 1, i)) & iputs(CE) + } + } + } + + # Clear the remaining lines down to the status line. + # + every w := i to last_i do { + iputs(igoto(CM, 1, w)) + iputs(CE) + } + last_i := i + + return + +end + + +# +# setup_screen: clear screen, set up status line. +# +procedure setup_screen() + + # global CM, LI, CO, CE + initial { + CM := getval("cm") | + stop("setup_screen: No cm capability!") + LI := getval("li") + CO := getval("co") + CE := getval("ce") + # UNIX-specific command to disable character echo. + system("stty -echo") + } + + clear() + iputs(igoto(CM, 1, 1)) + emphasize() + writes(left(left("procedure name", 19, " ") || + left("source file", 20, " ") || + left("line", 8, " ") || + "number of invocations/resumptions", + CO, " ")) + normal() + status_line("- \"Profile,\" by Richard Goerwitz -") + iputs(igoto(CM, 1, LI-1)) + writes("J or CR=down; k=up; ^=begin; $=end; p=pause; q=quit: ") + iputs(CE) + + return + +end + +# +# goodbye: exit, say something nice +# +procedure goodbye() + + # UNIX-specific command. + system("stty echo") + + status_line("- \"Profile,\" by Richard Goerwitz -") + every boldface() | emphasize() | normal() | + boldface() | emphasize() | normal() + do { + delay(50) + iputs(igoto(CM, 1, LI-1)) + writes("Hope you enjoyed using profile! ") + normal(); iputs(CE) + } + exit() + +end + + +# +# stop_profile: graceful exit after error +# +procedure stop_profile(s) + + # UNIX-specific command. + system("stty echo") + + status_line("- \"Profile,\" by Richard Goerwitz -") + iputs(igoto(CM, 1, LI-1)) + writes(s); iputs(CE) + iputs(igoto(CM, 1, LI)) + stop() + +end diff --git a/ipl/progs/ipsort.icn b/ipl/progs/ipsort.icn new file mode 100644 index 0000000..2ac9083 --- /dev/null +++ b/ipl/progs/ipsort.icn @@ -0,0 +1,92 @@ +############################################################################ +# +# File: ipsort.icn +# +# Subject: Program to sort Icon procedures +# +# Author: Ralph E. Griswold +# +# Date: June 27, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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. +# +# One option is accepted: +# +# -v preserve VIB section at end +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local line, x, i, proctable, proclist, comments, procname, opts, vib + + opts := options(args, "v") + + vib := opts["v"] + comments := [] # list of comment lines + proctable := table() # table of procedure declarations + + while line := read() do { + line ? { + if \vib & ="#===<<vib:begin>>===" then break + 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" | "invocable") + 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)) + + if \vib then { + write() + write(line) + while write(read()) + } + +end diff --git a/ipl/progs/ipsplit.icn b/ipl/progs/ipsplit.icn new file mode 100644 index 0000000..d92a12c --- /dev/null +++ b/ipl/progs/ipsplit.icn @@ -0,0 +1,85 @@ +############################################################################ +# +# File: ipsplit.icn +# +# Subject: Program to split Icon program into files +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/ipxref.icn b/ipl/progs/ipxref.icn new file mode 100644 index 0000000..522dd30 --- /dev/null +++ b/ipl/progs/ipxref.icn @@ -0,0 +1,236 @@ +############################################################################ +# +# File: ipxref.icn +# +# Subject: Program to cross reference Icon program +# +# Author: Allan J. Anderson +# +# Date: June 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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","invocable"] + 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 diff --git a/ipl/progs/irsort.icn b/ipl/progs/irsort.icn new file mode 100644 index 0000000..7a07f04 --- /dev/null +++ b/ipl/progs/irsort.icn @@ -0,0 +1,74 @@ +############################################################################ +# +# File: irsort.icn +# +# Subject: Program to sort Icon record declaration +# +# Author: Ralph E. Griswold +# +# Date: June 23, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads an Icon program and writes an equivalent +# program with the record declaration sorted alphabetically at the +# end. Global, link, invocable, and procedure declarations come in the order +# they appear in the original program. +# +# 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. +# +# Note: This program is still raw. White space and comments related +# to records may not come out as expected. A closed parenthesis in +# a comment in the midst of a record declaration will cause havok. +# +############################################################################ + + +procedure main(args) + local line, x, i, recordtable, recordlist, comments, recordname + + comments := [] # list of comment lines + recordtable := table() # table of record declarations + + while line := read() do { + line ? { + if ="record" & # record declaration + tab(many('\t ')) & + recordname := tab(upto('(')) | stop("*** bad syntax: ",line) + then { # if main, force sorting order + recordtable[recordname] := x := [] + put(x, line) + if upto(')', line) then next else while line := read() do { + put(x, line) + if upto(')', line) then break next + } + } + # other declarations + else if =("global" | "procedure" | "link" | "invocable") + then { + while write(get(comments)) + write(line) + } + else put(comments, line) + } + } + + while write(get(comments)) + + recordlist := sort(recordtable, 3) # sort record + + while get(recordlist) do + every write(!get(recordlist)) + +end diff --git a/ipl/progs/irunerr.icn b/ipl/progs/irunerr.icn new file mode 100644 index 0000000..8036713 --- /dev/null +++ b/ipl/progs/irunerr.icn @@ -0,0 +1,30 @@ +############################################################################ +# +# File: irunerr.icn +# +# Subject: Program to print Icon runtime errors +# +# Author: Robert J. Alexander +# +# Date: September 22, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to list Icon runtime errors. +# +############################################################################ + +procedure main() + local i + + every i := 100 to 500 do { + &error := 1 + runerr(i) + write(&errornumber," ","" ~== &errortext) + } + +end diff --git a/ipl/progs/iseq.icn b/ipl/progs/iseq.icn new file mode 100644 index 0000000..c3466fc --- /dev/null +++ b/ipl/progs/iseq.icn @@ -0,0 +1,50 @@ +############################################################################ +# +# File: iseq.icn +# +# Subject: Program to write sequence of integers +# +# Author: Ralph E. Griswold +# +# Date: November 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program generates integers in sequence. +# +# The following options are supported: +# +# -b i beginning integer; default 1 +# -e i ending integer; default no end +# -i i increment; default 1 +# -l i limit on number of integers generated; default no limit +# +# Large integer values are not supported. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, limit, start, stop, incr, i + + opts := options(args, "b+e+i+l+") + + limit := \opts["l"] | (2 ^ 32) # good enough + start := \opts["b"] | 1 + stop := \opts["e"] | (2 ^ 64) # sort of good enough + incr := \opts["i"] | 1 + + every i := seq(start, incr) \ limit do + if i > stop then exit() + else write(i) + +end diff --git a/ipl/progs/isize.icn b/ipl/progs/isize.icn new file mode 100644 index 0000000..ba26f45 --- /dev/null +++ b/ipl/progs/isize.icn @@ -0,0 +1,83 @@ +############################################################################ +# +# File: isize.icn +# +# Subject: Program to measure size of an Icon program +# +# Author: Ralph E. Griswold +# +# Date: May 11, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program give several measures of the size of an Icon program. +# The name of the program is given on the command line. +# +# The command line option -t produces tab-separated values without +# labeling instead of multipl labeled lines. +# +############################################################################ +# +# UNIX and the itokens meta-translator +# +############################################################################ +# +# Links: numbers, options +# +############################################################################ + +link numbers +link options + +$define Col 15 + +procedure main(args) + local chaff, code, line, cbytes, nbytes, input, tokens, opts, format + + opts := options(args, "t") + format := opts["t"] + + input := open(args[1]) | stop("*** cannot open file") + + cbytes := nbytes := code := chaff := 0 + + while line := read(input) do { + line ? { + tab(many(' \t')) + if ="#" | pos(0) then { + chaff +:= 1 + nbytes +:= *line + 1 + } + else { + code +:= 1 + cbytes +:= *line + 1 + } + } + } + + input := open("itokens " || args[1], "p") + tokens := read(input) + + if /format then { + write(left("bytes:", Col), right(cbytes + nbytes, 6)) + write(left("lines:", Col), right(code + chaff, 6)) + write(left("tokens:", Col), right(tokens, 6)) + write(left("% code lines", Col + 2), fix(100 * code, code + chaff, 7, 2)) + write(left("bytes/token:", Col + 2), fix(cbytes, tokens, 7, 2)) + write(left("tokens/code line:", Col + 2), fix(tokens, code, 7, 2)) + } + else { + writes(cbytes + nbytes, "\t") + writes(code + chaff, "\t") + writes(tokens, "\t") + writes(fix(100 * code, code + chaff, 7, 2), "\t") + writes(fix(cbytes, tokens, 7, 2), "\t") + writes(fix(tokens, code, 7, 2)) + write() + } + +end diff --git a/ipl/progs/isrcline.icn b/ipl/progs/isrcline.icn new file mode 100644 index 0000000..d28e7f3 --- /dev/null +++ b/ipl/progs/isrcline.icn @@ -0,0 +1,51 @@ +############################################################################ +# +# File: isrcline.icn +# +# Subject: Program to count code lines in Icon program +# +# Author: Ralph E. Griswold +# +# Date: November 7, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program counts the number of lines in a Icon program that actually +# contain code, as opposed to being comments or blank lines. +# +# Note: preprocessor directives are counted as code lines. +# +############################################################################ +# +# Links: numbers +# +############################################################################ + +link numbers + +procedure main() + local total, chaff, code, line + + total := chaff := 0 + + while line := read() do { + total +:= 1 + line ? { + tab(many(' \t')) + if ="#" | pos(0) then chaff +:= 1 + } + } + + code := total - chaff + + write(left("total lines:", 17), right(total, 6)) + write(left("code lines:", 17), right(code, 6)) + write(left("non-code lines:", 17), right(chaff, 6)) + write() + write(left("percentage code:", 17), fix(100 * code, total, 7, 2)) + +end diff --git a/ipl/progs/istrip.icn b/ipl/progs/istrip.icn new file mode 100644 index 0000000..e4cde35 --- /dev/null +++ b/ipl/progs/istrip.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: istrip.icn +# +# Subject: Program to strip comments from Icon program +# +# Author: Ralph E. Griswold +# +# Date: March 29, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program strips comments out of an Icon program. It also removes +# empty lines and leading whitespace (see stripcom.icn). +# +############################################################################ +# +# Links: stripcom +# +############################################################################ + +link stripcom + +procedure main() + local line, nextline + + while line := read() do { + while line[-1] == "_" do { # handle continued literal + nextline := read() | stop("*** unclosed continued literal") + nextline ?:= { + tab(many(' \t')) # remove leading whitespace + tab(0) + } + line := line[1:-1] || nextline + } + write(stripcom(line)) + } + +end diff --git a/ipl/progs/itab.icn b/ipl/progs/itab.icn new file mode 100644 index 0000000..c81a38b --- /dev/null +++ b/ipl/progs/itab.icn @@ -0,0 +1,105 @@ +############################################################################ +# +# File: itab.icn +# +# Subject: Program to entab an Icon program +# +# Author: Robert J. Alexander +# +# Date: August 30, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# itab -- Entab an Icon program, leaving quoted strings alone. +# +# itab [options] [source-program...] +# +# options: +# -i Input tab spacing (default 8) +# -o Outut tab spacing (default 8) +# +# Observes Icon Programming Language conventions for escapes and +# continuations in string constants. If no source-program names are +# given, standard input is "itabbed" to standard output. +# +############################################################################ +# +# Links: options, io +# +############################################################################ + +link options +link io + +global mapchars,intabs,outtabs + +procedure main(arg) + + local opt, fn, f, outfn, outf, f1, f2, buf + + opt := options(arg,"i+o+") + intabs := (\opt["i"] | 8) + 1 + outtabs := (\opt["o"] | 8) + 1 + if *arg = 0 then itab(&input,&output) + else every fn := !arg do { + if not (fn[-4:0] == ".icn") then fn ||:= ".icn" + write(&errout,"Entabbing ",fn) + f := open(fn) | stop("Can't open input file ",fn) + outfn := fn || ".temp" + outf := open(outfn,"w") | stop("Can't open output file ",outfn) + itab(f,outf) + close(outf) + close(f) + fcopy(outfn,fn) + remove(outfn) + } +end + + +procedure itab(f,outf) + local line,c,nonwhite,comment,delim + line := "" + while c := readx(f) do { + if not any(' \t',c) then nonwhite := 1 + case c of { + "\n": { + write(outf,map(entab(line,outtabs),\mapchars," \t") | line) + line := "" + nonwhite := comment := &null + } + "'" | "\"": { + if /comment then + (/delim := c) | (if c == delim then delim := &null) + line ||:= c + } + "\\": line ||:= c || if /comment then readx(f) else "" + "#": { + if /delim then comment := c + line ||:= c + } + default: { + line ||:= if /comment & \delim & \nonwhite & \mapchars then + map(c," \t",mapchars) else c + } + } + } + return +end + + +procedure readx(f) + static buf,printchars + initial { + buf := "" + printchars := &cset[33:128] + } + if *buf = 0 then { + buf := detab(read(f),intabs) || "\n" | fail + mapchars := (printchars -- buf)[1+:2] | &null + } + return 1(.buf[1],buf[1] := "") +end diff --git a/ipl/progs/itags.icn b/ipl/progs/itags.icn new file mode 100644 index 0000000..365c2fb --- /dev/null +++ b/ipl/progs/itags.icn @@ -0,0 +1,128 @@ +############################################################################ +# +# File: itags.icn +# +# Subject: Program to create tags file for Icon programs +# +# Author: Robert J. Alexander +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to create a tags file for an Icon program. It has the +# options described in the Sun 3.5 man entry for ctags (except -u -- +# update tags file): +# +# Usage: itags [-aBFtvwx] [-f tagsfile] file... +# +# -a append output to an existing tags file. +# +# -B use backward searching patterns (?...?). +# +# -F use forward searching patterns (/.../) (default). +# +# -x produce a list of object names, the line number and +# file name on which each is defined, as well as the text +# of that line and prints this on the standard output. +# This is a simple index which can be printed out as an +# off-line readable function index. +# +# -t create tags for records. +# +# -v produce on the standard output an index of the form +# expected by vgrind(1). This listing contains the +# function name, file name, and page number (assuming 64 +# line pages). Since the output will be sorted into lex- +# icographic order, it may be desired to run the output +# through sort -f. Sample use: +# itags -v files | sort -f > index +# vgrind -x index +# +# -w suppress warning diagnostics. +# +############################################################################ +# +# Links: sort, io, options +# +############################################################################ + +link sort, io, options + +global patChar + +record Tag(fn,line,linenbr,shortline) + +procedure main(arg) + local Write,f,fn,idChar,line,linenbr,noWarnings,opt,space,tag,tags, + tf,tfn,typedef,x + # + # Handle command line options and initialization. + # + opt := options(arg,"aBFxtvwuf:") + if *arg = 0 then + stop("usage: itags [-aBFtvwx] [-f tagsfile] file...") + if \opt["u"] then stop("update option (-u) not supported -- rebuild file") + patChar := if \opt["B"] & /opt["F"] then "?" else "/" + Write := (if \opt["v"] then VGrind + else if \opt["x"] then Index + else { + tfn := \opt["f"] | "tags" + tf := open(tfn,if \opt["a"] then "a" else "w") | + stop("Can't open tags file \"",tfn,"\"") + Tags + }) + typedef := opt["t"] + noWarnings := opt["w"] + idChar := &letters ++ &digits ++ "_" + space := ' \t\v\f\r' + tags := table() + # + # Loop to read files. + # + every fn := !arg do { + if not find(".",fn) then fn ||:= ".icn" + f := open(fn) | write(&errout,"Couldn't open \"",fn,"\"") + linenbr := 0 + while line := read(f) do line ? { + linenbr +:= 1 + if (tab(many(space)) | &null) & =("procedure" | (\typedef,"record")) & + tab(many(space)) then { + tag := tab(many(idChar)) + if x := \tags[tag] then { + if /noWarnings then + write(&errout,"Duplicate entry in file ",fn,", line ",linenbr, + ": ",tag,"\nSecond entry ignored") + } + else + tags[tag] := Tag(fn,line,linenbr,line[1:&pos + 1]) + } + } + close(f) + } + # + # Do requested output. + # + every Write(!sort(tags),tf) +end + + +# +# Output procedures. +# +procedure Tags(x,f) + return write(f,x[1],"\t",x[2].fn,"\t",patChar,"^",x[2].shortline,patChar) +end + +procedure Index(x) + return write(left(x[1],*x[1] < 16) | x[1],right(x[2].linenbr,4)," ", + left(x[2].fn,17),x[2].line) +end + +procedure VGrind(x) + return write(x[1]," ",x[2].fn," ",(x[2].linenbr - 1) / 64 + 1) +end diff --git a/ipl/progs/itrbksum.icn b/ipl/progs/itrbksum.icn new file mode 100644 index 0000000..0b0a3d6 --- /dev/null +++ b/ipl/progs/itrbksum.icn @@ -0,0 +1,51 @@ +############################################################################ +# +# File: itrbksum.icn +# +# Subject: Program to give summary of traceback +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program summarizes traceback information produced on error +# termination by filtering out the bulk of the procedure traceback +# information. +# +# Expect various options in future versions. +# +############################################################################ + +$define CountWidth 10 + +procedure main() + local line, count + + while line := read() do { + if line ? =("Trace back:" | "Traceback") then break + else write(line) + } + + write() + write(read()) + + count := 0 + while line := read() do + count +:= 1 + + every 1 to 3 do + write("\t.") + + write(line) + + write() + + write("at level ", count) + +end diff --git a/ipl/progs/itrcfltr.icn b/ipl/progs/itrcfltr.icn new file mode 100644 index 0000000..c073aba --- /dev/null +++ b/ipl/progs/itrcfltr.icn @@ -0,0 +1,69 @@ +############################################################################ +# +# File: itrcfltr.icn +# +# Subject: Program to filter trace output +# +# Author: Ralph E. Griswold +# +# Date: July 14, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program filters trace output. If there are command-line arguments, +# they are taken as procedure names, and only those lines with those +# names are written. If there are no command-line arguments, all lines +# are written. +# +# The names of procedures to pass through can be given in a "response" +# file as accepted by options(), as in +# +# itrcfltr @names <trace_file +# +# where names is a file containing the names to be passed through. +# +# The following option is supported: +# +# -a list all trace messages; overrides any procedure names +# given +# +############################################################################ +# +# See also: options.icn +# +############################################################################ +# +# Links: itrcline, options +# +############################################################################ + +link itrcline +link options + +$define CountWidth 10 + +procedure main(args) + local line, name, selected, opts + + opts := options(args, "a") + + selected := set(args) + + if (*selected = 0) | \opts["a"] then # if -a or no names produce all + every write(itrcline(&input)) + else { + every line := itrcline(&input) do { + line ? { + move(21) | break # line after trace output? + tab(many('| ')) # depth bars + name := tab(upto('( ')) # procedure name + if member(selected, name) then write(line) + } + } + } + +end diff --git a/ipl/progs/itrcsum.icn b/ipl/progs/itrcsum.icn new file mode 100644 index 0000000..04df217 --- /dev/null +++ b/ipl/progs/itrcsum.icn @@ -0,0 +1,110 @@ +############################################################################ +# +# File: itrcsum.icn +# +# Subject: Program to give summary of trace output +# +# Author: Ralph E. Griswold +# +# Date: July 14, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program provides a summary of Icon trace output. +# +############################################################################ +# +# Links: itrcline, numbers +# +############################################################################ + +link itrcline +link numbers + +$define CountWidth 10 + +procedure main() + local line, file_tbl, call_tbl, return_tbl, fail_tbl, suspend_tbl + local resume_tbl, max, ave, count, file, bars, depth, keys, width + + file_tbl := table(0) + call_tbl := table(0) + return_tbl := table(0) + suspend_tbl := table(0) + fail_tbl := table(0) + resume_tbl := table(0) + + max := 0 + ave := 0 + count := 0 + + while line := itrcline(&input) do { + line ? { + file := move(13) | break # line after trace output? + count +:= 1 + if trim(file) == "" then file := "(none) " + file_tbl[file] +:= 1 + move(8) # line number field + if bars := tab(many('| ')) then { # depth bars + depth := *bars / 2 # recursion depth + max <:= depth # maximum depth + ave +:= depth # cumulative depth + } + name := tab(upto('( ')) # procedure name + tab(bal(' ') | 0) # skip arguments (faulty) + if pos(0) then { + call_tbl[name] +:= 1 + next + } + if =" returned" then return_tbl[name] +:= 1 + else if =" failed" then fail_tbl[name] +:= 1 + else if =" suspended" then suspend_tbl[name] +:= 1 + else if =" resumed" then resume_tbl[name] +:= 1 + } + } + + if count = 0 then { + write("no trace output") + exit() + } + + write("maximum recursion depth = ", max) + write("average recursion depth = ", fix(ave, count, 5, 3)) + write() + write("File references:\n") + file_tbl := sort(file_tbl, 3) + while write(get(file_tbl), right(get(file_tbl), 10)) + write("\nprocedure activity:\n") + + keys := [] + every put(keys, key(call_tbl)) + + width := 0 + every width <:= *!keys + width +:= 2 + + write( + left("name", width), + right("call", CountWidth), + right("return", CountWidth), + right("suspend", CountWidth), + right("fail", CountWidth), + right("resume", CountWidth), + "\n" + ) + + every name := !sort(keys) do + write( + left(name, width), + right(call_tbl[name], CountWidth), + right(return_tbl[name], CountWidth), + right(suspend_tbl[name], CountWidth), + right(fail_tbl[name], CountWidth), + right(resume_tbl[name], CountWidth) + ) + +end diff --git a/ipl/progs/iundecl.icn b/ipl/progs/iundecl.icn new file mode 100644 index 0000000..381d7d2 --- /dev/null +++ b/ipl/progs/iundecl.icn @@ -0,0 +1,124 @@ +############################################################################ +# +# File: iundecl.icn +# +# Subject: Program to find undeclared Icon identifiers +# +# Authors: Robert J. Alexander and Ralph E. Griswold +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 +# +############################################################################ +# +# Links: io +# +############################################################################ + +link io + +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("version mismatch") then { + write(&errout, line) + exit() + } + 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 + + diff --git a/ipl/progs/iversion.icn b/ipl/progs/iversion.icn new file mode 100644 index 0000000..6d4c741 --- /dev/null +++ b/ipl/progs/iversion.icn @@ -0,0 +1,57 @@ +############################################################################ +# +# File: iversion.icn +# +# Subject: Program to show icode version +# +# Author: Ralph E. Griswold +# +# Date: April 28, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reports the version of Icon icode files whose names +# are supplied, one name per line, from standard input. +# +# The method is necessarily somewhat heuristic and may not work on +# all systems and for very old icode versions. +# +# This program does not work on icode files with shell headers +# (notably Version 9 Icon under UNIX). +# +############################################################################ + +procedure main() + local name, file, icode, okay + + while name := read() do { + writes(name, ": ") + file := open(name,"u") | { + write("cannot open") + next + } + okay := &null + while icode := reads(file,30000) do # enough for most UNIX headers + icode ? { + while tab(upto('I') + 1) do { + if any('5678') then { + write(tab(upto('\0'))) + okay := 1 + exit() # one is enough ... + } + } + } + if /okay then { + write("no version") + write("may have shell header or not be icode file") + } + close(file) + } + +end + + diff --git a/ipl/progs/iwriter.icn b/ipl/progs/iwriter.icn new file mode 100644 index 0000000..feae11b --- /dev/null +++ b/ipl/progs/iwriter.icn @@ -0,0 +1,28 @@ +############################################################################ +# +# File: iwriter.icn +# +# Subject: Program to write Icon code to write input +# +# Author: Ralph E. Griswold +# +# Date: March 7, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/knapsack.icn b/ipl/progs/knapsack.icn new file mode 100644 index 0000000..6d41aca --- /dev/null +++ b/ipl/progs/knapsack.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: knapsack.icn +# +# Subject: Program to fill a container +# +# Author: Anthony V. Hewitt +# +# Date: August 8, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.1 +# +############################################################################ +# +# This filter solves a knapsack problem - how to fill a container to +# capacity by inserting items of various volumes. +# +# input: a string of newline-separated volumes +# +# argument: the capacity to be filled exactly +# +# output: a single solution +# +# It is derived from fillup.icn, which has a bewildering array of +# options to make it applicable to real-world problems. In +# contrast, knapsack is merely a demonstration of the underlying +# algorithm. +# +# The return statement in trynext() greatly improves the efficiency +# by restricting the search to fruitful branches of the search tree. +# While the use of multiple returns may be considered poor style, +# such a structure is often more readable than the alternatives. In +# this case, it also seems to be faster. +# +# Knapsack may be tested conveniently by piping to it the output +# of randi, a trivial program, like this: +# +# iconx randi 100 10 | iconx knapsack 250 +# +# You may pick a different capacity, of course; this one just +# happens to produce a result quite quickly, as you might expect. +# +############################################################################ + +global vols,chosen,capacity + +procedure main(args) + capacity := integer(args[1]) | stop("usage: knapsack capacity") + vols := []; every put(vols,0 < integer(!&input)) + chosen := list(*vols,0) + # assert the requirement and write a solution + trynext(0,1) = capacity + every write(0 < !chosen) + end + +# trynext - recursively try to insert vols[n], incrementing n each +# time, while the knapsack is not full and the reference is within +# bounds +procedure trynext(totvol,n) + (capacity <= totvol) & return totvol # prune the tree for efficiency + suspend trynext(totvol + (chosen[n] := (vols[n] | 0)), n+1) + end diff --git a/ipl/progs/krieg.icn b/ipl/progs/krieg.icn new file mode 100644 index 0000000..68235b8 --- /dev/null +++ b/ipl/progs/krieg.icn @@ -0,0 +1,1224 @@ +############################################################################ +# +# File: krieg.icn +# +# Subject: Program to play kriegspiel +# +# Author: David J. Slate +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/kross.icn b/ipl/progs/kross.icn new file mode 100644 index 0000000..1e2bc1a --- /dev/null +++ b/ipl/progs/kross.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: kross.icn +# +# Subject: Program to show intersections of strings +# +# Author: Ralph E. Griswold +# +# Date: May 9, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/kwic.icn b/ipl/progs/kwic.icn new file mode 100644 index 0000000..d72d572 --- /dev/null +++ b/ipl/progs/kwic.icn @@ -0,0 +1,98 @@ +############################################################################ +# +# File: kwic.icn +# +# Subject: Program to produce keywords in context +# +# Author: Stephen B. Wampler, modified by Ralph E. Griswold +# +# Date: February 15, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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. +# +# If an integer is given on the command line, it overrides the default +# 40. +# +# Some noise words are omitted (see "exceptions" in the program text). +# If a file named except.wrd is open and readable in the 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, width + +procedure main(args) + local exceptfile + + width := integer(args[1]) | 40 + + 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", "by", "for"]) + + 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 ++ &digits ++ '\'' + 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 := width - loc + if offset >= 0 then return repl(" ",offset) || line + else return line[-offset + 1:0] +end diff --git a/ipl/progs/kwicprep.icn b/ipl/progs/kwicprep.icn new file mode 100644 index 0000000..9f106c3 --- /dev/null +++ b/ipl/progs/kwicprep.icn @@ -0,0 +1,55 @@ +############################################################################ +# +# File: kwicprep.icn +# +# Subject: Program to prepare information for IPL KWIC listings +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +########################################################################### +# +# This program prepares information used for creating keyword-in-context +# listings of the Icon program library. +# +########################################################################### + +procedure main() + local files, file, input, line + + files := open("ls [a-z]*.icn", "p") + + while file := read(files) do { + if *file > 13 then write(&errout,"*** file name too long: ", file) + input := open(file) + every 1 to 4 do read(input) # skip to subject line + line := read(input) | { + write(&errout, "*** no subject in ", file) + next + } + line ? { + if tab(find("Subject: Program ") + 18) | + tab(find("Subject: Procedures") + 21) | + tab(find("Subject: Procedure ") + 20) | + tab(find("Subject: Procedure ") + 20) | + tab(find("Subject: Definitions ") + 22) | + tab(find("Subject: Declarations ") + 23) | + tab(find("Subject: Declaration ") + 22) | + tab(find("Subject: Link declarations ") + 28) | + tab(find("Subject: Link declaration ") + 27) | + tab(find("Subject: Record declarations ") + 30) | + tab(find("Subject: Record declaration ") + 29) then { + =("for " | "to ") # optional in some cases + write(file, ": ", tab(0)) + } + else write(&errout, "*** bad subject line in ", file) + } + close(input) + } + +end diff --git a/ipl/progs/la.icn b/ipl/progs/la.icn new file mode 100644 index 0000000..c93cb78 --- /dev/null +++ b/ipl/progs/la.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: la.icn +# +# Subject: Program to give exponent approximation for large numbers +# +# Author: Ralph E. Griswold +# +# Date: April 17, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# +# +############################################################################ +# +# Requires: +# +############################################################################ +# +# Links: lrgapprx +# +############################################################################ + +link lrgapprx + +procedure main() + + while write(lrgapprx(read())) + + +end diff --git a/ipl/progs/labels.icn b/ipl/progs/labels.icn new file mode 100644 index 0000000..26fdfa7 --- /dev/null +++ b/ipl/progs/labels.icn @@ -0,0 +1,160 @@ +############################################################################ +# +# File: labels.icn +# +# Subject: Program to format mailing labels +# +# Author: Ralph E. Griswold +# +# Date: December 30, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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). +# +# 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, io +# +############################################################################ +# +# See also: address.doc, adllist.icn, adlfiltr.icn, adlcount.icn, +# adlcheck.icn, zipsort.icn +# +############################################################################ + +link options, io + +global lsize, repet, llength, ldepth, opts, selectors + +procedure main(args) + local y, i, line + + selectors := '#' + lsize := 9 + ldepth := 8 + llength := 40 + repet := 1 + i := 0 + opts := options(args,"c+d+l+s:tw+") + 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") + + while line := Read() do + line ? { + if any('#') & upto(selectors) then nextlbl() + } + +end + +# Obtain next label +# +procedure nextlbl() + local label, max, line + label := [Read()] + max := 0 + while line := Read() do { + if line[1] == "*" then next + if line[1] == "#" then { + PutBack(line) + break + } + 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 diff --git a/ipl/progs/lam.icn b/ipl/progs/lam.icn new file mode 100644 index 0000000..4ed8125 --- /dev/null +++ b/ipl/progs/lam.icn @@ -0,0 +1,92 @@ +############################################################################ +# +# File: lam.icn +# +# Subject: Program to laminate files +# +# Author: Thomas R. Hicks +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/latexidx.icn b/ipl/progs/latexidx.icn new file mode 100644 index 0000000..cca1fa0 --- /dev/null +++ b/ipl/progs/latexidx.icn @@ -0,0 +1,141 @@ +############################################################################ +# +# File: latexidx.icn +# +# Subject: Program to process LaTeX idx file +# +# Author: David S. Cargo +# +# Date: April 19, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/lc.icn b/ipl/progs/lc.icn new file mode 100644 index 0000000..937425d --- /dev/null +++ b/ipl/progs/lc.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: lc.icn +# +# Subject: Program to count lines in file +# +# Author: Ralph E. Griswold +# +# Date: July 19, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program simply counts the number of lines in standard input +# and writes the result to standard output. +# +# Assumes UNIX-style line terminators. +# +# Requires lots of memory as written. +# +############################################################################ + +procedure main() + local count, line + + count := 0 + + while line := reads(, 1000000) do + line ? { + every upto('\n') do + count +:= 1 + } + + write(count) + +end diff --git a/ipl/progs/lcfile.icn b/ipl/progs/lcfile.icn new file mode 100644 index 0000000..f302de9 --- /dev/null +++ b/ipl/progs/lcfile.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: lcfile.icn +# +# Subject: Program to convert file names to lowercase +# +# Author: Ralph E. Griswold +# +# Date: June 11, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program converts file names to lowercase letters. File names to +# convert are given in standard input. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main() + local name + + while name := read() do + system("mv " || name || " " || map(name)) + +end diff --git a/ipl/progs/lcn.icn b/ipl/progs/lcn.icn new file mode 100644 index 0000000..d2a2a1d --- /dev/null +++ b/ipl/progs/lcn.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: lcn.icn +# +# Subject: Program to convert file names to all lowercase +# +# Author: Ralph E. Griswold +# +# Date: February 25, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program converts files named on the command line to all lowercase +# names. Blanks are converted to underscores. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main(args) + local name, lc, uc + + uc := &ucase || " " + lc := &lcase || "_" + + every name := !args do + rename(name, map(name, uc, lc)) + +end diff --git a/ipl/progs/limitf.icn b/ipl/progs/limitf.icn new file mode 100644 index 0000000..91d0a20 --- /dev/null +++ b/ipl/progs/limitf.icn @@ -0,0 +1,38 @@ +############################################################################ +# +# File: limitf.icn +# +# Subject: Program to limit throughput +# +# Author: Ralph E. Griswold +# +# Date: September 17, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is intended to be used in a pipe line. It passes through +# at most the number of line given by the command-line option -l (default +# 10). +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, limit + + opts := options(args, "l+") + + limit := \opts["l"] | 10 + + every write(!&input) \ limit + +end diff --git a/ipl/progs/lindcode.icn b/ipl/progs/lindcode.icn new file mode 100644 index 0000000..1d2c8da --- /dev/null +++ b/ipl/progs/lindcode.icn @@ -0,0 +1,97 @@ +############################################################################ +# +# File: lindcode.icn +# +# Subject: Program to produce Icon code from L-system specifications +# +# Author: Ralph E. Griswold +# +# Date: August 19, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads a file of L-system specifications and build Icon +# code that creates a table of records containing the specifications. +# +# If the option -e is given, symbols for which there is no definition +# are included in the table with themselves as replacement. +# +############################################################################ +# +# See also: lindrec.icn +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local allchar, rchar, line, prefix, symbol, rhs, file, name, spec + local value, c, opts, expand + + opts := options(args, "e") + expand := opts["e"] + write(" linden := table()\n") + + while line := read() do { + line ? { + if ="name:" then { + name := tab(0) + break + } + } + } + + repeat { + + allchar := rchar := '' + + prefix := " linden[" || image(name) || "]" + + write(prefix, " := lsys_0l(\"\", table(), 0, 90)") + + while line := read() | exit() do + line ? { + if symbol := move(1) & ="->" then { + rchar ++:= symbol + rhs := tab(0) + write(prefix, ".rewrite[\"", symbol, "\"] := ", image(rhs)) + allchar ++:= rhs + } + else if spec := tab(upto(':')) then { + move(1) + value := tab(0) + case spec of { + "axiom": { + allchar ++:= value + write(prefix, ".axiom := ", image(value)) + } + "gener": write(prefix, ".gener := ", integer(value)) + "angle": write(prefix, ".angle := ", real(value)) + "length": write(prefix, ".length := ", integer(value)) + "name": { + name := value + break + } + } + } + + } + + if \expand then { + allchar --:= rchar + every c := image(!allchar) do + write(prefix, ".rewrite[", c, "] := ", c) + } + + } + + +end diff --git a/ipl/progs/lindsys.icn b/ipl/progs/lindsys.icn new file mode 100644 index 0000000..bd92940 --- /dev/null +++ b/ipl/progs/lindsys.icn @@ -0,0 +1,142 @@ +############################################################################ +# +# File: lindsys.icn +# +# Subject: Program to generate sentences in 0L-systems +# +# Author: Ralph E. Griswold +# +# Date: October 23, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads in a 0L-system (Lindenmayer system) consisting of +# rewriting rules in which a string is rewritten with every character +# replaced simultaneously (conceptually) by a specified string of +# symbols. +# +# Rules have the form +# +# S->SSS... +# +# where S is a character. +# +# In addition to rules, there are keywords that describe attributes of the +# system. These include the "axiom", the string on which rewriting is +# started and "gener", the number of generations. +# +# The keyword "name" may be used to identify different L-systems in +# a file. If a name is given, it must be the first line of the L-system. +# +# If the keyword "end" is present, it is taken as the termination of +# the grammar. Otherwise, the end of the file serves this purpose. +# +# Other keywords may be present, but are ignored. For example, +# +# comment:This produces a great tree. +# +# is ignored. +# +# Keywords are followed by a colon. +# +# An example 0L-system is: +# +# name:dragon +# X->-FX++FY- +# Y->+FX--FY+ +# F-> +# -->- +# +->+ +# axiom:FX +# +# Here, the initial string is "FX". +# +# Note that "-" is a legal character in a 0L-system -- context determines +# whether it's 0L character or part of the "->" that stands for "is +# replaced by". +# +# If no rule is provided for a character, the character is not changed +# by rewriting. Thus, the example above can be expressed more concisely +# as +# +# name:dragon +# X->-FX++FY- +# Y->+FX--FY+ +# F-> +# axiom:FX +# +# The file containing the 0L-system is read from standard input. +# +# The command-line options are: +# +# -g i number of generations if not given, default 3 +# -a s axiom (overrides axiom given in the grammar) +# -A generate all intermediate results, not just the last +# +# Note: An earlier version of this program had the ability to +# extract an L-System specification by name from a file with +# multiple specifications. This version does not -- the former +# functionality was deemed to cumbersome. +# +# References: +# +# Formal Languages, Arto Salomaa, Academic Press, 1973. pp. 234-252. +# +# The Algorithmic Beauty of Plants, Przemyslaw Prusinkiewicz and +# Aristid Lindenmayer, Springer Verlag, 1990. +# +# Lindenmayer Systems, Fractals, and Plants, Przemyslaw Prusinkiewicz +# and James Hanan, Springer Verlag, 1989. +# +############################################################################ +# +# See linden.dat for an example of input data. +# +# See also linden.icn for a graphics version. +# +############################################################################ +# +# Links: lindgen, makelsys, options +# +############################################################################ + +link lindgen +link makelsys +link options + +procedure main(args) + local line, gener, axiom, opts, i, s, c, symbol, rewrite + local low, lsys, lst + + opts := options(args,"n:g+a:A") + + lst := [] + + while put(lst, read()) + + lsys := makelsys(lst) + + axiom := lsys.axiom + gener := lsys.gener + rewrite := lsys.productions + + axiom := \opts["a"] + gener := \opts["g"] + /gener := 3 + + if /axiom then stop("*** no axiom") + + # The following approach is inefficient if low is not gener. + + low := if /opts["A"] then gener else 1 + + every i := low to gener do { + every writes(lindgen(!axiom, rewrite, i)) + write() + } + +end diff --git a/ipl/progs/lineseq.icn b/ipl/progs/lineseq.icn new file mode 100644 index 0000000..464109d --- /dev/null +++ b/ipl/progs/lineseq.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: lineseq.icn +# +# Subject: Program to write a sequence of values on a line +# +# Author: Ralph E. Griswold +# +# Date: February 18, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads values on separate lines and strings them together +# on a single line. The default separator is a blank; other separating +# strings can be specified by the -s option +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, sep + + opts := options(args, "s:") + sep := \opts["s"] | " " + + every writes(!&input, sep) + + write() + +end diff --git a/ipl/progs/link2url.icn b/ipl/progs/link2url.icn new file mode 100644 index 0000000..19e2260 --- /dev/null +++ b/ipl/progs/link2url.icn @@ -0,0 +1,34 @@ +############################################################################ +# +# File: link2url.icn +# +# Subject: Program to convert links to URLs +# +# Author: Ralph E. Griswold +# +# Date: September 1, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program takes HTML links from standard input, strips off the +# tags and related material, and write the resulting URLs to standard +# output. +# +############################################################################ + +procedure main() + local line + + while line := read() do { + line ? { + tab(find("<A" | "<a")) + tab(upto('"') + 1) + write(tab(upto('"'))) + } + } + +end diff --git a/ipl/progs/lisp.icn b/ipl/progs/lisp.icn new file mode 100644 index 0000000..861044f --- /dev/null +++ b/ipl/progs/lisp.icn @@ -0,0 +1,419 @@ +############################################################################ +# +# File: lisp.icn +# +# Subject: Program to interpret LISP programs +# +# Author: Stephen B. Wampler, modified by Phillip Lee Thomas +# +# Date: February 4, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is a simple interpreter for pure Lisp. It takes the +# name of the Lisp program as a command-line argument. +# +# 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). +# +############################################################################ +# +# Syntax: +# (quote (a b c)) ==> (A B C) +# (setq a (quote (A B C))) ==> (A B C) +# (car a) ==> (A) +# (cdr a) ==> (B C) +# (cons (quote d) a) ==> (D A B C) +# (eq (car a) (car a)) ==> T +# (atom (quote ())) ==> T +# (atom a) ==> NIL +# (null (car (car a))) ==> T +# (eval (quote a)) ==> (A B C) +# (print a) ==> (A B C) +# (A B C) +# (define (quote ( +# (cadr (quote (lambda (l) (car (cdr l))))) +# (cddr (quote (lambda (l) (cdr (cdr l))))) +# ))) ==> (CADR CDDR) +# (trace (quote (cadr))) ==> NIL +# (untrace (quote (cadr))) ==> NIL +# (itraceon) ==> T [turns on icon tracing] +# (itraceoff) ==> NIL [turns off icon tracing] +# (exit) ==> [exit gracefully from icon] +# +############################################################################ + +global words, # table of variable atoms + T, NIL, # universal constants + infile # command line library files + +global trace_set # set of currently traced functions + +record prop(v,f) # abbreviated propery list + +### main interpretive loop +# +procedure main(f) +local sexpr, source + initialize() + while infile := open(source := (pop(f) | "CON")) do { + write("Reading: ", source) + every sexpr := bstol(getbs()) do { + PRINT([EVAL([sexpr])]) + writes("> ") + } + } + +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 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) + "EXIT" : exit(0) + 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, string(fn)) then { + write("Arguments of ",fn) + PRINT(l[2:0]) + } + if value := case 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, string(fn)) then { + write("value of ",fn) + PRINT(value) + } + return value + } + fcn := (\words[fn]).f | return NIL + if type(fcn) == "list" then + if fcn[1] == "LAMBDA" then { + value := lambda(l[2:0],fcn[2],fcn[3]) + if member(trace_set, 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, fn) + } + return NIL +end + +## (UNTRACE l) +# +procedure UNTRACE(l) + local fn + + every fn := !l do { + delete(trace_set, 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[fn_def[1]] := prop(NIL) + words[fn_def[1]].f := fn_def[2] + return 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 := ("" ~== |Map(read(infile))) || " " + + repeat { + while not checkbal(tmp) do { + if more(')','(',tmp) then break + tmp ||:= (("" ~== |Map(read(infile))) || " ") | break + } + suspend balstr(tmp) + tmp := (("" ~== |Map(read(infile))) || " ") | 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 diff --git a/ipl/progs/lister.icn b/ipl/progs/lister.icn new file mode 100644 index 0000000..2934ae2 --- /dev/null +++ b/ipl/progs/lister.icn @@ -0,0 +1,432 @@ +############################################################################ +# +# File: lister.icn +# +# Subject: Program to list filess +# +# Author: Beppe Pavoletti +# +# Date: December 28, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists files. Note that the language is in Italian. +# +############################################################################ +# +# PROGRAMMA LIST visualizzazione e stampa file +# +# Autore: Beppe Pavoletti +# Via Trieste 12 I-15011 +# ACQUI TERME AL +# +# Tel. 0144.320218 +# +# Versione 2.0 26.12.1993 + +############################################################################## + +procedure main() + +local tasto + +repeat { + righe(26) + write("±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±") + write() + write(" LIST V 2.0 -- Visualizzazione/elaborazione file -- 26.12.1993") + write() + write(" di Beppe Pavoletti Via Trieste 12 I-15011 ACQUI TERME AL ") + write() + write(" ²±° "||&dateline||" °°°°°±±±±²²²") + write() + write() + write(" A - Visualizzazione file ") + write(" B - Stampa su file o stampante ") + write(" C - Elaborazione file ") + write(" D - Ricerca di stringhe ") + write(" E - Cambia la directory corrente ") + write() + write(" X - Torna al DOS ") + write() + writes(" SCELTA >> ") + repeat + { tasto:=getch() + if find(tasto,"aAbBcCdDeExX") then + break } + write() + write() + case tasto of { + "a"|"A": faivedere(dainome()) + "b"|"B": stampa() + "c"|"C": trasforma() + "d"|"D": cerca() + "e"|"E": cambiadir() + "x"|"X": exit(0) } # fine del case + } # fine del repeat +end +############################################################################## + + +############################################################################## +procedure righe(quante) # produce righe vuote + +local contarighe + +contarighe:=1 +until contarighe = quante do + { write() + contarighe+:=1 } +end +############################################################################## + + +############################################################################## +procedure dainome() + +local quale + + quale:="" + writes("Introdurre un nome di file valido: ") + while quale == "" do + quale:=read() + return quale +end +############################################################################## + + +############################################################################## +procedure lpag() + +local valore + +write() +writes("Lunghezza di pagina (0 = nessun salto pagina) ") +if numeric(valore:=read()) then + return valore +else + return 0 +end +############################################################################## + + +############################################################################## +procedure margs() + +local margine + +write() +writes("Scostamento dal margine sinistro ") +if numeric(margine:=read()) then + return repl(" ",margine) +else + return "" +end +############################################################################## + + +############################################################################## +procedure numriga() + +local risp # risposta + +write() +writes("Stampa numeri di riga ? (S/N) ") +repeat + { risp:=getch() + if find(risp,"sSnN") then + break } +return risp +end +############################################################################## + + +############################################################################## +procedure compresso() + +local risp # risposta + +write() +writes("Attiva la stampa compressa con il carattere ASCII 15 ? (S/N) ") +repeat + { risp:=getch() + if find(risp,"sSnN") then + break } +return risp +end +############################################################################## + + + +############################################################################## +procedure trasforma() # elabora file + +local tasto + +repeat + { write() + write(" QUALE ELABORAZIONE VUOI EFFETTUARE ?") + write() + write(" A - Copia file") + write(" B - Elimina i fine riga (LF/CR)") + write(" C - Sostituzione carattere a scelta") + write(" D - Sostituisce le tabulazioni con spazi") + write(" E - Elimina i caratteri speciali (ASCII 0-31)") + write(" F - Elimina i caratteri ASCII estesi (> 126)") + write(" G - Elimina i caratteri speciali ed estesi") + write(" H - Elimina i caratteri spec. tranne segni diacritici") + write(" I - Elimina i caratteri speciali tranne LF/CR") + write() + write(" X - Menu principale") + write() + writes(" Scelta --> ") + repeat + { tasto:=getch() + if find(tasto,"aAbBcCdDeEfFgGhHiIxX") then + break } + righe(3) + case tasto of { + "a"|"A": copiafile(1) + "b"|"B": copiafile(2) + "c"|"C": copiafile(3) + "d"|"D": copiafile(4) + "e"|"E": copiafile(5) + "f"|"F": copiafile(6) + "g"|"G": copiafile(7) + "h"|"H": copiafile(8) + "i"|"I": copiafile(9) + "x"|"X": break } } # fine del repeat +end +############################################################################## + + +############################################################################## +procedure sceglinumero(messaggio) # introduzione di un numero + +local quale + +write() +writes(messaggio||" ") +repeat + { quale:=read() + if numeric(quale) then + if (quale > 0) then + break } +write() +return quale +end +############################################################################## + + +############################################################################## +procedure cambiadir() + +local nomedir + +write() +writes("Passare alla directory ") +if not chdir(nomedir:=read()) then + write(char(7)||"DIRECTORY NON ESISTENTE O NOME NON VALIDO") +end +############################################################################## + + +############################################################################## +procedure copiafile(switch) + +local origine,dest,nome1,nome2,dati,dati2,car,x,vecchio,nuovo,quantispazi,acc + +acc:='•…—Š‚„ƒ†ˆ‰‹ŒŽ“”–˜™š ¡¢£¤¥á' # set dei caratteri accentati +write() +write("SCELTA FILE O DEVICE DI ORIGINE ") +nome1:=dainome() +write() +write("SCELTA FILE O DEVICE DI DESTINAZIONE") +nome2:=dainome() +write() +if (origine:=open(nome1,"ru")) & (dest:=open(nome2,"wu")) then # apre i file { while dati:=reads(origine,1000) do + { case switch of { + 3: { vecchio:=sceglinumero("CODICE ASCII DEL CARATTERE DA SOSTITUIRE: ") + nuovo:=sceglinumero("CODICE ASCII DEL NUOVO CARATTERE") } + 4: { quantispazi:=sceglinumero("QUANTI SPAZI PER UNA TABULAZIONE ? ") } } + while dati:=reads(origine,40000) do + { case switch of { + 2: every x:=(dati ? find(char(10)|char(13))) do + dati[x]:=" " + 3: { every x:=(dati ? find(char(vecchio))) do + dati[x]:=char(nuovo) } + 4: { dati2:="" + dati ? { while car:=move(1) do + { if (car == "\t") then + car:=repl(" ",quantispazi) + dati2:=dati2||car } } + dati:=dati2 } + 5: { dati2:="" + dati ? { while car:=move(1) do + { if (ord(car) < 32) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 6: { dati2:="" + dati ? { while car:=move(1) do + { if (ord(car) > 126) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 7: { dati2:="" + dati ? { while car:=move(1) do + { if ((ord(car) > 126)|(ord(car) < 32)) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 8: { dati2:="" + dati ? { while car:=move(1) do + { if ((ord(car) > 126) & (not find(car,acc))) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 9: { dati2:="" + dati ? { while car:=move(1) do + { if (ord(car) < 32) & ((ord(car) ~= 10) & (ord(car) ~= 13)) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } } + writes(dest,dati) } # while dati:= + close(origine) + close(dest) } +else + { write() + write(char(7)||"IMPOSSIBILE APRIRE I FILE DI INPUT E/O OUTPUT") } +end +############################################################################## + + +############################################################################## +procedure stampa() # stampa o duplica il file + +local origine,dest,nome1,nome2,riga,contarighe,lungh,marg,nriga,comp + +write("SCELTA FILE O DEVICE DI ORIGINE ") +nome1:=dainome() +write() +write("SCELTA FILE O DEVICE DI DESTINAZIONE") +nome2:=dainome() +write() +if (origine:=open(nome1,"r")) & (dest:=open(nome2,"w")) then # apre i file + { lungh:=lpag() # sceglie la lunghezza pagina + nriga:=numriga() # stampa numeri di riga + if (not find(nriga,"sS")) then + marg:=margs() # scostamento dal margine + comp:=compresso() # stampa compressa + if find(comp,"sS") then + { write(dest,char(27)||char(120)||"0") # imposta il draft + write(dest,char(27)||char(77)) # imposta l'elite + write(dest,char(15)) } # imposta il compresso + contarighe:=1 + while riga:=read(origine) do + { if nriga == ("s"|"S") then + marg:=contarighe||" " + write(dest,marg||riga) + if (lungh ~= 0) & ((contarighe % lungh) = 0) then + write(dest,char(12)) # manda un salto pagina + contarighe+:=1 } # while riga + write(dest,char(12)) # salto pagina alla file + write(dest,char(18)) # annulla il compresso + close(origine) + close(dest) + write() + write("SCRITTE "||contarighe||" righe di "||nome1||" su "||nome2) + writes(" Invio per continuare ...") + read() } # if dest ... +else + { write() + write("IMPOSSIBILE APRIRE I FILE DI INPUT E/O OUTPUT") } +end +############################################################################## + + +############################################################################## +procedure dimmelo() + +local quale + + quale:="" + writes("Stringa da cercare >> ") + while quale == "" do + quale:=read() + return quale +end +############################################################################## + + +############################################################################## +procedure cerca() # ricerca di testo + +local origine,dest,nome1,nome2,riga,posizione,contatrova,testo + +write("SCELTA FILE O DEVICE DI ORIGINE ") +nome1:=dainome() +write() +write("SCELTA FILE O DEVICE DI DESTINAZIONE") +nome2:=dainome() +write() +testo:=dimmelo() # testo da cercare +contatrova:=0 +righe(25) +if (origine:=open(nome1,"r")) & (dest:=open(nome2,"w")) then # apre i file + { while riga:=reads(origine,40000) do + { every posizione:=(riga ? find(testo,riga)) do + { contatrova+:=1 + write(char(7)||riga[posizione-38:posizione+38]) + write(dest,"Occorrenza "||string(contatrova)||" di "||testo) + write(dest,riga[posizione-38|1:posizione+38|(*riga-posizione)]) + write(dest,"------------------------------------------") + write(dest) } } #scrive + close(origine) + close(dest) + righe(4) + write("Ricerca di "||testo||" nel file "||nome1) + write("Trovate "||string(contatrova)||" occorrenze") + write() + writes(" Invio per continuare ...") + read() } # if dest ... +else + { righe(2) + write("IMPOSSIBILE APRIRE I FILE DI INPUT E/O OUTPUT") } +end +############################################################################## + + +############################################################################## +procedure faivedere(nfile) # fa vedere il file + +local testo,riga,conta,x, count + +if testo:=open(nfile,"r") then # apre il file per la lettura + { count:=0 + while riga:=read(testo) do # ciclo lettura file + { write(riga) + count+:=1 + if (count % 21) = 0 then # fine pagina + { write() + write("±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±") + writes(" >> UN TASTO PER CONTINUARE X PER USCIRE ") + x:=getch() + if find(x,"xX") then + break } } + close(testo) + write() + write() + write(" >>> RIGHE SCRITTE "||count) + writes(" Invio per continuare ... ") + read() } + else # l'apertura fallisce + { write() + write("IMPOSSIBILE APRIRE IL FILE !!") } + write() +end +############################################################################# diff --git a/ipl/progs/listhtml.icn b/ipl/progs/listhtml.icn new file mode 100644 index 0000000..4362f4f --- /dev/null +++ b/ipl/progs/listhtml.icn @@ -0,0 +1,34 @@ +############################################################################ +# +# File: listhtml.icn +# +# Subject: Program to create Web page with links to listed files +# +# Author: Ralph E. Griswold +# +# Date: September 17, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The files to be included are listed in standard input. There is no +# check that the files actually exist. +# +############################################################################ + +procedure main() + local file + + write("<HTML><HEAD>") + write("<TITLE>File Links</TITLE></HEAD>") + write("<BODY>") + + every file := !&input do + write("<A HREF=\"", file, "\">", file, "</A><BR>") + + write("</BODY></HTML>") + +end diff --git a/ipl/progs/listviz.icn b/ipl/progs/listviz.icn new file mode 100644 index 0000000..ecd293c --- /dev/null +++ b/ipl/progs/listviz.icn @@ -0,0 +1,432 @@ +############################################################################ +# +# File: listviz.icn +# +# Subject: Program to visualize lists +# +# Author: Beppe Pavoletti +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program visualizes lists. Note that the language is Italian. +# +############################################################################ +# +# PROGRAMMA LIST visualizzazione e stampa file +# +# Autore: Beppe Pavoletti +# Via Trieste 12 I-15011 +# ACQUI TERME AL +# +# Tel. 0144.320218 +# +# Versione 2.0 26.12.1993 +# +############################################################################## + +procedure main() + +local tasto + +repeat { + righe(26) + write("±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±") + write() + write(" LIST V 2.0 -- Visualizzazione/elaborazione file -- 26.12.1993") + write() + write(" di Beppe Pavoletti Via Trieste 12 I-15011 ACQUI TERME AL ") + write() + write(" ²±° "||&dateline||" °°°°°±±±±²²²") + write() + write() + write(" A - Visualizzazione file ") + write(" B - Stampa su file o stampante ") + write(" C - Elaborazione file ") + write(" D - Ricerca di stringhe ") + write(" E - Cambia la directory corrente ") + write() + write(" X - Torna al DOS ") + write() + writes(" SCELTA >> ") + repeat + { tasto:=getch() + if find(tasto,"aAbBcCdDeExX") then + break } + write() + write() + case tasto of { + "a"|"A": faivedere(dainome()) + "b"|"B": stampa() + "c"|"C": trasforma() + "d"|"D": cerca() + "e"|"E": cambiadir() + "x"|"X": exit(0) } # fine del case + } # fine del repeat +end +############################################################################## + + +############################################################################## +procedure righe(quante) # produce righe vuote + +local contarighe + +contarighe:=1 +until contarighe = quante do + { write() + contarighe+:=1 } +end +############################################################################## + + +############################################################################## +procedure dainome() + +local quale + + quale:="" + writes("Introdurre un nome di file valido: ") + while quale == "" do + quale:=read() + return quale +end +############################################################################## + + +############################################################################## +procedure lpag() + +local valore + +write() +writes("Lunghezza di pagina (0 = nessun salto pagina) ") +if numeric(valore:=read()) then + return valore +else + return 0 +end +############################################################################## + + +############################################################################## +procedure margs() + +local margine + +write() +writes("Scostamento dal margine sinistro ") +if numeric(margine:=read()) then + return repl(" ",margine) +else + return "" +end +############################################################################## + + +############################################################################## +procedure numriga() + +local risp # risposta + +write() +writes("Stampa numeri di riga ? (S/N) ") +repeat + { risp:=getch() + if find(risp,"sSnN") then + break } +return risp +end +############################################################################## + + +############################################################################## +procedure compresso() + +local risp # risposta + +write() +writes("Attiva la stampa compressa con il carattere ASCII 15 ? (S/N) ") +repeat + { risp:=getch() + if find(risp,"sSnN") then + break } +return risp +end +############################################################################## + + + +############################################################################## +procedure trasforma() # elabora file + +local tasto + +repeat + { write() + write(" QUALE ELABORAZIONE VUOI EFFETTUARE ?") + write() + write(" A - Copia file") + write(" B - Elimina i fine riga (LF/CR)") + write(" C - Sostituzione carattere a scelta") + write(" D - Sostituisce le tabulazioni con spazi") + write(" E - Elimina i caratteri speciali (ASCII 0-31)") + write(" F - Elimina i caratteri ASCII estesi (> 126)") + write(" G - Elimina i caratteri speciali ed estesi") + write(" H - Elimina i caratteri spec. tranne segni diacritici") + write(" I - Elimina i caratteri speciali tranne LF/CR") + write() + write(" X - Menu principale") + write() + writes(" Scelta --> ") + repeat + { tasto:=getch() + if find(tasto,"aAbBcCdDeEfFgGhHiIxX") then + break } + righe(3) + case tasto of { + "a"|"A": copiafile(1) + "b"|"B": copiafile(2) + "c"|"C": copiafile(3) + "d"|"D": copiafile(4) + "e"|"E": copiafile(5) + "f"|"F": copiafile(6) + "g"|"G": copiafile(7) + "h"|"H": copiafile(8) + "i"|"I": copiafile(9) + "x"|"X": break } } # fine del repeat +end +############################################################################## + + +############################################################################## +procedure sceglinumero(messaggio) # introduzione di un numero + +local quale + +write() +writes(messaggio||" ") +repeat + { quale:=read() + if numeric(quale) then + if (quale > 0) then + break } +write() +return quale +end +############################################################################## + + +############################################################################## +procedure cambiadir() + +local nomedir + +write() +writes("Passare alla directory ") +if not chdir(nomedir:=read()) then + write(char(7)||"DIRECTORY NON ESISTENTE O NOME NON VALIDO") +end +############################################################################## + + +############################################################################## +procedure copiafile(switch) + +local origine,dest,nome1,nome2,dati,dati2,car,x,vecchio,nuovo,quantispazi,acc + +acc:='•…—Š‚„ƒ†ˆ‰‹ŒŽ“”–˜™š ¡¢£¤¥á' # set dei caratteri accentati +write() +write("SCELTA FILE O DEVICE DI ORIGINE ") +nome1:=dainome() +write() +write("SCELTA FILE O DEVICE DI DESTINAZIONE") +nome2:=dainome() +write() +if (origine:=open(nome1,"ru")) & (dest:=open(nome2,"wu")) then # apre i file { while dati:=reads(origine,1000) do + { case switch of { + 3: { vecchio:=sceglinumero("CODICE ASCII DEL CARATTERE DA SOSTITUIRE: ") + nuovo:=sceglinumero("CODICE ASCII DEL NUOVO CARATTERE") } + 4: { quantispazi:=sceglinumero("QUANTI SPAZI PER UNA TABULAZIONE ? ") } } + while dati:=reads(origine,40000) do + { case switch of { + 2: every x:=(dati ? find(char(10)|char(13))) do + dati[x]:=" " + 3: { every x:=(dati ? find(char(vecchio))) do + dati[x]:=char(nuovo) } + 4: { dati2:="" + dati ? { while car:=move(1) do + { if (car == "\t") then + car:=repl(" ",quantispazi) + dati2:=dati2||car } } + dati:=dati2 } + 5: { dati2:="" + dati ? { while car:=move(1) do + { if (ord(car) < 32) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 6: { dati2:="" + dati ? { while car:=move(1) do + { if (ord(car) > 126) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 7: { dati2:="" + dati ? { while car:=move(1) do + { if ((ord(car) > 126)|(ord(car) < 32)) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 8: { dati2:="" + dati ? { while car:=move(1) do + { if ((ord(car) > 126) & (not find(car,acc))) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } + 9: { dati2:="" + dati ? { while car:=move(1) do + { if (ord(car) < 32) & ((ord(car) ~= 10) & (ord(car) ~= 13)) then + car:="" + dati2:=dati2||car } } + dati:=dati2 } } + writes(dest,dati) } # while dati:= + close(origine) + close(dest) } +else + { write() + write(char(7)||"IMPOSSIBILE APRIRE I FILE DI INPUT E/O OUTPUT") } +end +############################################################################## + + +############################################################################## +procedure stampa() # stampa o duplica il file + +local origine,dest,nome1,nome2,riga,contarighe,lungh,marg,nriga,comp + +write("SCELTA FILE O DEVICE DI ORIGINE ") +nome1:=dainome() +write() +write("SCELTA FILE O DEVICE DI DESTINAZIONE") +nome2:=dainome() +write() +if (origine:=open(nome1,"r")) & (dest:=open(nome2,"w")) then # apre i file + { lungh:=lpag() # sceglie la lunghezza pagina + nriga:=numriga() # stampa numeri di riga + if (not find(nriga,"sS")) then + marg:=margs() # scostamento dal margine + comp:=compresso() # stampa compressa + if find(comp,"sS") then + { write(dest,char(27)||char(120)||"0") # imposta il draft + write(dest,char(27)||char(77)) # imposta l'elite + write(dest,char(15)) } # imposta il compresso + contarighe:=1 + while riga:=read(origine) do + { if nriga == ("s"|"S") then + marg:=contarighe||" " + write(dest,marg||riga) + if (lungh ~= 0) & ((contarighe % lungh) = 0) then + write(dest,char(12)) # manda un salto pagina + contarighe+:=1 } # while riga + write(dest,char(12)) # salto pagina alla file + write(dest,char(18)) # annulla il compresso + close(origine) + close(dest) + write() + write("SCRITTE "||contarighe||" righe di "||nome1||" su "||nome2) + writes(" Invio per continuare ...") + read() } # if dest ... +else + { write() + write("IMPOSSIBILE APRIRE I FILE DI INPUT E/O OUTPUT") } +end +############################################################################## + + +############################################################################## +procedure dimmelo() + +local quale + + quale:="" + writes("Stringa da cercare >> ") + while quale == "" do + quale:=read() + return quale +end +############################################################################## + + +############################################################################## +procedure cerca() # ricerca di testo + +local origine,dest,nome1,nome2,riga,posizione,contatrova,testo + +write("SCELTA FILE O DEVICE DI ORIGINE ") +nome1:=dainome() +write() +write("SCELTA FILE O DEVICE DI DESTINAZIONE") +nome2:=dainome() +write() +testo:=dimmelo() # testo da cercare +contatrova:=0 +righe(25) +if (origine:=open(nome1,"r")) & (dest:=open(nome2,"w")) then # apre i file + { while riga:=reads(origine,40000) do + { every posizione:=(riga ? find(testo,riga)) do + { contatrova+:=1 + write(char(7)||riga[posizione-38:posizione+38]) + write(dest,"Occorrenza "||string(contatrova)||" di "||testo) + write(dest,riga[posizione-38|1:posizione+38|(*riga-posizione)]) + write(dest,"------------------------------------------") + write(dest) } } #scrive + close(origine) + close(dest) + righe(4) + write("Ricerca di "||testo||" nel file "||nome1) + write("Trovate "||string(contatrova)||" occorrenze") + write() + writes(" Invio per continuare ...") + read() } # if dest ... +else + { righe(2) + write("IMPOSSIBILE APRIRE I FILE DI INPUT E/O OUTPUT") } +end +############################################################################## + + +############################################################################## +procedure faivedere(nfile) # fa vedere il file + +local testo,riga,conta,x, count + +if testo:=open(nfile,"r") then # apre il file per la lettura + { count:=0 + while riga:=read(testo) do # ciclo lettura file + { write(riga) + count+:=1 + if (count % 21) = 0 then # fine pagina + { write() + write("±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±") + writes(" >> UN TASTO PER CONTINUARE X PER USCIRE ") + x:=getch() + if find(x,"xX") then + break } } + close(testo) + write() + write() + write(" >>> RIGHE SCRITTE "||count) + writes(" Invio per continuare ... ") + read() } + else # l'apertura fallisce + { write() + write("IMPOSSIBILE APRIRE IL FILE !!") } + write() +end +############################################################################# diff --git a/ipl/progs/literat.icn b/ipl/progs/literat.icn new file mode 100644 index 0000000..fde9c5c --- /dev/null +++ b/ipl/progs/literat.icn @@ -0,0 +1,1083 @@ +############################################################################ +# +# File: literat.icn +# +# Subject: Program to manage literature information +# +# Author: Matthias Heesch +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Database system to manage information concerning literature. +# +############################################################################ +# +# Written by: Dr. Matthias Heesch +# Department of Protestant Theology (FB 02) +# Johannes Gutenberg University +# Saarstrasse 21 / D-W-6500 Mainz 1 / Germany +# +############################################################################ +# +# Written and tested under: DR/MS-DOS, using ansi.sys +# +############################################################################ +# +# See the comment lines concerning the single user defined +# functions if you want to use them separately. Note that all screen +# access assumes ansi.sys to be installed. +# +# Since arguments to the seek() function may be long integers, +# long-integer support is required. +# +# The program uses standard files literat.fil, literat2.fil and +# adress.fil to store its data on the disk. It has a predefined +# structure of the items and predefined field labels to make it easy +# to use and to cut down the source code length.for users having some +# knowledge of the Icon language it shouldn't be difficult to +# change the program. In this case the item length (now 846 byte) +# the option lists in menue() and the field label list have to be +# modified. The main changes then will concern user defined +# function edit_item() where the number of fields within an item +# is decided by *labels. In function in_itemm() the number of dummy +# field separators has to be equal to the amount of fields desired. +# (items := list(200,"##" if two fields are desired). Within the +# other functions only the amount of bytes for a whole item within +# reads() and seek() operation has to be changed accordingly. Note +# that "literat"'s editor in its present version isn't able to scroll. +# +# See the description (comment lines) of user defined function +# line() for details of the editing facilities. +# +# The menue accepts input by <arrow up/dn> and the lower case short +# hand key of every option. The selected option has to be activated +# by <ret>. +# +# iNPUT: function to update an existing file literat.dat. When moving +# the cursor out of the actual item, the last or following item will +# be displayed and is available for the editing process. Input treats +# literat.dat as a sequential file. Only the items to be added to the +# existing file are in the computer's memory. This fastens the option +# to switch between the (new) items. Otherwise it would have been +# necessary to load the whole literat.dat into the RAM or to load +# every new item from the disk. The first would consume too much +# memory with the result of potential loss of new items, the second +# would cost much time. In one session "literat" can accept no more +# than 200 new items. +# +# tURN_OVER_ITEMS: literat.dat can be viewed and edited item by item +# moving the cursor out of the actual item causes the next/last item +# to be displayed. The edited items are written to file literat2.fil +# +# aDRESS file: type words to be indicated. If they are found, the +# item numbers of their occurrence will be recorded in file adress.fil. +# Moving the cursor out of the editor causes the indicating +# process to start. New items to adress.fil are simply added to the +# file. Therefore changes of existing material in adress.fil have to +# be made by creating a new adress.fil. +# +# qUERY: searches item using the information in adress.fil. You are +# prompted to type a word and if it's found in adress.fil the +# programm will use the item numbers to compute arguments to the +# seek()-function and then read the item. After viewing and if +# desired editing the item it will be written to file literat2.fil. +# +# dEL: prompts for an item number and removes the corresponding item. +# the file then is written to literat2.fil, literat.fil remains +# as it was. +# +# AlPHA: alphabetical sorting, sorted file written to literat2.fil. +# +# eND: return to the operating system. +# +############################################################################ +# +# Important message to the user: everybody who will find and remove +# a bug or add any improvement to the program is kindly encouraged +# to send a copy to the above address. +# +############################################################################ +# +# Note: Clerical edits were made to this file by the Icon Project. +# It's possible they introduced errors. +# +############################################################################ +# +# Requires: large-integer arithmetic, ANSI terminal support +# +############################################################################ + +############################################################################ +# # +# linfield: line and field editing package # +# # +############################################################################ +# +# +############################################################################ +# # +# set of user defined functions essential to the line editor line() # +# # +############################################################################ +# +# newkey(): redirects keyboard to make some of the editing functions +# accessable also by arrow/ctrl-arrow-keys. needs ansi.sys. +# although newkey() isn't called by line() directly, a program +# which uses line() should contain a call to newkey(), because +# otherwise line()'S function won't be available for cursor keys. + + procedure newkey() + + local code, n_keys + n_keys := list(9) +# arrow left (cursor left) + n_keys[1] := char(27) || "[0;77;1p" +# arrow right (cursor right) + n_keys[2] := char(27) || "[0;75;2p" +# arrow up (quit, decreasing line_number) + n_keys[3] := char(27) || "[0;72;14p" +# arrow down (quit, increasing line_number) + n_keys[4] := char(27) || "[0;80;21p" +# ctrl/left + n_keys[5] := char(27) || "[0;116;8p" +# ctrl/right + n_keys[6] := char(27) || "[0;115;9p" +# home + n_keys[7] := char(27) || "[0;71;4p" +# end + n_keys[8] := char(27) || "[0;79;5p" +# deL + n_keys[9] := char(27) || "[0;83;6p" +# +# activate codes + while code := get(n_keys) do { + writes(code) + } +end +# +# +# function to set cursor position + procedure locate(row,col) + + local cursor + + cursor := char(27) || "[" || row || ";" || col || "H" + writes(cursor) +end +# +# last(byte,string): detects the last occurrence of byte in +# string and returns its position + procedure last(byte,string) + + local a, r_string, rpos + + r_string := reverse(string) + rpos := find(byte,r_string) + a := (*string - rpos) + return a +end +# +# remword(string,acol): removes word at acol from string + procedure remword(string,acol) + + local blank, string_a, string_b + +# if acol points to end of string, don`t do anything + if acol + 1 > *string then return string +# if acol points to a blank just remove the blank + if string[acol + 1] == " " then { + string ? { + string_a := tab(acol + 1) + move(1) + string_b := tab(0) + string := string_a || string_b + return string + } + } +# else delete actual word + if acol = 0 then acol := 1 +# crack string into two parts + string ? { + string_a := tab(acol + 1) + string_b := tab(0) + } +# check string_a for the last blank if any + if find(" ",string_a) then { + blank := last(" ",string_a) + string_a := string_a[1:blank + 1] + } + else string_a := "" +# check string_b for the first blank if any + if blank := find(" ",string_b) then { + string_b := string_b[blank:*string_b + 1] + } + else string_b := "" +# build string out of string_a ending at its last and string_b +# beginning at its first blank. + string := string_a || string_b + if string[1] == " " then string[1] := "" + return string +end +# +# stat_line: function to display a status line with the actual row +# and column + procedure stat_line(column) + locate(24,1) + writes("LINE: ",lin_nm," COL: ",column," ","TIME: ",&clock," ") +end +# +# global variable line_number to indicate the increase or decrease +# of global variable lin_nm + global line_number +# +# global variable lin_nm to increase or decrease actual line +# in the field + global lin_nm +# +# global variable field_flag: direction flag to increase or +# decrease field number + global field_flag +# +# global variable item_flag: direction flag to increase or +# decrease item number + global item_flag +# +############################################################################ +# # +# line editor line() # +# # +############################################################################ +# +# editing commands for the line editor: +# ctrl/A: byte forward (arrow right) +# ctrl/B: byte back (arrow left) +# ctrl/D: beginning of line (home) +# ctrl/E: end of line (end) +# ctrl/F: del byte (del) +# ctrl/G: del word +# ctrl/H: word forward (ctrl/right) +# ctrl/I: word back (ctrl/ left) +# ctrl/L: perform block operation +# 1. press ctrl/L +# 2. enter relative adress (followed by <ret>) for +# block end. It must be an (numerical) offset +# pointing right to the actual cursor. +# 3. enter "r" (no <ret>!) for remove or "b" +# to move block to the beginning of field +# or "e" to transfer it to the end. +# Annotation: "impossible" adresses (beyond string +# length or negative) will be ignored. +# alt/A : wrap line (+ 1) +# esc : del line +# ctrl/K: restore line +# ctrl/n: quit line (- 1) (arrow up) +# ctrl/U: quit line (+ 1) (arrow down) +# ret : quit line (+ 1) +############################################################################ +# +# Function to edit a line. The function needs the following +# arguments +# row : (row of the line to be edited) +# bnumber: (maximum size of the string to be +# edited, further input will be +# ignored.) +# status: display actual line_number and col2 if +# status == 1 else not +# comment: (comment or input prompt) +# field : (contains the string to be edited.) +# +# The function returns a list with the first element containing +# The main part of FIELD and the second element containing +# the wrapped part if any. +# + procedure line(row,bnumber,status,comment,field) + + local beg, blank, blanks, block, byte, byte_input, col, col2, dec_byte + local dec_bytes, e1, e2, editing, fa, fb, field2, field_1, field_2 + local field_a, field_b, fieldl, highl, lg, mark, n_blank, nb, normal + local quit, r_field, rest + +# Define csets containing the keys for +# input +# editing functions +# quit / wraP +# +# Characters permitted in the edited field + n_blank := &ucase ++ &lcase ++ &digits ++ '„”Ž™šá?.,;!' + byte_input := n_blank ++ ' ' +# Characters for the editing functions + e1 := set([char(1),char(2),char(4),char(5),char(6),char(7),char(8)]) + e2 := set([char(27),char(11)]) + editing := e1 ++ e2 +# Characters to end editing + quit := set([char(13),char(30),char(14),char(21)]) +# +# List to return result + fieldl := list() +# Initialize field_a/b for a concatenation, if scanning field +# fails + field_a := "" + field_b := "" +# Initialize r_field (variable to store completely deleted field +# to keep it recoverable) + r_field := "" +# Codes to highlight screen output and to return to normal +# screen outpuT + highl := char(27) || "[7m" + normal := char(27) || "[0m" +# +# Remove single initial blank if any + if field[1] == " " then { + field := field[2:(*field+1)] + } +# +# Display field when beginning the editing process, place +# cursor behind the end of field + locate(row,1) + writes(comment,field,repl(" ",(bnumber-*field))) +# If status is set to 1 display line_number and col2 after the +# initial printing of line + if status == 1 then stat_line(*field+1) +# col: absolute cursor position (comment and field) +# col2: relative position in field + col := (*comment + *field) + 1 + col2 := *field + 1 + locate(row,col) +# +# Editing loop: continue until end character appears + while byte := getch() & not member(quit,byte) do { + if find(byte,byte_input) & *field <= bnumber - 2 then { +# If byte is a normal character (if member(byte_input,byte)) insert +# it into field at cursor position. +# + field ? { + field_a := tab(col2) + field_b := tab(0) + } + field := field_a || byte || field_b + locate(row,1) + writes(comment,field) + col +:= 1 + col2 +:= 1 + if status == 1 then stat_line(col2) + locate(row,col) + } +# else perform editing operation + else { + case byte of { +# backspace (ctrl/B) + char(2) : if col2 > 1 then { + col -:= 1 + col2 -:= 1 + if status == 1 then stat_line(col2) + locate(row,col) + } +# byte forward (ctrl/A) + char(1) : if col2 <= *field then { + col +:= 1 + col2 +:= 1 + if status == 1 then stat_line(col2) + locate(row,col) + } +# goto beginning of line (ctrl/D) + char(4) : { + col2 := 1 + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } +# goto end of line (ctrl/E) + char(5) : { + col2 := (*field + 1) + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } +# delete byte at cursor position (ctrl/F) + char(6) : { + if col2 <= *field then { + field ? { + beg := tab(col2) + rest := tab(0) + + } + rest[1] := "" + field := beg || rest + locate(row,1) + writes(comment,field," ") + locate(row,col) + } + } +# +# delete the actual word (ctrl/G) + char(7) : { + field2 := remword(field,col2 - 1) + blanks := *field - *field2 + field := field2 + col2 := col2 - blanks + if col2 <= 0 then col2 := 1 + col := *comment + col2 + locate(row,1) + writes(comment,field,repl(" ",blanks)) + if status == 1 then stat_line(col2) + locate(row,col) + } + +# move to the beginning of the following word (ctrl/H) + char(8) : { + if find(" ",field[col2:*field]) then { + string := field[col2:*field] + blank := find(" ",string) + col2 := col2 + blank + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } + } +# +# move to the beginning of the recent word (ctrl/I) + char(9) : { +# jump over the blank preceding the actual word + if col2 = 1 then locate(row,col) + else { + if find(" ",field[1:(col2 - 2)]) then { + string := field[1:(col2 - 2)] + col2 := (last(" ",string) + 2) + } + else { + col2 := 1 + } + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } + } +# +# Delete complete line, deleted line is assigned to r_field +# to be recoverable + char(27) : { + lg := *field + r_field := field + field := "" + col2 := 1 + col := *comment + col2 + locate(row,1) + writes(comment,repl(" ",lg)) + if status == 1 then stat_line(col2) + locate(row,col) + } +# Restore deleted line (overwrite new actual line, assigning it +# to r_field) + char(11) : { + if *r_field >= 1 then { + field :=: r_field + col2 := *field + 1 + col := *comment + col2 + locate(row,1) + blanks := bnumber - *field + writes(comment,field,repl(" ",blanks)) + if status == 1 then stat_line(col2) + locate(row,col) + } + } + +# Perform block operation + char(12) : { + mark := "" + dec_bytes := "" + while nb := getch() & nb ~== char(13) do { + mark ||:= nb + } + if mark < 1 then mark := 1 +# Place cursor to field's beginning if it points to its end + if col2 >= *field then col2 := 1 + field ? { + fa := tab(col2) + block := move(mark) + fb := tab(0) + } + locate(row,1) + writes(comment,fa,highl,block,normal,fb) + dec_byte := getch() + if dec_byte == ("r" | "R") then { + field := fa || fb + locate(row,1) + writes(comment,field,repl(" ",*block + 1)) + col2 := col2 - *block + if col2 < 1 then col2 := 1 + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } + else { + if dec_byte == ("b" | "B") then { + field := block || fa || fb + } + if dec_byte == ("e" | "E") then { + field := fa || fb || block + locate(row,1) + } + locate(row,1) + writes(comment,field) + locate(row,col) + } + } + +# right brace closing case control structure + } +# right brace closing else structure (editing keys) + } +# right brace closing while-do loop + } +# +# if while-do loop stops it must be because of a key in quit. +# Therefore perform final operation and return. +# +# wrap: divide field at the last possible blank, assign the +# first part to the first element of list result, the second +# part to the second element. + if byte == char(30) & find(" ",field) then { + blank := last(" ",field) + field_1 := field[1:(blank + 1)] + field_2 := field[(blank + 2):(*field + 1)] + locate(row,(*comment + 1)) + writes(field_1,repl(" ",*field_2)) + put(fieldl,field_1) + put(fieldl,field_2) +# Increase lnumber by 1 + line_number := 1 +# Return list with main part and wrapped part as its elements + return fieldl + } +# +# normal termination by <ret> or <arrow down> + if byte == (char(13) | char(21)) then { + put(fieldl,field) + put(fieldl,"") + line_number := 1 + return fieldl + } +# normal termination by alt/e + else { + if byte == char(14) then { + put(fieldl,field) + put(fieldl,"") + line_number := -1 + return fieldl + } + } +end +# +############################################################################ +# # +# field editor edit_field() # +# # +############################################################################ +# +# edit_field: user-defined function to divide a long string into +# lines and edit them as a field. uses: line() and all user- +# defined functions called by line(). +# edit_field() accepts its data in a single string which is +# cracked apart before editing and put together afterwards. +# exceeding the size of the field (lnumber) by moving the +# cursor out of it, finishes the editing process. +# +# Annotation: edit_field() doesn't contain anything needed +# by line() and therefore should be removed if only line() +# is to be used. +# +# arguments to the function: +# startline : first line on the screen +# lnumber : number of lines within field +# byte_n : number of bytes permitted within a line +# label : label to be displayed as field's headline +# string : string to be edited + procedure edit_field(startline,lnumber,byte_n,label,string) + + local feld, item, lin, liste, n, res, rest + +# Fail if "editing beyond the end of screen" is tried or byte_n is +# too big + if {(lnumber + startline > 24) | (byte_n > 77)} then { + write("ERROR: ILLEGAL ARGUMENT!") + fail + } + n := 1 +# Initialize feld as a list to contain string's contents + feld := list(lnumber,"") +# Crack apart string into byte_n-byte items. + while lin := string[1:byte_n] do { +# Assign every item's substring upto the last " " to field[n] + feld[n] := lin[1:last(" ",lin)+1] +# Assign the rest to rest + rest := lin[(last(" ",lin)+2):*lin+1] +# Delete the first byte_n bytes, then concatenate rest and string + string[1:byte_n] := "" + string := rest || string + n +:= 1 + } + feld[n] := string +# Display field's contents + n := 1 + locate(startline-1,1) + writes(center(label,(byte_n-5)," ")) + while n <= lnumber do { + locate(startline-1+n,1) + writes(feld[n]) + n +:= 1 + } +# Begin editing process + line_number := 1 + lin_nm := 1 +# Stop if access to non permitted line number (0,>lnumber) is +# tried. + while lin_nm >= 1 & lin_nm <= lnumber do { +# locate(23,40) +# write("ZEILENTYP: ",type(startline)) +# read() + liste := line(startline,byte_n,1,"Ü ",feld[lin_nm]) + feld[lin_nm] := liste[1] + locate(startline,1) + writes(feld[lin_nm],repl(" ",byte_n-*feld[lin_nm]+1)) + startline +:= line_number + lin_nm +:= line_number +# If wrap demanded and the following line is capable to contain +# the wrapped rest of the line before and its original content, +# perform wrap. + if *liste[2] + *feld[lin_nm] <= byte_n then { + feld[lin_nm] := liste[2] || " " || feld[lin_nm] + } + } +# Set flag field_flag to -1/1 to indicate the direction +# in which the field has been quitted. + if lin_nm <= 1 then field_flag := -1 + if lin_nm >= lnumber then field_flag := 1 +# Put the string to be returned together of feld's elements. + res := "" + while item := pop(feld) do { + res := res || " " || item + } + return res +end +# +# show_field: see edit field (except editing routines) for +# details. + procedure show_field(startline,lnumber,byte_n,label,string) + + local feld, lin, n, rest + + if {(lnumber + startline > 24) | (byte_n > 77)} then { + write("ERROR: ILLEGAL ARGUMENT!") + fail + } + n := 1 + feld := list(lnumber,"") + while lin := string[1:byte_n] do { + feld[n] := lin[1:last(" ",lin)+1] + rest := lin[(last(" ",lin)+2):*lin+1] + string[1:byte_n] := "" + string := rest || string + n +:= 1 + } + feld[n] := string + n := 1 + locate(startline-1,1) + writes(center(label,(byte_n-5)," ")) + while n <= lnumber do { + locate(startline-1+n,1) + writes(feld[n]) + n +:= 1 + } +end +# +# edit_item(): function to edit the entry concerning one item +# of literature. This function makes it necessary to declare +# a fixed structure of every item within the function +# "#" separates the fields from each other. it shouldn't be +# contained in the data given to edit_item(). +# +# Structure of an item: +# TITLE +# AUTHOR +# YEAR +# TYPE +# COMMENT1 +# COMMENT2 + procedure edit_item(item) + + local ct, feld, felder, felder2, item2, labels, lin_e, n, zeile + + felder := list() + felder2 := list() + labels := ["AUTHOR","TITLE","YEAR","TYPE","COMMENT1","COMMENT2"] + item ? { + while feld := tab(upto("#")) do { + move(1) + put(felder,feld) + put(felder2,feld) + } + } + zeile := 2 +# Display the fields + n := 1 + while feld := get(felder) do { + show_field(zeile,2,70,labels[n],feld) + n +:= 1 + zeile +:= 4 + } +# Start editing process + ct := 1 + zeile := 2 + while zeile >= 2 & zeile <= 22 do { + felder2[ct] := edit_field(zeile,2,70,labels[ct],trim(felder2[ct])) + ct +:= field_flag + if field_flag = 1 then zeile +:= 4 else zeile -:= 4 + } +# Indicate the direction in which item has been quitted using +# global variable item_flag + if zeile < 2 then item_flag := -1 else item_flag := 1 + item2 := "" +# Format result: item's fields are brought up to a standard length +# of 140 bytes using blanks. + while lin_e := get(felder2) do { + item2 ||:= lin_e || repl(" ",(140 - *lin_e)) || "#" + } + return item2 +end +# +# brightwrite(string): function to highlight a string + procedure brightwrite(string) + + local highl, normal + + highl := char(27) || "[7m" + normal := char(27) || "[0m" + writes(highl,string,normal) +end +# +# findlist(wlist,item): function to return the first +# position of item in wlist. + procedure findlist(wlist,item) + + local n + + n := 1 + while n <= *wlist do { + if wlist[n] == item then return n + n +:= 1 + } + fail +end +# +# menue(header,wlist,klist): function to build up a menuE +# Arguments: header, list of options (wlist) and list of +# shorthand keys (key list). +# because menue() fails if a non defined key (not contained +# in klist, no arrow key), calls to menue() should be made +# within a loop terminated on menue()'s success, see below +# main(). + procedure menue(header,wlist,klist) + + local add, byte, n + + locate(4,10) + writes(header) + n := 5 + while (n - 4) <= *wlist do { + locate(n,10) + writes(wlist[n-4]) + n +:= 1 + } + n := 5 + locate(n,10) + brightwrite(wlist[n-4]) + while byte := getch() & { + byte == (char(21) | char(14)) | findlist(klist,byte) + } + do { +# If byte Is element of klist (shorthandkey) the element number +# within the list + 4 indicates option. + if add := findlist(klist,byte) then { + locate(n,10) + writes(wlist[n-4]) + n := 4 + add + locate(n,10) + brightwrite(wlist[n-4]) + } +# else increase/decrease actual element by one. + else { + if byte == char(14) then add := -1 + if byte == char(21) then add := 1 + locate(n,10) + writes(wlist[n-4]) + n +:= add + if (n - 4) < 1 then n +:= 1 + if (n - 4) > *wlist then n -:= 1 + locate(n,10) + brightwrite(wlist[n-4]) + } + } + if byte == char(13) then return wlist[(n-4)] else fail +end +# +# in_itemm(): function to create new items. Standard file is literat.fil +# The new items are handled as a sequential file which is added to the +# existing file when input process is finished. + procedure in_itemm() + + local answer, count, items, itnum, out_item + + item_flag := 1 + items := list(200,"######") + itnum := 0 + repeat { + itnum +:= item_flag + if itnum < 1 then itnum := 1 + items[itnum] := edit_item(items[itnum]) + writes(char(27),"[2J") + write("NEW ITEM? Yy/Nn!") + answer := getch() + if answer == ("n" | "N") then break + } + count := 1 + out_item := open("literat.fil","a") + while items[count] ~== "######" do { + writes(out_item,items[count]) + count +:= 1 + } + close(out_item) +end +# +# turn_over(): view and edit literat.fil item by item + procedure turn_over() + + local answer, in_item, it, out_item + + in_item := open("literat.fil","r") + out_item := open("literat2.fil","w") + repeat { + it := reads(in_item,846) + it := edit_item(it) + writes(out_item,it) + writes(char(27),"[2J") + write("NEW ITEM? Yy/Nn!") + answer := getch() + if answer == ("n" | "N") then break +# If item_flag is -1 seek -1692 (2 items) to access the beginning of the +# previous item because the internal file pointer points to the end of +# the actual item. + if item_flag == -1 then seek(in_item,where(in_item)-1692) + } + close(in_item) + close(out_item) +end +# +# del(num) remove numth item from filE + procedure del() + + local fil, in_item, itm, n, num, out_item + + writes(char(27),"[2J") + write("NUMBER OF ITEM TO BE REMOVED?") + num := read() + write("READING...") + fil := list() + in_item := open("literat.fil","r") + while itm := reads(in_item,846) do { + put(fil,itm) + } + close(in_item) + write("START OVERWRITE PROCESS...") + n := num + while n < *fil do { + fil[n] := fil[n+1] + n +:= 1 + } + fil[*fil] := "" + out_item := open("literat2.fil","w") + write("WRITING...") + while itm := get(fil) & itm ~== "" do { + writes(out_item,itm) + } + close(out_item) + write("DONE...") +end +# +# alpha: sorting in alphabetical order + procedure alpha() + + local fil, in_item, itm, out_item + + writes(char(27),"[2J") + write("READING...") + fil := list() + in_item := open("literat.fil","r") + while itm := reads(in_item,846) do { + put(fil,itm) + } + close(in_item) + write("ARRANGING DATA IN ALPHABETICAL ORDER...") + fil := sort(fil) + write("WRITING...") + out_item := open("literat2.fil","w") + while itm := get(fil) & itm ~== "" do { + writes(out_item,itm) + } + close(out_item) + write("DONE...") +end +# +# m_adress: function to generate a file with arguments to the seek() +# function. The file (adress.fil) will be used for sequential +# search in the computer's ram, (function (query()). The results enable +# the seek() function to place the internal file pointer on the desired +# item in literat.fil. + procedure m_adress() + + local a, adr, b, in_item, item, m, n, out_adr, out_line, wlist, wlist_2 + + out_line := "" + adr := edit_field(4,10,70,"FORMAT: <WORD>;<WORD>;ETC.","") + writes(char(27),"[2J") + write("GENERATING WORD LIST...") + wlist := list() + n := 1 + adr ? { + while put(wlist,tab(upto(";"))) do { + move(1) + write("ACTUAL WORD: ",wlist[n]) + n +:= 1 + } + } + in_item := open("literat.fil","r") + n := 1 + + wlist_2 := copy(wlist) +# Insert ; between word in wlist_2 and seqence of record numbers +# to be found out later. + while n <= *wlist_2 do { + wlist_2[n] ||:= ";" + n +:= 1 + } + n := 1 + while n <= *wlist do { + write("COMPARING WORD NUMBER: ",n,".") +# counter m: indicates record number + m := 1 + while item := reads(in_item,846) do { + if find(wlist[n],item) then { + wlist_2[n] ||:= m || ";" + } + m +:= 1 + } + wlist_2[n] ? { + a := tab(upto(";")) + b := tab(0) + } + if b == ";" then b := ";0" + wlist_2[n] := a || b + out_line ||:= wlist_2[n] || ":" +# When every item has been compared with wlist[n], move file +# pointer to the beginning of in_item and increase n by 1. + seek(in_item,1) + n +:= 1 + } + close(in_item) +# Remove trailing blank if any + if out_line[1] := " " then { + out_line := out_line[2:(*out_line+1)] + } + write("WRITING ADRESS FILE") + out_adr := open("adress.fil","a") + writes(out_adr,out_line) + close(out_adr) + write("OK") +end +# +# query(): find items using the numbers in adress.fil * 846 as +# arguments to the seek() function + procedure query() + + local byte, in_item, in_line, in_query, it_key, kkey, out_item, word, wrd + + writes(char(27),"[2J") + in_query := open("adress.fil","r") + in_line := read(in_query) + close(in_query) + in_item := open("literat.fil","r") + out_item := open("literat2.fil","a") + wrd := line(10,20,0,"TYPE WORD TO BE LOOKED FOR: ","") + word := wrd[1] + if byte := find(word,in_line) then { + in_line ? { + move(byte) + it_key := tab(upto(":")) + } + } + else { + locate(10,25) + writes("ERROR: UNKNOWN WORD! PRESS KEY!") + getch() + fail + } +# place internal cursor behind the first ; to get the first +# number: + it_key := it_key[find(";",it_key)+1:*it_key+1] + it_key ? { + while kkey := tab(upto(";")) do { + if kkey <= 0 then { + locate(10,25) + writes("ERROR: UNKNOWN WORD! PRESS KEY!") + getch() + fail + } + seek(in_item,(kkey-1)*846) + writes(out_item,edit_item(reads(in_item,846))) + move(1) + } + } + close(in_item) + close(out_item) + write("OK") +end +# +# main program. see the description of the program's functionS +# at the beginning of the source code and of every user-defined +# function if you are in doubt how to use them. +# + procedure main() + + local alist, blist, opt + + newkey() + alist := { + ["iNPUT","tURN OVER ITEMS","aDRESS FILE","qUERY","dEL","AlPHA","eND"] + } + blist := ["i","t","a","q","d","l","e"] + repeat { + repeat { + writes(char(27),"[2J") + locate(1,10) + write("LITERAT: EASY DATABASE SYSTEM") + locate(2,10) + write("WRITTEN BY: MATTHIAS HEESCH 1992") + if opt := menue("MENUE",alist,blist) then break + } + writes(char(27),"[2J") + case opt of { + "iNPUT" : in_itemm() + "tURN OVER ITEMS" : turn_over() + "aDRESS FILE" : m_adress() + "qUERY" : query() + "dEL" : del() + "AlPHA" : alpha() + "eND" : break + } + } +end diff --git a/ipl/progs/ll.icn b/ipl/progs/ll.icn new file mode 100644 index 0000000..df77759 --- /dev/null +++ b/ipl/progs/ll.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: ll.icn +# +# Subject: Program to list shortest and longest lines in a file +# +# Author: Ralph E. Griswold +# +# Date: June 12, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads a file from standard input and writes out the +# lengths of the shortest and longest lines in it. +# +############################################################################ + +procedure main() + local length, max, min + + max := 0 + min := 2 ^ 31 # good enough ... + + while length := *read() do { + max <:= length + min >:= length + } + + write(min) + write(max) + +end diff --git a/ipl/progs/loadmap.icn b/ipl/progs/loadmap.icn new file mode 100644 index 0000000..dfdbd78 --- /dev/null +++ b/ipl/progs/loadmap.icn @@ -0,0 +1,144 @@ +############################################################################ +# +# File: loadmap.icn +# +# Subject: Program to show load map of UNIX object file +# +# Author: Stephen B. Wampler +# +# Date: December 13, 1985 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/longest.icn b/ipl/progs/longest.icn new file mode 100644 index 0000000..444857f --- /dev/null +++ b/ipl/progs/longest.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: longest.icn +# +# Subject: Program to write longest line in a file +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes the (last) longest line in the input file. If the +# command-line option -# is given, the number of the longest line is +# written first. +# +############################################################################ + +procedure main(argl) + local longest, max, count, countl, number, line + + if argl[1] == "-#" then number := 1 + + count := 0 + max := -1 + + every line := !&input do { + count +:= 1 + if *line >= max then { + max := *line + longest := line + countl := count + } + } + + if \number then write(countl) + write(longest) + +end diff --git a/ipl/progs/lower.icn b/ipl/progs/lower.icn new file mode 100644 index 0000000..a1b0674 --- /dev/null +++ b/ipl/progs/lower.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: lower.icn +# +# Subject: Program to map file names to lowercase +# +# Author: Ralph E. Griswold +# +# Date: January 6, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program maps the names of all files in the current directory to +# lowercase. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main() + local input, old, new + + input := open("ls", "p") + + while old := read(input) do { + new := map(old) + if new ~== old then rename(old, new) + } + +end diff --git a/ipl/progs/lssum.icn b/ipl/progs/lssum.icn new file mode 100644 index 0000000..f19d0cc --- /dev/null +++ b/ipl/progs/lssum.icn @@ -0,0 +1,41 @@ +############################################################################ +# +# File: lssum.icn +# +# Subject: Program to sum the file sizes in an ls -l listing +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program summarizes file sizes give by the UNIX ls -l command. +# +# It probably platform dependent. +# +############################################################################ +# +# Requires: Input from UNIX ls -l +# +############################################################################ + +procedure main() + local sum, line + + sum := 0 + + while line := read() do + line ? { + move(30) | next + tab(upto(&digits)) + sum +:= write(tab(many(&digits))) + } + + write(sum) + +end diff --git a/ipl/progs/lsysmap.icn b/ipl/progs/lsysmap.icn new file mode 100644 index 0000000..34f7bfd --- /dev/null +++ b/ipl/progs/lsysmap.icn @@ -0,0 +1,85 @@ +############################################################################ +# +# File: lsysmap.icn +# +# Subject: Program to map L-system symbols +# +# Author: Ralph E. Griswold +# +# Date: June 18, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program maps the symbols in L-Systems. +# +# The following options are supported: +# +# -i s input symbols for mapping; default &ucase +# -o s output symbols for mapping; default &ucase +# -a put symbols for axiom production in alphabetical +# order (ignores -i and -o) +# +# symbol strings are given on the command line, as in +# +# lsysmap -i ABCD -o DCBA <exam.lys +# +# There is little error checking. It's possible to produce an invalid +# L-system by creating duplicate nonterminals or changing metacharacters. +# +# The program handles two-level grammars using the first axiom symbol. +# +############################################################################ +# +# Links: options, strings +# +############################################################################ + +link options +link strings + +procedure main(args) + local isyms, osyms, line, defs, axiom, i, opts, symbols, done + + opts := options(args, "i:s:a") + + if /opts["a"] then { + isyms := \opts["i"] | &ucase + osyms := \opts["o"] | &ucase + if *isyms ~= *osyms then + stop("*** input and output strings not of equal length") + } + + defs := [] + symbols := '' + + while line := read() do { + put(defs, line) + line ? { + if ="axiom:" then { + if not(/axiom := move(1)) then # not first axiom + done := 1 # turn off gathering nontrminals + } + else if =\axiom & ="->" & /isyms then isyms := tab(0) + if /done & find("->") then symbols ++:= move(1) + } + } + + isyms := deletec(isyms, &cset -- symbols) + isyms := ochars(isyms) + osyms := csort(isyms) + + every i := 1 to *defs do { + defs[i] ?:= { + (="axiom:" || map(move(1), isyms, osyms)) | + (find("->") & map(tab(0), isyms, osyms)) | + tab(0) + } + } + + every write(!defs) + +end diff --git a/ipl/progs/maccvt.icn b/ipl/progs/maccvt.icn new file mode 100644 index 0000000..22f6e00 --- /dev/null +++ b/ipl/progs/maccvt.icn @@ -0,0 +1,26 @@ +############################################################################ +# +# File: maccvt.icn +# +# Subject: Program to convert Macintosh special characters to ASCII +# +# Author: Ralph E. Griswold +# +# Date: September 18, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program maps the Macintosh characters for quotation and various +# minus signs into their ASCII equivalents. +# +############################################################################ + +procedure main() + + while write(map(read(), "\xd0\xd1\xd2\xd3\xd4\xd5", "--\"\"''")) + +end diff --git a/ipl/progs/makepuzz.icn b/ipl/progs/makepuzz.icn new file mode 100644 index 0000000..aee48ad --- /dev/null +++ b/ipl/progs/makepuzz.icn @@ -0,0 +1,330 @@ +############################################################################ +# +# File: makepuzz.icn +# +# Subject: Program to make find-the-word puzzle +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +########################################################################### +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.19 +# +########################################################################### +# +# This program doesn't do anything fancy. It simply takes a list +# of words, and constructs out of them one of those square +# find-the-word puzzles that some people like to bend their minds +# over. Usage is: +# +# makepuzz [-f input-file] [-o output-file] [-h puzzle-height] +# -w puzzle-width] [-t how-many-seconds-to-keep-trying] +# [-r maximum-number-of-rejects] [-s] [-d] +# +# where input-file is a file containing words, one to a line +# (defaults to &input), and output-file is the file you would like the +# puzzle written to (defaults to &output). Puzzle-height and width +# are the basic dimensions you want to try to fit your word game into +# (default 20x20). If the -s argument is present, makepuzz will +# scramble its output, by putting random letters in all the blank +# spaces. The -t tells the computer when to give up, and construct +# the puzzle (letting you know if any words didn't make it in). +# Defaults to 60 (i.e. one minute). The -r argument tells makepuzz to +# run until it arrives at a solution with number-of-rejects or less +# un-inserted words. -d turns on certain diagnostic messages. +# +# Most of these options can safely be ignored. Just type +# something like "makepuzz -f wordlist," where wordlist is a file +# containing about sixty words, one word to a line. Out will pop a +# "word-find" puzzle. Once you get the hang of what is going on, +# try out the various options. +# +# The algorithm used here is a combination of random insertions +# and mindless, brute-force iterations through possible insertion +# points and insertion directions. If you don't like makepuzz's per- +# formance on one run, run it again. If your puzzle is large, try +# increasing the timeout value (see -t above). +# +############################################################################ +# +# Links: options, random, colmize +# +############################################################################ + +link options +link random +link colmize + +global height, width, _debug_ + +procedure main(a) + + local usage, opttbl, inputfile, outputfile, maxrejects, puzzle, + wordlist, rejects, master_list, word, timeout, x, y, l_puzzle, + l_wordlist, l_rejects, no_ltrs, l_no_ltrs, try, first_time + + # Filename is the only mandatory argument; they can come in any order. + usage := "makepuzz [-f infile] [-o outfile] [-h height] [-w width] _ + [-t secs] [-r rejects] [-s]" + + # Set up puzzle height and width (default 20x20); set up defaults + # such as the input & output files, time to spend, target reject + # count, etc. + opttbl := options(a, "w+h+f:o:t+sr+d") # stop(usage) + width := \opttbl["w"] | 20 + height := \opttbl["h"] | 20 + timeout := &time + (1000 * (\opttbl["t"] | 60)) + inputfile := open(\opttbl["f"], "r") | &input + outputfile := open(\opttbl["o"], "w") | &output + maxrejects := \opttbl["r"] | 0 + _debug_ := \opttbl["d"] & try := 0 + first_time := 1 + + # Set random number seed. + randomize() + + # Read, check, and sort word list hardest to easiest. + master_list := list() + every word := "" ~== trim(map(!inputfile)) do { + upto(~(&lcase++&ucase), word) & + stop("makepuzz: non-letter found in ", word) + write(&errout, "makepuzz: warning, ",3 > *word, + "-letter word (", word, ")") + put(master_list, word) + } + master_list := sort_words(master_list) + if \_debug_ then write(&errout, "makepuzz: thinking...") + + # Now, try to insert the words in the master list into a puzzle. + # Stop when the timeout limit is reached (see -t above). + until &time > timeout & /first_time do { + + first_time := &null + wordlist := copy(master_list); rejects := list() + puzzle := list(height); every !puzzle := list(width) + blind_luck_insert(puzzle, wordlist, rejects) + brute_force_insert(puzzle, wordlist, rejects, timeout) + + # Count the number of letters left over. + no_ltrs := 0; every no_ltrs +:= *(!wordlist | !rejects) + l_no_ltrs := 0; every l_no_ltrs +:= *(!\l_wordlist | !\l_rejects) + # If our last best try at making a puzzle was worse... + if /l_puzzle | + (*\l_wordlist + *l_rejects) > (*wordlist + *rejects) | + ((*\l_wordlist + *l_rejects) = (*wordlist + *rejects) & + l_no_ltrs > no_ltrs) + then { + # ...then save the current (better) one. + l_puzzle := puzzle + l_wordlist := wordlist + l_rejects := rejects + } + + # Tell the user how we're doing. + if \_debug_ then + write(&errout, "makepuzz: try number ", try +:= 1, "; ", + *wordlist + *rejects, " rejects") + + # See the -r argument above. Stop if we get to a number of + # rejects deemed acceptable to the user. + if (*\l_wordlist + *l_rejects) <= maxrejects then break + } + + # Signal to user that we're done, and set puzzle, wordlist, and + # rejects to their best values in this run of makepuzz. + write(&errout, "makepuzz: done") + puzzle := \l_puzzle + wordlist := \l_wordlist + rejects := \l_rejects + + # Print out original word list, and list of words that didn't make + # it into the puzzle. + write(outputfile, "Original word list (sorted hardest-to-easiest): \n") + every write(outputfile, colmize(master_list)) + write(outputfile, "") + if *rejects + *wordlist > 0 then { + write(outputfile, "Couldn't insert the following words: \n") + every write(outputfile, colmize(wordlist ||| rejects)) + write(outputfile, "") + } + + # Scramble (i.e. put in letters for remaining spaces) if the user + # put -s on the command line. + if \opttbl["s"] then { + every y := !puzzle do + every x := 1 to *y do + /y[x] := ?&ucase + + # Print out puzzle structure (answers in lowercase). + every y := !puzzle do { + every x := !y do + writes(outputfile, \x | " ", " ") + write(outputfile, "") + } + write(outputfile, "") + } + + # Print out puzzle structure, all lowercase. + every y := !puzzle do { + every x := !y do + writes(outputfile, map(\x) | " ", " ") + write(outputfile, "") + } + + # Exit with default OK status for this system. + every close(inputfile | outputfile) + exit() + +end + + +procedure sort_words(wordlist) + + local t, t2, word, sum, l + + # Obtain a rough character count. + t := table(0) + every t[!!wordlist] +:= 1 + t2 := table() + + # Obtain weighted values for each word, essentially giving longer + # words and words with uncommon letters the highest values. Later + # we'll reverse the order (-> hardest-to-easiest), and return a list. + every word := !wordlist do { + "" == word & next + sum := 0 + every sum +:= t[!word] + insert(t2, word, (sum / *word) - (2 * *word)) + } + t2 := sort(t2, 4) + l := list() + + # Put the hardest words first. These will get laid down when the + # puzzle is relatively empty. Save the small, easy words for last. + every put(l, t2[1 to *t2-1 by 2]) + return l + +end + + +procedure blind_luck_insert(puzzle, wordlist, rejects) + + local s, s2, s3, begy, begx, y, x, diry, dirx, diry2, dirx2, i + # global height, width + + # Try using blind luck to make as many insertions as possible. + while s := get(wordlist) do { + + # First try squares with letters already on them, but don't + # try every direction yet (we're relying on luck just now). + # Start at a random spot in the puzzle, and wrap around. + begy := ?height; begx := ?width + every y := (begy to height) | (1 to begy - 1) do { + every x := (begx to width) | (1 to begx - 1) do { + every i := find(\puzzle[y][x], s) do { + diry := ?3; dirx := ?3 + s2 := s[i:0] + diry2 := 4 > (diry + 2) | 0 < (diry - 2) | 2 + dirx2 := 4 > (dirx + 2) | 0 < (dirx - 2) | 2 + s3 := reverse(s[1:i+1]) + if insert_word(puzzle, s2, diry, dirx, y, x) & + insert_word(puzzle, s3, diry2, dirx2, y, x) + then break { break break next } + } + } + } + + # If the above didn't work, give up on spaces with characters + # in them; use blank squares as well. + every 1 to 512 do + if insert_word(puzzle, s, ?3, ?3, ?height, ?width) then + break next + # If this word doesn't submit to easy insertion, save it for + # later. + put(rejects, s) + } + + # Nothing useful to return (puzzle, wordlist, and rejects objects + # are themselves modified; not copies of them). + return + +end + + +procedure brute_force_insert(puzzle, wordlist, rejects, timeout) + + local s, start, dirs, begy, begx, y, x + + # Use brute force on the remaining forms. + if *rejects > 0 then { + wordlist |||:= rejects; rejects := [] + while s := pop(wordlist) do { + start := ?3; dirs := "" + every dirs ||:= ((start to 3) | (1 to start-1)) + begy := ?height; begx := ?width + every y := (begy to height) | (1 to begy - 1) do { + if &time > timeout then fail + every x := (begx to width) | (1 to begx - 1) do { + if insert_word(puzzle, s, !dirs, !dirs, y, x) then + break { break next } + } + } + # If we can't find a place for s, put it in the rejects list. + put(rejects, s) + } + } + + # Nothing useful to return (puzzle, wordlist, and rejects objects + # are themselves modified; not copies of them). + return + +end + + +procedure insert_word(puzzle, s, ydir, xdir, y, x) + + local incry, incrx, firstchar + + # If s is zero length, we've matched it in it's entirety! + if *s = 0 then { + return + + } else { + + # Make sure there's enough space in the puzzle in the direction + # we're headed. + case ydir of { + "3": if (height - y) < (*s - 1) then fail + "1": if y < (*s - 1) then fail + } + case xdir of { + "3": if (width - x) < (*s - 1) then fail + "1": if x < (*s - 1) then fail + } + + # Check to be sure everything's in range, and that both the x and + # y increments aren't zero (in which case, we aren't headed in any + # direction at all...). + incry := (ydir - 2); incrx := (xdir - 2) + if incry = 0 & incrx = 0 then fail + height >= y >= 1 | fail + width >= x >= 1 | fail + + # Try laying the first char in s down at puzzle[y][x]. If it + # works, head off in some direction, and try laying down the rest + # of s along that vector. If at any point we fail, we must + # reverse the assignment (<- below). + firstchar := !s + ((/puzzle[y][x] <- firstchar) | (\puzzle[y][x] == firstchar)) & + insert_word(puzzle, s[2:0], ydir, xdir, y + incry, x + incrx) & + suspend + fail + } + +end diff --git a/ipl/progs/mapcolrs.icn b/ipl/progs/mapcolrs.icn new file mode 100644 index 0000000..833f77d --- /dev/null +++ b/ipl/progs/mapcolrs.icn @@ -0,0 +1,57 @@ +############################################################################ +# +# File: mapcolrs.icn +# +# Subject: Program to map colors in lists +# +# Author: Ralph E. Griswold +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program maps colors in lists. +# +# This is a work in progress. +# +############################################################################ +# +# Links: io, ximage +# +############################################################################ + +link io +link ximage + +procedure main(args) + local in_list, to_list, infile, tofile, colors, map, i + + in_list := args[1] | stop("*** no input list specified") + to_list := args[2] | stop("*** no map list specified") + + infile := dopen(in_list) | stop("*** cannot open ", in_list) + tofile := dopen(to_list) | stop("*** cannot open ", to_list) + + in_list := [] + write(read(infile)) # header + while put(in_list, read(infile)) + to_list := [] + while put(to_list, read(tofile)) + + colors := table(0) + every colors[!in_list] +:= 1 + colors := sort(colors, 4) + map := table() + every i := 1 to *colors / 2 do { + pull(colors) + map[pull(colors)] := i + } + + xdump(colors) + xdump(map) + +end diff --git a/ipl/progs/midisig.icn b/ipl/progs/midisig.icn new file mode 100644 index 0000000..8aee48d --- /dev/null +++ b/ipl/progs/midisig.icn @@ -0,0 +1,140 @@ +############################################################################ +# +# File: midisig.icn +# +# Subject: Program to show signature of a MIDI file +# +# Author: Ralph E. Griswold +# +# Date: August 17, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program displays the signature of a MIDI file. +# +############################################################################ +# +# Links: bincvt, convert +# +############################################################################ + +link bincvt +link convert + +procedure main() + local rest, track, tracks, width, track_segs, seg, byte, bytes, code + local meta_event, event, command, channel + + event := table() + + event["8"] := "note off" + event["9"] := "note on" + event["a"] := "key after-touch" + event["b"] := "control change" + event["c"] := "program change" + event["d"] := "channel after-touch" + event["e"] := "pitch wheel change" + event["f"] := "SysEx event" + + meta_event := table() + + meta_event["\x00"] := "track sequence number" + meta_event["\x01"] := "text" + meta_event["\x02"] := "copyright" + meta_event["\x03"] := "sequence or track name" + meta_event["\x04"] := "track instrument name" + meta_event["\x05"] := "lyric" + meta_event["\x06"] := "marker" + meta_event["\x07"] := "cue point" + meta_event["\x20"] := "channel marker" + meta_event["\x2f"] := "end of track" + meta_event["\x51"] := "tempo" + meta_event["\x54"] := "SMPTE offset" + meta_event["\x58"] := "time signature" + meta_event["\x59"] := "key signature" + meta_event["\x07"] := "sequencer-specific information" + + track_segs := [] + + reads(, 100000) ? { + ="MThd" | stop("*** invalid header") + (unsigned(move(4)) = 6) | stop("*** invalid size") + write( + case unsigned(move(2)) of { + 0 : "single track" + 1 : "multi-track, synchronous" + 2 : "multi-track, asynchronous" + default : stop("*** invalid track information") + } | stop("*** invalid track information") + ) + write(tracks := unsigned(move(2)), " tracks") | + stop("*** invalid track number information") + write(unsigned(move(2)), " delta-ticks per quarter note") | + stop("*** invalid delta-tick information") + width := *tracks + 1 + every track := 1 to tracks do { + ="MTrk" | { + write(&errout, "*** short file") + break + } + rest := unsigned(move(4)) + put(track_segs, move(rest)) + } + } + + track := 0 + + while seg := get(track_segs) do { + write() + track +:= 1 + write("track", right(track, width), ": ", *seg, " bytes") + seg ? { + write("delta-time: ", get_time()) | stop("*** invalid delta-time") + byte := move(1) + if byte == "\xff" then { + write( + "meta-event: ", + \meta_event[code := move(1)] | + ("unknown code " || image(code)) + ) + bytes := unsigned(move(1)) + if 1 <= unsigned(code) <= 7 then write(" ", move(bytes)) + } + else { # event + byte := exbase10(ord(byte), 16) + write( + "event: ", + \event[byte[1]] | ("unknown command " || image(byte[1])), + ", channel ", + byte[2] + ) + } + next # THE NEXT THING TO DO IS GET DATA BYTES + } # AND LOOP + } + +end + +# Decode delta-time. + +procedure get_time() + local delta, byte + + delta := "" + + while byte := move(1) do { + if ord(byte) >= 128 then delta ||:= char(ord(byte) - 128) + else { + delta ||:= byte + return unsigned(delta) + } + } + + fail # short data + +end + diff --git a/ipl/progs/missile.icn b/ipl/progs/missile.icn new file mode 100644 index 0000000..4b4fdaa --- /dev/null +++ b/ipl/progs/missile.icn @@ -0,0 +1,331 @@ +############################################################################ +# +# File: missile.icn +# +# Subject: Program to play missile command game +# +# Author: Chris Tenaglia +# +# Date: June 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Here is a cheap attempt at a Missile Command game. +# +# I've run it under Icon V8.7 under VMS, Unix, and V8.5 under MS-DOS. +# +# Here are some things you'll need to know. There is a delay() procedure +# that keeps the game running at a steady pace. delay() is built into +# V8.7 on VMS and unix. Under DOS you'll need to roll your own. +# The program also uses ansi escape sequences. Also to play use 7, 8, and 9 +# to launch a # missile. 7 is leftward, 8 is straight, and 9 is right. A bug +# in the Ultrix version (kbhit() and getch()) requires double pressing the +# buttons. I think q will quit the game early. +# +# Have Fun! +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +global bonus, # bonus missile threshhold + score, # number of missiles shot down + munitions, # munitions supply (# of defensive missiles) + missilef, # whether enemy missile is launched flag + missilex, # x position of enemy missile + missiley, # y position of enemy missile + incm, # x increment of enemy missile + abmf, # whether defensive missile fired flag + abmx, # x position of defensive missile + abmy, # y position of defensive missile + abmix # x increment of defensive missle + +procedure main() + infrastructure() # set up defaults, globals, and munitions + banner() # output initial banner + repeat + { + draw_base() # initially draw base + repeat + { + enemy_launch() # possible enemy attack + friendly_fire() # possible defensive attack + animate() # draw action if any + sense_status() # sense status + delay(1000) # pace the game + } + } + stop("\7\e[0m",at(12,24),"Game Over. \e[5mInsert another quarter.\e[0m\e[?25h\e=") + end + +# +# set up all the initial defaults +# +procedure infrastructure() + bonus := 22 + missilef := 0 + missilex := 0 + missiley := 0 + incm := 0 + abmf := 0 + abmx := 0 + abmy := 0 + score := 0 + randomize() + munitions:= 10 + ?5 + end + +# +# draw the initial environment +# +procedure draw_base() + write("\e[?25l\e>\e[?5l\e[0;1;33;44m\e[2J\e[H S.D.I. OUTPOST [TACTICAL SITUATION DISPLAY]") + writes(at(23,1),repl("#",79)) + writes(at(24,1),repl("=",79)) + writes(at(24,39),"/ \\",at(23,40),"^") + writes(at(24,5)," Missiles Left : ",munitions," ") + writes(at(24,60)," Score : ",score," ") + end + +# +# check and occasionally launch a missile +# +procedure enemy_launch() + (?50 = 33) | fail + if missilef = 1 then fail + missilex := 1 + missiley := 1 + ?10 + missilef := 1 + incm := ?3 + end + +# +# coordinate launch of defensive missiles +# +procedure friendly_fire() + local ambf, press + + kbhit() | fail + press := getch() + if abmf = 1 then + { + case press of + { + "1" | "4" | "7" | "l" | "L" : abmix := -2 + "2" | "5" | "8" | "s" | "S" : abmix := 0 + "3" | "6" | "9" | "r" | "R" : abmix := 2 + "q" | "Q" | "\e" : stop("\e[2J\e[H") + default : writes("\7") + } + } else { + ambf := 1 + abmx := 40 + abmy := 22 + case press of + { + "1" | "4" | "7" | "l" | "L" : abmix := -2 + "2" | "5" | "8" | "s" | "S" : abmix := 0 + "3" | "6" | "9" | "r" | "R" : abmix := 2 + "q" | "Q" | "\e": stop("\e[2J\e[H",at(12,24),"Game Over. \e[5mInsert another quarter.\e[0m\e[?25h\e=") + default : { + writes("\7") + fail + } + } + if munitions <= 0 then + stop(at(12,24),"Game Over. \e[5mInsert Another Quarter!\e[0m\e=\e[?25h") + munitions -:= 1 + abmf := 1 + writes(at(24,5)," Missiles Left : ",munitions," ") + } + end + +# +# fly the missiles +# +procedure animate() + local old_missilez + + static old_abmx, + old_abmy, + old_missilex, + old_missiley + + initial { + old_abmx := 0 + old_abmy := 0 + old_missilez := 0 + old_missiley := 0 + } + + # + # move the defensive missile if launched + # + if abmf = 1 then + { + writes(at(abmy,abmx),"*",at(old_abmy,old_abmx)," ") + old_abmx := abmx + old_abmy := abmy + abmx +:= abmix + abmy -:= 1 + if abmy < 2 then + { + writes(at(old_abmy,old_abmx)," ") + abmf := 0 + abmx := 0 + abmy := 0 + } + } + + # + # move the offensive missile if launched + # + if missilef = 1 then + { + writes(at(missiley,missilex)," =>") + missilex +:= incm + if missilex > 76 then + { + writes(at(missiley,76),"\e[K") + missilef := 0 + missilex := 0 + missiley := 0 + incm := 0 + } + } + end + +# +# sense for hits and handle explosions +# +procedure sense_status() + local j + static junk + initial junk := ["=%!*@", + "%^&(!", + "(@^$^", + "*)@%$", + "@&%^(#"] + if missilef=1 & abmf=1 then + { + if abmy=missiley & (missilex < abmx < missilex+6) then + { + every 1 to 3 do + { + writes(at(abmy,abmx-4),"\e[?5h<<<<>>>>") ; delay(2000) # reverse screen + writes(at(abmy,abmx-4),"\e[?5l>>>><<<<") ; delay(2000) # normal screen + } + every j := abmy to 22 do + { + writes(at(j,abmx-3),?junk) + delay(1000) + } + if abmx > 67 then abmx := 67 # handle edge of screen problem + writes(at(23,abmx-3),"********") ; delay(1000) + writes(at(22,abmx-3),"\e[?5h||||||||") ; delay(1000) + writes(at(21,abmx-5),"\e[?5l. . . . . . .") ; delay(1000) + every j := 20 to abmy by -1 do writes(at(j,abmx-6),"\e[K") + wait(2) + score +:= incm * (15 - missiley) + if score > bonus then + { + writes(at(12,30),"\7\e[5mBONUS MISSILE EARNED!\e[0m") + bonus +:= 33 + munitions +:= 1 + delay(30000) + } + draw_base() + abmf := 0 + abmx := 0 + abmy := 0 + missilef := 0 + missilex := 0 + missiley := 0 + } + } + end + +# +# output initial banner for this game +# +procedure banner() + write("\e[0;1;33;44m\e[2J\e[H ") + write(" ") + write("###############################################################################") + write(" ") + write(" *** * * ***** **** *** **** ***** ") + write(" * * * * * * * * * * * ") + write(" * * * * * **** * * *** * ") + write(" * * * * * * * * * * ") + write(" *** *** * * *** **** * ") + write(" ") + write(" **** **** *** ") + write(" * * * * ") + write(" **** * * * ") + write(" * * * * ") + write(" **** ** **** ** *** ** ") + write(" ") + write(" ") + write("###############################################################################") + wait(3) + end + +# +# move cursor to specified screen position +# +procedure at(row,column) + return "\e[" || row || ";" || column || "f" + end + +# +# procedure to wait n seconds +# +procedure wait(n) + delay(n * 10000) + return +## secs := &clock[-2:0] + n +## if secs > 58 then secs -:= 60 +## repeat +## { +## now := &clock[-2:0] +## if now > secs then break +## } +## return + end + +############################################################################ +# # +# This procedure pulls all the elements (tokens) out of a line # +# buffer and returns them in a list. a variable named 'chars' # +# can be statically defined here or global. It is a cset that # +# contains the valid characters that can compose the elements # +# one wishes to extract. # +# # +############################################################################ +procedure parse(line,delims) + local tokens + static chars + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end + +############################################################################ +# # +# This procedure is terribly handy in prompting and getting # +# an input string # +# # +############################################################################ +procedure input(prompt) + writes(prompt) + return read() + end diff --git a/ipl/progs/miu.icn b/ipl/progs/miu.icn new file mode 100644 index 0000000..627629e --- /dev/null +++ b/ipl/progs/miu.icn @@ -0,0 +1,80 @@ +############################################################################ +# +# File: miu.icn +# +# Subject: Program to generate strings from MIU system +# +# Author: Cary A. Coutant, modified by Ralph E. Griswold +# +# Date: January 3, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 + + limit := integer(arg[1]) | 7 + gen := set(["MI"]) + + every count := 1 to limit do { + gen := nextgen(gen) + show(count,gen) + } + +end + +# show - show a generation of strings + +procedure show(count,gen) + + write("Generation #",count,", ",*gen," strings") + every write(" ",image(!sort(gen))) + write() + +end + +# nextgen - given a generation of strings, compute the next generation + +procedure nextgen(gen) + local new + + new := set() + every insert(new,apply(!gen)) + return new + +end + +# apply - produce all strings derivable from s in a single rule application + +procedure apply(s) + +# Here's a case where referring to the subject by name inside scanning +# is justified. + + s ? { + if ="M" then suspend s || tab(0) + tab(-1) # to last character + if ="I" then suspend s || "U" + tab(1) # back to the beginning + suspend tab(find("III")) || (move(3) & "U") || tab(0) + tab(1) # back to the beginning + suspend tab(find("UU")) || (move(2) & tab(0)) + } + +end diff --git a/ipl/progs/mkpasswd.icn b/ipl/progs/mkpasswd.icn new file mode 100644 index 0000000..5c8d251 --- /dev/null +++ b/ipl/progs/mkpasswd.icn @@ -0,0 +1,49 @@ +############################################################################ +# +# File: mkpasswd.icn +# +# Subject: Program to make passwords +# +# Author: Jere K{pyaho +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program creates a list of randomly generated passwords. +# +# Passwords consist of eight random characters [A-Z][0-9]. +# +# Number of passwords to generate is given as the first argument; default 1. +# +############################################################################ + +procedure main(Args) + local count, i + + count := integer(Args[1]) | 1 + + every i := 1 to count do + write( genpasswd() ) + +end + +# +# genpasswd: generate and return an 8-character password +# +procedure genpasswd() + + local i, s, ucalnum + + s := "" + ucalnum := &ucase ++ &digits + every i := 1 to 8 do + s := s || ?ucalnum + + return s + +end diff --git a/ipl/progs/monkeys.icn b/ipl/progs/monkeys.icn new file mode 100644 index 0000000..6f07690 --- /dev/null +++ b/ipl/progs/monkeys.icn @@ -0,0 +1,78 @@ +############################################################################ +# +# File: monkeys.icn +# +# Subject: Program to generate random text +# +# Author: Stephen B. Wampler +# +# Date: September 7, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Ralph E. Griswold and Alan Beale +# +############################################################################ +# +# 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 + &random := \switches["r"] + + 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 diff --git a/ipl/progs/morse.icn b/ipl/progs/morse.icn new file mode 100644 index 0000000..dbfcaa7 --- /dev/null +++ b/ipl/progs/morse.icn @@ -0,0 +1,99 @@ +############################################################################ +# +# File: morse.icn +# +# Subject: Program to convert string to Morse code +# +# Authors: Ralph E. Griswold and Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# If "morse" is invoked without arguments, a Morse code table is +# printed. If words are entered as arguments, the Morse code +# conversion is printed in dots and dashes. If the first character of +# the first argument is a dot or dash, the arguments are takes as Morse +# code and converted to a string. +# +############################################################################ +# +# Links: colmize +# +############################################################################ + +link colmize + +procedure main(arg) + local lst, c, s + if *arg = 0 then { + lst := [] + every c := !(&ucase || " " || &digits) do { + put(lst,c || " " || morse(c)) + } + every write(colmize(lst)) + } + else { + s := "" + every s ||:= !arg || " " + s := trim(s) + write((if any('.-',s) then unmorse else morse)(s)) + } +end + + +############################################################################ +# +# This procedure converts the string s to its Morse code equivalent. +# +############################################################################ + +procedure morse(s) + local i, t, c, x + static morsemeander, morseindex + + initial { + morsemeander := + "....------.----..---.-.---...--.--.-..--..-.--....-.-.-...-..-....." + morseindex := + "TMOT09TTT1T8TT2GQTTTJTZ7T3NKYTTCTTTTDXTTWPTB64EARTTLTVTIUFTSH5" + } + + x := "" + every c := !map(s,&lcase,&ucase) do + if not(i := find(c,morseindex)) then x ||:= " " + else { + t := morsemeander[i+:6] + x ||:= t[find("-",t)+1:0] || " " + } + return x +end + + +############################################################################ +# +# This procedure converts Morse code string s to its character string +# equivalent. +# +############################################################################ + +procedure unmorse(s) + local x, t, c + x := "" + s ? { + until pos(0) do { + tab(many(' \t')) + t := tab(upto(' \t') | 0) + if t == "" then next + x ||:= (every c := !(&ucase || &digits) do { + if trim(morse(c)) == t then break c + }) | "?" + } + } + return x +end + diff --git a/ipl/progs/mr.icn b/ipl/progs/mr.icn new file mode 100644 index 0000000..0d7f49f --- /dev/null +++ b/ipl/progs/mr.icn @@ -0,0 +1,429 @@ +############################################################################ +# +# File: mr.icn +# +# Subject: Program to read mail +# +# Author: Ronald Florence +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.4 +# +############################################################################ +# +# With no arguments, mr reads the default mail spool. Another user, +# a spool file, or the recipient for outgoing mail can be given as +# a command line argument. Help, including the symbols used to +# indicate the status of mail, is available with the H command. +# +# Usage: mr [recipient] [-u user] [-f spool] +# +# Configuration: +# +# Editor for replies or new mail. +# Host optional upstream routing address for outgoing mail; +# a domained Host is appended to the address, a uucp +# Host prefixes the address. +# Mail_cmd the system mailer (usually sendmail, smail, or mail). +# print_cmd command to format and/or spool material for the printer +# (for OS with pipes). &null for ms-dos. +# ignore a list of headers to hide when paging messages. The V +# command views hidden headers. +# +# Non-UNIX systems only: +# +# non_unix_mailspool full path of the default mailspool. +# +############################################################################ +# +# Links: iolib, options, io +# +############################################################################ + +link iolib, options, io + +global Host, Editor, Spool, Status, Mail_cmd + +procedure main(arg) + local i, opts, cmd, art, mailspool, print_cmd, ignore, non_unix_mailspool + + # configuration + Editor := "vi" + Host := &null + Mail_cmd := "/usr/lib/sendmail -t" + print_cmd := "mp -F | lpr" + ignore := ["From ", "Message-Id", "Received", "Return-path", "\tid", + "Path", "Xref", "References", "X-mailer", "Errors-to", + "Resent-Message-Id", "Status", "X-lines", "X-VM-Attributes"] + non_unix_mailspool := &null + + # end of configuration + + if not "UNIX" == &features then + mailspool := getenv("MAILSPOOL") | \non_unix_mailspool | "DUNNO" + opts := options(arg, "u:f:h?") + \opts["h"] | \opts["?"] | arg[1] == "?" & + stop("usage: mr [recipient] [-f spoolfile] [-u user]") + \arg[1] & { write(); newmail(arg[1]); exit(0) } + /mailspool := "/usr/spool/mail/" || (\opts["u"] | getenv("LOGNAME"|"USER")) + \opts["f"] & mailspool := opts["f"] + i := readin(mailspool) + headers(mailspool, i) + repeat { + cmd := query("\n[" || i || "/" || *Status || "]: ", " ") + if integer(cmd) & (cmd > 0) & (cmd <= *Status) then + headers(mailspool, i := cmd) + else case map(!cmd) of { + " ": { showart(i, ignore); i := inc(i) } + "a": save(query("Append to: "), i, "append") + "d": { Status[i] ++:= 'D'; clear_line(); i := inc(i) } + "f": forward(query("Forward to: "), i) + "g": readin(mailspool, "update") & headers(mailspool, i) + "l": headers(mailspool, i) + "m": newmail(query("Address: ")) + "p": print(print_cmd, i) + "q": quit(mailspool) + "r": reply(i) + "s": save(query("Filename: "), i) + "u": { Status[i] --:= 'D'; clear_line(); i := inc(i) } + "v": showart(i, ignore, "all") + "x": upto('yY', query("Are you sure? ")) & exit(1) + "|": pipeto(query("Command: "), i) + "!": { system(query("Command: ")) + write() & query("Press <return> to continue") } + "-": { if (i -:= 1) = 0 then i := *Status; showart(i, ignore) } + "+"|"n": showart(i := inc(i), ignore) + "?"|"h": help() + default: clear_line() & writes("\^g") + } + } +end + + # Read the mail spool into a list of + # lists and set up a status list. +procedure readin(spoolname, update) + local sf, i, article + + Spool := [] + \update | Status := [] + sf := open(spoolname) | stop("Can't read " || spoolname) + i := 0 + every !sf ? { + ="From " & { + ((i +:= 1) > 1) & put(Spool, article) + article := [] + (i > *Status) & put(Status, 'N') + } + (i > 0) & put(article, &subject) + } + (i > 0) & { + put(Spool, article) + i := 1 + } + close(sf) + return i +end + + # Parse messages for author & subject, + # highlight the current message. +procedure headers(spoolname, art) + local hlist, i, entry, author, subj + + hlist := [] + every i := 1 to *Status do { + entry := if i = art then getval("md"|"so") else "" + entry ||:= left(i, 3, " ") || left(Status[i], 4, " ") + author := "" + subj := "" + while (*author = 0) | (*subj = 0) do !Spool[i] ? { + ="From: " & author := tab(0) + ="Subject: " & subj := tab(0) + (*&subject = 0) & break + } + entry ||:= " [" || right(*Spool[i], 3, " ") || ":" + entry ||:= left(author, 17, " ") || "] " || left(subj, 45, " ") + (i = art) & entry ||:= getval("me"|"se") + put(hlist, entry) + } + put(hlist, "") + more(spoolname, hlist) +end + + # Check if any messages are deleted; + # if the spool cannot be written, + # write a temporary spool. Rename + # would be convenient, but won't work + # across file systems. +procedure quit(spoolname) + local msave, f, tfn, i + + every !Status ? { find("D") & break msave := 1 } + \msave & { + readin(spoolname, "update") + (f := open(spoolname, "w")) | { + f := open(tfn := tempname(), "w") + write("Cannot write " || spoolname || ". Saving changes to " || tfn) + } + every i := 1 to *Status do { + find("D", Status[i]) | every write(f, !Spool[i]) + } + } + exit(0) +end + + +procedure save(where, art, append) + local mode, outf + + mode := if \append then "a" else "w" + outf := open(where, mode) | { write("Can't write ", where) & fail } + every write(outf, !Spool[art]) + Status[art] ++:= 'S' + return close(outf) +end + + +procedure pipeto(cmd, art) + static real_pipes + local p, tfn, status + + initial real_pipes := "pipes" == &features + p := (\real_pipes & open(cmd, "wp")) | open(tfn := tempname(), "w") + every write(p, !Spool[art]) + if \real_pipes then return close(p) + else { + cmd ||:= " < " || tfn + status := system(cmd) + remove(tfn) + return status + } +end + + +procedure print(cmd, art) + local p, status + + if \cmd then status := pipeto(cmd, art) + else if not "MS-DOS" == &features then + return write("Sorry, not configured to print messages.") + else { + p := open("PRN", "w") + every write (p, !Spool[art]) + status := close(p) + } + \status & { Status[art] ++:= 'P'; clear_line() } +end + + + # Lots of case-insensitive parsing. +procedure reply(art) + local tfn, fullname, address, quoter, date, id, subject, newsgroup, refs, r + + r := open(tfn := tempname(), "w") + every !Spool[art] ? { + tab(match("from: " | "reply-to: ", map(&subject))) & { + if find("<") then { + fullname := tab(upto('<')) + address := (move(1), tab(find(">"))) + } + else { + address := trim(tab(upto('(') | 0)) + fullname := (move(1), tab(find(")"))) + } + while match(" ", \fullname, *fullname) do fullname ?:= tab(-1) + quoter := if *\fullname > 0 then fullname else address + } + tab(match("date: ", map(&subject))) & date := tab(0) + tab(match("message-id: ", map(&subject))) & id := tab(0) + match("subject: ", map(&subject)) & subject := tab(0) + match("newsgroups: ", map(&subject)) & newsgroup := tab(upto(',') | 0) + match("references: ", map(&subject)) & refs := tab(0) + (\address & *&subject = 0) & { + writes(r, "To: " || address) + write(r, if *\fullname > 0 then " (" || fullname || ")" else "") + \subject & write(r, subject) + \newsgroup & write(r, newsgroup) + \refs & write(r, refs, " ", id) + write(r, "In-reply-to: ", quoter, "'s message of ", date); + write(r, "\nIn ", id, ", ", quoter, " writes:\n") + break + } + } + every write(r, " > ", !Spool[art]) + send(tfn, address) & { + Status[art] ++:= 'RO' + Status[art] --:= 'N' + } +end + + # Put user in an editor with a temp + # file, query for confirmation, if + # necessary rewrite address, and send. +procedure send(what, where) + local edstr, mailstr, done + static console + + initial { + if "UNIX" == &features then console := "/dev/tty" + else if "MS-DOS" == &features then console := "CON" + else stop("Please configure `console' in mr.icn.") + } + edstr := (getenv("EDITOR") | Editor) || " " || what || " < " || console + system(edstr) + upto('nN', query( "Send to " || where || " y/n? ")) & { + if upto('yY', query("Save your draft y/n? ")) then + clear_line() & write("Your draft is saved in " || what || "\n") + else clear_line() & remove(what) + fail + } + clear_line() + \Host & not find(map(Host), map(where)) & upto('!@', where) & { + find("@", where) & where ? { + name := tab(upto('@')) + where := (move(1), tab(upto(' ') | 0)) || "!" || name + } + if find(".", Host) then where ||:= "@" || Host + else where := Host || "!" || where + } + mailstr := Mail_cmd || " " || where || " < " || what + done := system(mailstr) + remove(what) + return done +end + + +procedure forward(who, art) + local out, tfn + + out := open(tfn := tempname(), "w") + write(out, "To: " || who) + write(out, "Subject: FYI (forwarded mail)\n") + write(out, "-----[begin forwarded message]-----") + every write(out, !Spool[art]) + write(out, "------[end forwarded message]------") + send(tfn, who) & Status[art] ++:= 'F' +end + + +procedure newmail(address) + local out, tfn + + out := open(tfn := tempname(), "w") + write(out, "To: " || address) + write(out, "Subject:\n") + return send(tfn, address) +end + + +procedure showart(art, noshow, eoh) + local out + + out := [] + every !Spool[art] ? { + /eoh := *&subject = 0 + if \eoh | not match(map(!noshow), map(&subject)) then put(out, tab(0)) + } + more("Message " || art, out, "End of Message " || art) + Status[art] ++:= 'O' + Status[art] --:= 'N' +end + + +procedure help() + local hlist, item + static pr, sts + + initial { + pr := ["Append message to a file", + "Delete message", + "eXit, without saving changes", + "Forward message", + "Get new mail", + "Help", + "List headers", + "Mail to a new recipient", + "Next message", + "Print message", + "Quit, saving changes", + "Reply to message", + "Save message", + "Undelete message", + "View all headers", + "| pipe message to a command", + "+ next message", + "- previous message", + "! execute command", + "# make # current message", + " "] + sts := ["New", "Old", "Replied-to", "Saved", + "Deleted", "Forwarded", "Printed"] + } + hlist := [] + every !(pr ||| sts) ? { + item := " " + item ||:= tab(upto(&ucase++'!|+-#') \1) || getval("md"|"so") || + move(1) || getval("me"|"se") || tab(0) + put(hlist, item) + } + put(hlist, "") + more("Commands & Status Symbols", hlist) +end + + # The second parameter specifies a + # default response if the user presses + # <return>. +procedure query(prompt, def) + local ans + + clear_line() + writes(prompt) + ans := read() + return (*ans = 0 & \def) | ans +end + + # Increment the count, then cycle + # through again when user reaches the + # end of the list. +procedure inc(art) + + if (art +:= 1) > *Status then art := 1 + return art +end + + +procedure more(header, what, footer) + local ans, lines + + writes(getval("cl")) + lines := 0 + \header & { + write(getval("us") || header || getval("ue")) + lines +:= 1 + } + every !what ? { + write(tab(0)) + ((lines +:= 1 + *&subject/getval("co")) % (getval("li") - 1) = 0) & { + writes(getval("so") || + "-MORE-(", (100 > (lines - 2)*100/*what) | 100, "%)" || + getval("se")) + ans := read() & clear_line() + upto('nNqQ', ans) & fail + } + } + \footer & { + writes(getval("so") || footer || getval("se")) + read() & clear_line() + } +end + +procedure clear_line() + + return writes(getval("up") || getval("ce")) +end diff --git a/ipl/progs/mszip.icn b/ipl/progs/mszip.icn new file mode 100644 index 0000000..2e6744a --- /dev/null +++ b/ipl/progs/mszip.icn @@ -0,0 +1,361 @@ +############################################################################ +# +# File: mszip.icn +# +# Subject: Program to ZIP a directory for MS-DOS use +# +# Author: Gregg M. Townsend +# +# Date: June 23, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# usage: mszip [options] root-directory zip-file +# -n no action: just report; zip-file may be omitted +# -v verbose commentary: list individual file types +# -i check filenames for ISO 9660 (CD-ROM) legality +# +# Mszip stuffs the contents of a directory into a ZIP archive file, +# translating text files to CRLF form. Pipes are opened that +# require find, sort, and zip in the search path. +# +# The default report gives an inventory of files by extension. This +# can be useful even without creating a ZIP file ("mszip -n dir"). +# +# File types on the verbose report are: +# x unreadable file +# e empty file +# b binary file +# c text file with CRLFs +# n text file with newlines +# A file is "binary" if it contains more than 1% unexpected characters. +# +# Symlinks, FIFOs, device files etc. are reported and not archived. +# Files with illegal MS-DOS names are reported but still archived. +# +############################################################################ +# +# Requires: UNIX, zip program +# +############################################################################ + + + +$define USAGE "[-n] [-v] [-i] root-directory zip-file" + +$define BTHRESH 0.01 # allowed fraction of wild bytes in text file + +$define BUFSIZ 65536 # size of buffer for checking binary/text + # (bytes beyond this many are not checked) + +$define ZIPOPTS "-9 -X" # best compression; omit uid/gid + + +link options + + + +global verbose +global errorcount +global allfiles, binlist, txtlist +global extns + + + +procedure main(args) + local opts, root, zipopts, zipname + local pwd, pipe, fname, errmsg + local nmproc + + # process options + opts := options(args, "nvi") + verbose := opts["v"] + if \opts["i"] then + nmproc := isoname + else + nmproc := msname + + root := args[1] | stop("usage: ", &progname, " ", USAGE) + + # get current directory name and prepend to zip file if necessary + if /opts["n"] then { + zipname := args[2] | stop("usage: ", &progname, USAGE) + pipe := popen("pwd") + pwd := read(pipe) | stop("can't read current directory") + close(pipe) + if not zipname ? ="/" then + zipname := pwd || "/" || zipname + } + + # change to source directory + chdir(root) | stop("can't change to directory: ", root) + + # verify that zip file is writable + if \zipname then { + if not close(open(zipname, "w")) then + stop(zipname, ": cannot write") + remove(zipname) + } + + # initialize + errorcount := 0 + extns := table("") + allfiles := [] + binlist := [] + txtlist := [] + + # check for "bad" files: symlinks, fifos, etc. + write(&errout, "finding files...") + pipe := popen("find . ! -type d ! -type f -print | sort") + while report(read(pipe), "bad file type") + close(pipe) + + # get list of the rest + pipe := popen("find . -type f -print | sort") + while fname := read(pipe) do { + put(allfiles, fname) + if not nmproc(fname) then + report(fname, "illegal filename") + } + close(pipe) + + # inspect files + write(&errout, "inspecting files...") + while inspect(get(allfiles)) + + # summarize file types by extension + summary() + + # write zip file, if -n was not specified + if \zipname then { + + zipopts := ZIPOPTS + if /verbose then + zipopts := ZIPOPTS || " -q" + + # create zip file and fill with text files + write(&errout, "storing text files...") + pipe := popen("zip -l " || zipopts || " " || zipname || " -@", "w") + every write(pipe, !txtlist) + close(pipe) + + # add binary files to zip file + write() + write(&errout, "storing binary files...") + pipe := popen("zip -g " || zipopts || " " || zipname || " -@", "w") + every write(pipe, !binlist) + close(pipe) + } + + # exit + if errorcount > 0 then + stop("\t", errorcount, " error(s)") + else + write("done.") +end + + + +# popen(cmd, mode) -- open pipe, and abort on error + +procedure popen(cmd, mode) + local f + + mode := "p" || (\mode | "r") + f := open(cmd, mode) | stop("can't open pipe: ", cmd) + return f +end + + + +# census(s, c, lim) -- count occurrences of members of c in string s +# +# If lim is given, counting can stop early. + +procedure census(s, c, lim) + local n + + /lim := *s + n := 0 + s ? { + while n < lim & tab(upto(c)) do + n +:= *tab(many(c)) + } + n >:= lim + return n +end + + + +# msname(fname) -- check filename for MS-DOS legality + +procedure msname(fname) + local dir, base, ext + static forbid + initial forbid := &cset -- &letters -- &digits -- '/._^$~!#%&-{}()@\'`' + + fname ? { + if upto(forbid) then fail # forbidden char + while dir := tab(upto('/') + 1) do + if *dir > 9 then fail # dir component too long + if base := tab(upto('.')) then { + move(1) + if upto('.') then fail # two periods + ext := tab(0) + } + else { + base := tab(0) + ext := "" + } + if (*base > 8) | (*ext > 3) then fail # component too long + } + return +end + + + +# isoname(fname) -- check for ISO-9660 (CD-ROM) filename legality +# +# (disallows explicit version numbers) + +procedure isoname(fname) + static legal + initial legal := &lcase ++ &ucase ++ &digits ++ '_.' + + fname ? { + while tab(upto('/') + 1) + tab(many(legal)) + if pos(0) then + return msname(fname) + else + fail + } +end + + + +# inspect(fname) -- inspect one file and update lists + +procedure inspect(fname) + local c + + fname ? { + if ="./" then + fname := tab(0) + } + + c := ftype(fname) + count(fname, c) + if \verbose then write(c, " ", fname) + + if c == "x" then { + report(fname, "unreadable file") + return + } + + if c == "n" then + put(txtlist, fname) + else + put(binlist, fname) + + return +end + + + +# ftype(fname) -- return file type character + +procedure ftype(fname) + local f, s, lim + static bset + initial bset := # allows \a\b\t\n\v\f\r\^Z + '\0\1\2\3\4\5\6\16\17\20\21\22\23\24\25\26\27\30\31\33\34\35\36\37' ++ + &cset[128+:33] + + f := open(fname, "ru") | return "x" + s := reads(f, BUFSIZ) + close(f) + + if /s | (*s = 0) then return "e" + lim := BTHRESH * *s + if census(s, bset, lim) >= lim then return "b" + else if census(s, '\l') > census(s, '\r') then return "n" + else return "c" +end + + + +# count(fname, typechar) -- count file extension + +procedure count(fname, tchar) + local extn + + fname ? { + while tab(upto('/') + 1) + if tab(upto('.') + 1) then { + while tab(upto('.') + 1) + extn := tab(0) + } + else + extn := "" + } + extns[extn] ||:= tchar + return +end + + + +# report(fname, errmsg) -- report error + +procedure report(fname, errmsg) + write(&errout, "\t", errmsg, ": ", fname) + errorcount +:= 1 + return +end + + + +# summary() -- generate summary of extension counts + +procedure summary() + local tlist, ext, s, b, c, e, n, x, tb, tc, te, tn, tx + + write() + write(" unrd empty bin crlf newln extension") + tb := tc := te := tn := tx := 0 + + tlist := sort(extns, 3) + while ext := get(tlist) do { + s := get(tlist) + tb +:= (b := census(s, 'b')) + tc +:= (c := census(s, 'c')) + te +:= (e := census(s, 'e')) + tn +:= (n := census(s, 'n')) + tx +:= (x := census(s, 'x')) + write(r5(x), r5(e), r5(b), r5(c), r5(n), " .", ext) + } + + write() + write(r5(tx), r5(te), r5(tb), r5(tc), r5(tn), " TOTAL: ", tx+te+tb+tc+tn) + write() + return +end + + + +# r5(n) -- show integer in 5-char field, if nonzero + +procedure r5(n) + local s + + if n = 0 then return " " + s := integer(n) + if *s < 5 then + return right(s, 5) + else + return " " || s +end diff --git a/ipl/progs/mtf3.icn b/ipl/progs/mtf3.icn new file mode 100644 index 0000000..8ebca4e --- /dev/null +++ b/ipl/progs/mtf3.icn @@ -0,0 +1,536 @@ +############################################################################ +# +# File: mtf3.icn +# +# Subject: Program to map tar file +# +# Author: Richard Goerwitz +# +# Date: June 3, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 3.4 +# +############################################################################ +# +# PURPOSE: Maps 15+ char. filenames in a tar archive to 14 chars. +# Handles both header blocks and the archive itself. Mtf is intended +# to facilitate installation of tar'd archives on systems subject to +# the System V 14-character filename limit. +# +# USAGE: mtf inputfile [-r reportfile] [-e .extensions] [-x exceptions] +# +# "Inputfile" is a tar archive. "Reportfile" is file containing a +# list of files already mapped by mtf in a previous run (used to +# avoid clashes with filenames in use outside the current archive). +# The -e switch precedes a list of filename .extensions which mtf is +# supposed to leave unscathed by the mapping process +# (single-character extensions such as .c and .o are automatically +# preserved; -e allows the user to specify additional extensions, +# such as .pxl, .cpi, and .icn). The final switch, -x, precedes a +# list of strings which should not be mapped at all. Use this switch +# if, say, you have a C file with a structure.field combination such +# as "thisisveryverybig.hashptr" in an archive that contains a file +# called "thisisveryverybig.h," and you want to avoid mapping that +# portion of the struct name which matches the name of the overlong +# file (to wit, "mtf inputfile -x thisisveryverybig.hashptr"). To +# prevent mapping of any string (including overlong filenames) begin- +# ning, say, with "thisisvery," use "mtf inputfile -x thisisvery." +# Be careful with this option, or you might end up defeating the +# whole point of using mtf in the first place. +# +# OUTPUT FORMAT: Mtf writes a mapped tar archive to the stdout. +# When finished, it leaves a file called "map.report" in the current +# directory which records what filenames were mapped and how. Rename +# and save this file, and use it as the "reportfile" argument to any +# subsequent runs of mtf in this same directory. Even if you don't +# plan to run mtf again, this file should still be examined, just to +# be sure that the new filenames are acceptable, and to see if +# perhaps additional .extensions and/or exceptions should be +# specified. +# +# BUGS: Mtf only maps filenames found in the main tar headers. +# Because of this, mtf cannot accept nested tar archives. If you try +# to map a tar archive within a tar file, mtf will abort with a nasty +# message about screwing up your files. Please note that, unless you +# give mtf a "reportfile" to consider, it knows nothing about files +# existing outside the archive. Hence, if an input archive refers to +# an overlong filename in another archive, mtf naturally will not +# know to shorten it. Mtf will, in fact, have no way of knowing that +# it is a filename, and not, say, an identifier in a C program. +# Final word of caution: Try not to use mtf on binaries. It cannot +# possibly preserve the correct format and alignment of strings in an +# executable. Same goes for compressed files. Mtf can't map +# filenames that it can't read! +# +############################################################################ + + +global filenametbl, chunkset, short_chunkset # see procedure mappiece(s) +global extensions, no_nos # ditto + +record hblock(name,junk,size,mtime,chksum, # tar header struct; + linkflag,linkname,therest) # see readtarhdr(s) + + +procedure main(a) + local usage, intext, i, current_list + + usage := "usage: mtf inputfile [-r reportfile] " || + "[-e .extensions] [-x exceptions]" + + *a = 0 & stop(usage) + + intext := open_input_file(a[1]) & pop(a) + + i := 0 + extensions := []; no_nos := [] + while (i +:= 1) <= *a do { + case a[i] of { + "-r" : readin_old_map_report(a[i+:=1]) + "-e" : current_list := extensions + "-x" : current_list := no_nos + default : put(current_list,a[i]) + } + } + + every !extensions ?:= (=".", tab(0)) + + # Run through all the headers in the input file, filling + # (global) filenametbl with the names of overlong files; + # make_table_of_filenames fails if there are no such files. + make_table_of_filenames(intext) | { + write(&errout,"mtf: no overlong path names to map") + a[1] ? (tab(find(".tar")+4), pos(0)) | + write(&errout,"(Is ",a[1]," even a tar archive?)") + exit(1) + } + + # Now that a table of overlong filenames exists, go back + # through the text, remapping all occurrences of these names + # to new, 14-char values; also, reset header checksums, and + # reformat text into correctly padded 512-byte blocks. Ter- + # minate output with 512 nulls. + seek(intext,1) + every writes(output_mapped_headers_and_texts(intext)) + + close(intext) + write_report() # Record mapped file and dir names for future ref. + exit(0) + +end + + + +procedure open_input_file(s) + local intext + + intext := open("" ~== s,"r") | + stop("mtf: can't open ",s) + find("UNIX",&features) | + stop("mtf: I'm not tested on non-UNIX systems.") + s[-2:0] == ".Z" & + stop("mtf: sorry, can't accept compressed files") + return intext +end + + + +procedure readin_old_map_report(s) + local mapfile, line, chunk, lchunk + + initial { + filenametbl := table() + chunkset := set() + short_chunkset := set() + } + + mapfile := open_input_file(s) + while line := read(mapfile) do { + line ? { + if chunk := tab(many(~' \t')) & tab(upto(~' \t')) & + lchunk := move(14) & pos(0) then { + filenametbl[chunk] := lchunk + insert(chunkset,chunk) + insert(short_chunkset,chunk[1:16]) + } + if /chunk | /lchunk + then stop("mtf: report file, ",s," seems mangled.") + } + } + +end + + + +procedure make_table_of_filenames(intext) + + local header # chunkset is global + + # search headers for overlong filenames; for now + # ignore everything else + while header := readtarhdr(reads(intext,512)) do { + # tab upto the next header block + tab_nxt_hdr(intext,trim_str(header.size),1) + # record overlong filenames in several global tables, sets + fixpath(trim_str(header.name)) + } + *\chunkset ~= 0 | fail + return &null + +end + + + +procedure output_mapped_headers_and_texts(intext) + + # Remember that filenametbl, chunkset, and short_chunkset + # (which are used by various procedures below) are global. + local header, newtext, full_block, block, lastblock + + # Read in headers, one at a time. + while header := readtarhdr(reads(intext,512)) do { + + # Replace overlong filenames with shorter ones, according to + # the conversions specified in the global hash table filenametbl + # (which were generated by fixpath() on the first pass). + header.name := left(map_filenams(header.name),100,"\x00") + header.linkname := left(map_filenams(header.linkname),100,"\x00") + + # Use header.size field to determine the size of the subsequent text. + # Read in the text as one string. Map overlong filenames found in it + # to shorter names as specified in the global hash table filenamtbl. + newtext := map_filenams(tab_nxt_hdr(intext,trim_str(header.size))) + + # Now, find the length of newtext, and insert it into the size field. + header.size := right(exbase10(*newtext,8) || " ",12," ") + + # Calculate the checksum of the newly retouched header. + header.chksum := right(exbase10(get_checksum(header),8)||"\x00 ",8," ") + + # Finally, join all the header fields into a new block and write it out + full_block := ""; every full_block ||:= !header + suspend left(full_block,512,"\x00") + + # Now we're ready to write out the text, padding the final block + # out to an even 512 bytes if necessary; the next header must start + # right at the beginning of a 512-byte block. + newtext ? { + while block := move(512) + do suspend block + pos(0) & next + lastblock := left(tab(0),512,"\x00") + suspend lastblock + } + } + # Write out a final null-filled block. Some tar programs will write + # out 1024 nulls at the end. Dunno why. + return repl("\x00",512) + +end + + + +procedure trim_str(s) + + # Knock out spaces, nulls from those crazy tar header + # block fields (some of which end in a space and a null, + # some just a space, and some just a null [anyone know + # why?]). + return s ? { + (tab(many(' ')) | &null) & + trim(tab(find("\x00")|0)) + } + +end + + + +procedure tab_nxt_hdr(f,size_str,firstpass) + + # Tab upto the next header block. Return the bypassed text + # as a string if not the first pass. + + local hs, next_header_offset + + hs := integer("8r" || size_str) + next_header_offset := (hs / 512) * 512 + hs % 512 ~= 0 & next_header_offset +:= 512 + if 0 = next_header_offset then return "" + else { + # if this is pass no. 1 don't bother returning a value; we're + # just collecting long filenames; + if \firstpass then { + seek(f,where(f)+next_header_offset) + return + } + else { + return reads(f,next_header_offset)[1:hs+1] | + stop("mtf: error reading in ", + string(next_header_offset)," bytes.") + } + } + +end + + + +procedure fixpath(s) + local s2, piece + + # Fixpath is a misnomer of sorts, since it is used on + # the first pass only, and merely examines each filename + # in a path, using the procedure mappiece to record any + # overlong ones in the global table filenametbl and in + # the global sets chunkset and short_chunkset; no fixing + # is actually done here. + + s2 := "" + s ? { + while piece := tab(find("/")+1) + do s2 ||:= mappiece(piece) + s2 ||:= mappiece(tab(0)) + } + return s2 + +end + + + +procedure mappiece(s) + local chunk, i, lchunk + + # Check s (the name of a file or dir as recorded in the tar header + # being examined) to see if it is over 14 chars long. If so, + # generate a unique 14-char version of the name, and store + # both values in the global hashtable filenametbl. Also store + # the original (overlong) file name in chunkset. Store the + # first fifteen chars of the original file name in short_chunkset. + # Sorry about all of the tables and sets. It actually makes for + # a reasonably efficient program. Doing away with both sets, + # while possible, causes a tenfold drop in execution speed! + + # global filenametbl, chunkset, short_chunkset, extensions + local j, ending + + initial { + /filenametbl := table() + /chunkset := set() + /short_chunkset := set() + } + + chunk := trim(s,'/') + if chunk ? (tab(find(".tar")+4), pos(0)) then { + write(&errout, "mtf: Sorry, I can't let you do this.\n", + " You've nested a tar archive within\n", + " another tar archive, which makes it\n", + " likely I'll f your filenames ubar.") + exit(2) + } + if *chunk > 14 then { + i := 0 + + if /filenametbl[chunk] then { + # if we have not seen this file, then... + repeat { + # ...find a new unique 14-character name for it; + # preserve important suffixes like ".Z," ".c," etc. + # First, check to see if the original filename (chunk) + # ends in an important extension... + if chunk ? + (tab(find(".")), + ending := move(1) || tab(match(!extensions)|any(&ascii)), + pos(0) + ) + # ...If so, then leave the extension alone; mess with the + # middle part of the filename (e.g. file.with.extension.c -> + # file.with001.c). + then { + j := (15 - *ending - 3) + lchunk:= chunk[1:j] || right(string(i+:=1),3,"0") || ending + } + # If no important extension is present, then reformat the + # end of the file (e.g. too.long.file.name -> too.long.fi01). + else lchunk := chunk[1:13] || right(string(i+:=1),2,"0") + + # If the resulting shorter file name has already been used... + if lchunk == !filenametbl + # ...then go back and find another (i.e. increment i & try + # again; else break from the repeat loop, and... + then next else break + } + # ...record both the old filename (chunk) and its new, + # mapped name (lchunk) in filenametbl. Also record the + # mapped names in chunkset and short_chunkset. + filenametbl[chunk] := lchunk + insert(chunkset,chunk) + insert(short_chunkset,chunk[1:16]) + } + } + + # If the filename is overlong, return lchunk (the shortened + # name), else return the original name (chunk). If the name, + # as passed to the current function, contained a trailing / + # (i.e. if s[-1]=="/"), then put the / back. This could be + # done more elegantly. + return (\lchunk | chunk) || ((s[-1] == "/") | "") + +end + + + +procedure readtarhdr(s) + local this_block + + # Read the silly tar header into a record. Note that, as was + # complained about above, some of the fields end in a null, some + # in a space, and some in a space and a null. The procedure + # trim_str() may (and in fact often _is_) used to remove this + # extra garbage. + + this_block := hblock() + s ? { + this_block.name := move(100) # <- to be looked at later + this_block.junk := move(8+8+8) # skip the permissions, uid, etc. + this_block.size := move(12) # <- to be looked at later + this_block.mtime := move(12) + this_block.chksum := move(8) # <- to be looked at later + this_block.linkflag := move(1) + this_block.linkname := move(100) # <- to be looked at later + this_block.therest := tab(0) + } + integer(this_block.size) | fail # If it's not an integer, we've hit + # the final (null-filled) block. + return this_block + +end + + + +procedure map_filenams(s) + local el, ch + + # Chunkset is global, and contains all the overlong filenames + # found in the first pass through the input file; here the aim + # is to map these filenames to the shortened variants as stored + # in filenametbl (GLOBAL). + + local s2, tmp_chunk_tbl, tmp_lst + static new_chunklist + initial { + + # Make sure filenames are sorted, longest first. Say we + # have a file called long_file_name_here.1 and one called + # long_file_name_here.1a. We want to check for the longer + # one first. Otherwise the portion of the second file which + # matches the first file will get remapped. + tmp_chunk_tbl := table() + every el := !chunkset + do insert(tmp_chunk_tbl,el,*el) + tmp_lst := sort(tmp_chunk_tbl,4) + new_chunklist := list() + every put(new_chunklist,tmp_lst[*tmp_lst-1 to 1 by -2]) + + } + + s2 := "" + s ? { + until pos(0) do { + # first narrow the possibilities, using short_chunkset + if member(short_chunkset,&subject[&pos:&pos+15]) + # then try to map from a long to a shorter 14-char filename + then { + if match(ch := !new_chunklist) & not match(!no_nos) + then s2 ||:= filenametbl[=ch] + else s2 ||:= move(1) + } + else s2 ||:= move(1) + } + } + return s2 + +end + + +# From the IPL. Thanks, Ralph - +# Author: Ralph E. Griswold +# Date: June 10, 1988 +# exbase10(i,j) convert base-10 integer i to base j +# The maximum base allowed is 36. + +procedure exbase10(i,j) + + static digits + local s, d, sign + initial digits := &digits || &lcase + if i = 0 then return 0 + if i < 0 then { + sign := "-" + i := -i + } + else sign := "" + s := "" + while i > 0 do { + d := i % j + if d > 9 then d := digits[d + 1] + s := d || s + i /:= j + } + return sign || s + +end + +# end IPL material + + +procedure get_checksum(r) + local sum, field + + # Calculates the new value of the checksum field for the + # current header block. Note that the specification say + # that, when calculating this value, the chksum field must + # be blank-filled. + + sum := 0 + r.chksum := " " + every field := !r + do every sum +:= ord(!field) + return sum + +end + + + +procedure write_report() + + # This procedure writes out a list of filenames which were + # remapped (because they exceeded the SysV 14-char limit), + # and then notifies the user of the existence of this file. + + local outtext, stbl, i, j, mapfile_name + + # Get a unique name for the map.report (thereby preventing + # us from overwriting an older one). + mapfile_name := "map.report"; j := 1 + until not close(open(mapfile_name,"r")) + do mapfile_name := (mapfile_name[1:11] || string(j+:=1)) + + (outtext := open(mapfile_name,"w")) | + open(mapfile_name := "/tmp/map.report","w") | + stop("mtf: Can't find a place to put map.report!") + stbl := sort(filenametbl,3) + every i := 1 to *stbl -1 by 2 do { + match(!no_nos,stbl[i]) | + write(outtext,left(stbl[i],35," ")," ",stbl[i+1]) + } + write(&errout,"\nmtf: ",mapfile_name," contains the list of changes.") + write(&errout," Please save this list!") + close(outtext) + return &null + +end diff --git a/ipl/progs/newicon.icn b/ipl/progs/newicon.icn new file mode 100644 index 0000000..8740456 --- /dev/null +++ b/ipl/progs/newicon.icn @@ -0,0 +1,106 @@ +############################################################################ +# +# File: newicon.icn +# +# Subject: Program to produce new Icon program file +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program creates a new file with a standard Icon program +# header and a skeleton mail procedure. +# +# The first command-line argument is taken as the base +# name of the file; default "foo". The second command-line argument is +# taken as the author; the default is "Ralph E. Griswold" -- with minor +# apologies, I use this program a lot; personalize it for your own +# use. The same comment applies to the skeleton file mentioned below. +# +# The new file is brought up in the vi editor. +# +# The supported options are: +# +# -f overwrite and existing file +# -p produce a procedure file instead of a program +# -o provide program skeleton with options() +# +# The files skeleton.icn, skelproc.icn, and skelopt.icn must be accessible +# via dopen(). +# +############################################################################ +# +# Requires: system(), vi(1) +# +############################################################################ +# +# Links: basename, datetime, io, options +# +############################################################################ + +link basename +link datetime +link io +link options + +procedure main(args) + local opts, overwrite, name, author, input, output, file + + opts := options(args, "fpo") + if \opts["f"] then overwrite := 1 + + name := (args[1] | "foo") + if (*name < 4) | (name[-4:0] ~== ".icn") then name ||:= ".icn" + + author := args[2] | "Ralph E. Griswold" + + if /overwrite then { # check to see if file exists + if input := open(name) then { + close(input) + system("vi " || name) + exit() + } + } + + output := open(name, "w") | + stop("*** cannot open ", name, " for writing") + + input := dopen( + if \opts["o"] then file := "skelopt.icn" + else if \opts["p"] then "skelproc.icn" + else "skeleton.icn" + ) | stop("*** cannot open skeleton file") + + every 1 to 2 do write(output, read(input)) | + stop("*** short skeleton file") + write(output, read(input), name) | + stop("*** short skeleton file") + every 1 to 3 do write(output, read(input)) | + stop("*** short skeleton file") + write(output, read(input), author) | + stop("*** short skeleton file") + write(output, read(input)) | + stop("*** short skeleton file") + write(output, read(input), date()) | + stop("*** short skeleton file") + write(output, read(input)) | + stop("*** short skeleton file") + while write(output, read(input)) + + if \opts["p"] then { + write(output, "procedure ", basename(name, ".icn"), "()") + write(output) + write(output, "end") + } + + close(output) + + system("vi " || name) + +end diff --git a/ipl/progs/newsrc.icn b/ipl/progs/newsrc.icn new file mode 100644 index 0000000..68a0012 --- /dev/null +++ b/ipl/progs/newsrc.icn @@ -0,0 +1,88 @@ +############################################################################ +# +# File: newsrc.icn +# +# Subject: Program to organize UNIX .newsrc file +# +# Author: Alan D. Corre +# +# Date: April 1, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program takes the .newsrc file, moves active groups to the beginning +# then appends inactive groups with the numbers omitted, then anything else. +# the groups are alphabetized. +# +# The user may retain a set of groups at the top of the file by specifying how +# many groups on the command line. If not specified, it will be prompted for. +# the new file is called newnewsrc. The user can replace .newsrc with it if it +# is satisfactory. +# +############################################################################ + +procedure main(times) + process(times) +end + +procedure process(times) +local active, inactive, defective, invar, outvar, line, newline + +#create three empty lists + active := [] + inactive := [] + defective := [] + +#open old and new files + if not (invar := open(".newsrc")) then stop("Unable to open .newsrc") + outvar := open("newnewsrc","w") + +#get saved lines +if *times = 0 then put(times,ask()) else { + if not integer(times[1]) then stop("Bye") + if times[1] = 1 then write("The following line has been saved:") else + if times[1] > 1 then + write("The following ",times[1]," lines have been saved:")} + every 1 to times[1] do + write(write(outvar,read(invar))) +#place the lines in appropriate lists + while line := read(invar) do { + newline := line + line ? {if find(":") then + put(active,newline) else + if newline := (tab(find("!")) || "!") then + put(inactive,newline) else + put(defective,newline)}} + close(invar) +#sort the lists + active := sort(active) + inactive := sort(inactive) + defective := sort(defective) +#create the new file + every line := !active do + write(outvar,line) + every line := !inactive do + write(outvar,line) + every line := !defective do + write(outvar,line) +#notify user + write("File newnewsrc has been created. If it is satisfactory, use") + write("mv newnewsrc .newsrc to replace old file.") + close(outvar) +end + + +procedure ask() +local number,n + n := 0 + write("You may save any number of lines at the top of the file.") + writes("Enter a whole number, 0 or greater.> ") + while not integer(number := read()) do { + if (n +:= 1) > 3 then stop("Bye.") + writes("You must enter a whole number.> ")} + return number +end diff --git a/ipl/progs/nim.icn b/ipl/progs/nim.icn new file mode 100644 index 0000000..73fa2e5 --- /dev/null +++ b/ipl/progs/nim.icn @@ -0,0 +1,319 @@ +############################################################################ +# +# File: nim.icn +# +# Subject: Program to play the game of nim +# +# Author: Jerry Nowlin +# +# Date: June 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The game of nim focuses on a pile of 15 sticks. Each player can +# select 1, 2, or 3 sticks from the sticks remaining in the pile when +# it's their turn. The player to pick up the last stick(s) wins. The +# loser of the previous game always gets to go first. +# +# There are two versions of nim in here. The first (default) version +# uses an algorithm to make its moves. It will never lose if it gets +# the first turn. The second version tries to learn from each game. +# You'll have to play a few games before it will get very smart but +# after a while it will also never lose if it gets the first turn. This +# is assuming of course that you know how to play. Since the learning +# version learns from the person it plays against, if you're lousy the +# game will be too. +# +# To invoke the learning version just pass any argument to the program. +# If you want to see how the program learns, you can use the string +# "show" as the argument and the program's current game memory will be +# displayed after each game. If you invoke the game with the string save +# as an argument a file called ".nimdump" will be created in the current +# directory with a dump of the program's game memory when you quit and +# the next time the game is played in learn mode it will initialize its +# game memory from the dump. You can invoke this program with more than +# one argument so show and save can be used at the same time. +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +global STICKS, # the number of stick left + MINE, # my trys for a given game + THEIRS, # their trys for a given game + TRIED # the combined tried table (game memory) + +procedure main(args) + + local resp, # player response + turn, # who's turn + fp, # file pointer + stick, # sticks index + take, # take index + seed, # random number seed + show # show the game memory flag + + randomize() + + # check if we should show the thought process of a learning game + if !args == "show" then show := "yes" + + # define game memory + TRIED := table() + + # if this is a learning game and there's a memory dump read it + if *args > 0 & fp := open(".nimdump","r") then { + every stick := 1 to 15 do { + TRIED[stick] := list(3) + every take := 1 to 3 do + TRIED[stick][take] := (read(fp) | "?") + } + close(fp) + } + + # otherwise initialize game memory to unknowns + else every stick := 1 to 15 do TRIED[stick] := [ "?", "?", "?" ] + + # start with their turn + turn := "theirs" + + # print the initial message + write("\nThis is the game of nim. You must pick up 1, 2 or 3") + write("sticks from the pile when it's your turn. The player") + write("that picks up the last stick(s) wins. Good luck.") + + # loop + repeat { + + # initialize the per game variables + STICKS := 15 + THEIRS := table() + MINE := table() + + # display the initial stick pile + dispile() + + # loop while there are sticks left + while STICKS > 0 do + + # take turns + if turn == "theirs" then + turn := theirturn(args) + else turn := myturn(args) + + # the player who took the last stick(s) wins + if turn == "theirs" then + write("\nI won!") + else write("\nYou won!") + + # if this is a thinking game learn from it + if *args > 0 then learn(turn,show) + + # see if they want to play again + writes("\nDo you want to play again? ") + if not any('yY',read()) then quit(args,"\nGoodbye.\n") + } +end + +procedure theirturn(args) + + local pick # the players pick + + # find out how many sticks they want + writes("How many sticks do you want? ") + pick := read() + + # check their response to see if they want to quit + if any('qQ',pick) then quit(args,"\nYou gave up!\n") + + # check to see if their pick is valid + if not numeric(pick) | pick < 1 | pick > (3 | STICKS) then + write("\007Invalid Response\007\n") & return "theirs" + + # save their pick if this is a thinking game + if *args > 0 then THEIRS[STICKS] := pick + + # take away the sticks + STICKS -:= pick + + # if there are any sticks left display them + if STICKS > 0 then dispile() + + # make it my turn + return "mine" +end + +procedure myturn(args) + + local pick # my pick + + # let them know I'm about to pick + writes("I'll take ") + + # make my choice depending on whether or not this is a thinking game + if *args > 0 then { + + # think about it + pick := thinkpick(STICKS) + + # if I can't make up my mind randomly pick one choice + if type(pick) == "list" then pick := ?pick + + MINE[STICKS] := pick + + } else pick := algorpick(STICKS) + + # tell them what I decided + write((1 < pick) || " sticks." | "1 stick.") + + # take away the sticks + STICKS -:= pick + + # if there are any sticks left display them + if STICKS > 0 then dispile() + + # make it their turn + return "theirs" +end + +procedure dispile() + write() + every 1 to STICKS do writes("/ ") + write("\n") +end + +# Use an algorithmic method to choose the number of sticks I want. The +# decision is made by taking the number of sticks that will leave an even +# multiple of 4 in the pile (0 is an even multiple of 4) if possible and if +# not then randomly choose 1, 2 or 3 sticks. + +procedure algorpick(sticks) + return (0 ~= (sticks % 4)) | ?3 +end + +# Use a learning method to choose the number of sticks I want. The +# decision is made by looking at the choices that have been made for this +# number of sticks in the past and the results of the game where it was +# made. If there is no pick that resulted in a win make a random pick +# from all the unknown picks. If there are no unknown picks just randomly +# choose 1, 2 or 3 sticks and hope THEY screw up. + +procedure thinkpick(sticks,recurse) + + local picks, # unknown picks + take, # take index + check, # check list + pick # my pick + + # initialize a list of unknown picks + picks := [] + + # check every possible pick + every take := 1 to 3 do { + + # if this pick won take it + if TRIED[sticks][take] == "won" then return take + + # if this pick is unknown save it + if TRIED[sticks][take] == "?" then put(picks,take) + } + + # if there are no unknown picks and no winning picks anything goes + if *picks = 0 then picks := [1,2,3] + + # be smarter and check to see if there is a clear win for THEM + # after any of the picks left + if /recurse then { + check := [] + every pick := !picks do + if type(thinkpick(0 < (sticks - pick),1)) == "list" then + put(check,pick) + if *check = 0 then + picks := [1,2,3] + else picks := check + } + + return picks +end + +# Save the results of each pick in this game in the programs game memory and +# if the command line argument was "show" display the updated game memory. + +procedure learn(turn,show) + + local them, # their outcome flag + me, # my outcome flag + stick, # sticks index + take # taken index + + # decide on the outcome + if turn == "theirs" then + them := "lost" & me := "won" + else them := "won" & me := "lost" + + # check for all the picks made for this game and save the results + # in the game memory + every stick := 1 to 15 do { + if \MINE[stick] then + TRIED[stick][MINE[stick]] := + comp(TRIED[stick][MINE[stick]],me) + if \THEIRS[stick] then + TRIED[stick][THEIRS[stick]] := + comp(TRIED[stick][THEIRS[stick]],them) + } + + # if the show flag is set print the program's game memory + if \show then { + writes("\n picks\n ") + every writes(center(1 to 3,5)) + write("\n ----------------") + every stick := 15 to 1 by -1 do { + if stick = 8 then + writes("sticks ",right(stick,2),"|") + else writes(" ",right(stick,2),"|") + every take := 1 to 3 do + writes(center(TRIED[stick][take],5)) + write() + } + } + + return +end + +# Compare this game's result with what the program remembers. If the results +# were the same fine. If the old result was unknown save the new result. If +# the old result is different from the new result the game can't know for +# sure anymore so go back to unknown. + +procedure comp(old,new) + + return (old == new) | (old == "?" & new) | "?" + +end + +procedure quit(args,msg) + + local fp, # file pointer + stick, # sticks index + take # take index + + write(msg) + + if !args == "save" then + if fp := open(".nimdump","w") then { + every stick := 1 to 15 do + every take := 1 to 3 do + write(fp,TRIED[stick][take]) + close(fp) + } + + exit() +end diff --git a/ipl/progs/nocr.icn b/ipl/progs/nocr.icn new file mode 100644 index 0000000..cde499b --- /dev/null +++ b/ipl/progs/nocr.icn @@ -0,0 +1,135 @@ +############################################################################ +# +# File: nocr.icn +# +# Subject: Program to convert MS-DOS text files to UNIX +# +# Author: Richard L. Goerwitz +# +# Date: December 30, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.4 +# +############################################################################ +# +# This program simply converts \r\n to \n in each line of each of the +# files supplied as command-line arguments, thereby effecting conversion +# of MS-DOS format text files to the corresponding UNIX format. +# +# usage: nocr file1 [file2 [etc.]] +# +# No check done to see whether the file is in fact a text file. +# +############################################################################ +# +# Requires: UNIX or MS-DOS +# +# See also: yescr.icn +# +############################################################################ + +procedure main(a) + + local fname, infile, outfile, line, temp_name + + # Static variables, initial clause not really necessary in main(). + static slash, l, ms, DOSos, nok, ok + initial { + + nok := string(~&letters) + ok := repl("X",*nok) + + # Find us a place to put temporary files. + if find("UNIX",&features) then { + slash := "/" + l := 10 + ms := "" + } + else if find("MS-DOS", &features) then { + slash := "\\" + l := 8 + ms := "u" + DOSos := 1 + } + # Don't take this out unless you're sure of what you're doing. + else stop("nocr: tested only under UNIX and MS-DOS") + } + + # Check to see if we have any arguments. + *a = 0 & stop("usage: nocr file1 [file2...]") + + # Start popping filenames off of the argument list. + while fname := pop(a) do { + + # Open input file. + infile := open(fname,"r") | (er_out(fname), next) + # Get temporary file name. + every temp_name := + pathname(fname, slash) || + map(left(basename(fname,slash),l,"X"), nok, ok) || + "." || right(0 to 999,3,"0") + do close(open(temp_name)) | break + # Open temporary file. + outfile := open(\temp_name,"w"||ms) | (er_out(fname), next) + + if \DOSos then { + # Infile above was opened in translate mode (removing the CR), + # while outfile was opened in untranslate mode (automatically + # writing the line in UNIX format). + while write(outfile,read(infile)) + } + else { + # If not running under DOS, then we're under UNIX (unless + # we've been hacked). Trim CR manually, then write. + while line := read(infile) do { + if line[-1] == "\x0D" then + line[-1] := "" + write(outfile, line) + } + } + + # Close opened input and output files. + close(infile) | stop("nocr: cannot close, ",fname,"; aborting") + close(outfile) | stop("nocr: cannot close, ",temp_name,"; aborting") + + # Remove physical input file. + remove(fname) | stop("nocr: cannot remove ",fname,"; aborting") + + # Give temp name the same name as the input file, completing the + # conversion process. + rename(temp_name,fname) | + stop("nocr: Can't find temp file ",temp_name,"; aborting") + } + +end + + +procedure er_out(s) + write(&errout,"nocr: cannot open ",s," for reading") + return +end + + +procedure basename(s,slash) + s ? { + while tab(find(slash)+1) + return tab(0) + } +end + + +procedure pathname(s,slash) + local s2 + + s2 := "" + s ? { + while s2 ||:= tab(find(slash)+1) + return s2 + } +end diff --git a/ipl/progs/noise.icn b/ipl/progs/noise.icn new file mode 100644 index 0000000..e35d368 --- /dev/null +++ b/ipl/progs/noise.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: noise.icn +# +# Subject: Program to generate random noise +# +# Author: Gregg M. Townsend +# +# Date: November 3, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program generates random 8-bit bytes until killed. +# While it may not be cryptographically strong, it is +# suitable for overwriting a disk or tape for disposal. +# +############################################################################ +# +# Links: random +# +############################################################################ + +$define BUFSIZE 1000000 # working buffer size +$define BLKSIZE 65536 # output block size + +link random + +procedure main() + local buf, cs + + collect(2, 2 * BUFSIZE) # ensure large memory region + randomize() # different results every time + + buf := "" + cs := string(&cset) + every 1 to BUFSIZE do + buf ||:= ?cs # initialize buffer randomly + + repeat # write random transliterations of random subsets of buffer + writes(map(buf[?(BUFSIZE - BLKSIZE) +: BLKSIZE], cs, scramble(cs))) +end diff --git a/ipl/progs/normalize.icn b/ipl/progs/normalize.icn new file mode 100644 index 0000000..2d71cad --- /dev/null +++ b/ipl/progs/normalize.icn @@ -0,0 +1,46 @@ +############################################################################ +# +# File: normalize.icn +# +# Subject: Program to normalize numeric channel +# +# Author: Ralph E. Griswold +# +# Date: January 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads numbers, one per line, from standard input and +# writes them out normalized so that the largest is 1.0. +# +############################################################################ +# +# Links: numbers +# +############################################################################ + +link numbers + +procedure main() + local numbers, colors, line, i, largest + + numbers := [] + + colors := [] + while line := read() do { + line ? { + put(numbers, i := tab(upto(' \t') | 0)) + put(colors, tab(0)) + } + } + + largest := real(max ! numbers) + + every i := 1 to *numbers do + write(numbers[i] / largest, colors[i]) + +end diff --git a/ipl/progs/oldicon.icn b/ipl/progs/oldicon.icn new file mode 100644 index 0000000..f0d2a99 --- /dev/null +++ b/ipl/progs/oldicon.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: oldicon.icn +# +# Subject: Program to update the date in an Icon program header +# +# Author: Ralph E. Griswold +# +# Date: September 23, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program updates the date line in a standard Icon program header. +# The old file is saved with the suffix ".bak". +# +# The file then is brought up in the vi editor unless the -f option +# is specified. +# +############################################################################ +# +# Requires: system(), vi(1), UNIX +# +############################################################################ +# +# Links: datetime, options +# +############################################################################ + +link datetime +link options + +procedure main(args) + local name, input, output, line, opts + + opts := options(args, "f") + + name := (args[1] | "foo") + if (*name < 4) | (name[-4:0] ~== ".icn") then name ||:= ".icn" + + if system("cp " || name || " " || name || ".bak >/dev/null") ~= 0 then { + if /opts["f"] then system("vi " || name) # if file didn't exist + exit() + } + + input := open(name || ".bak") | stop("*** cannot open backup file") + + output := open(name, "w") | stop("*** cannot open ", name, " for writing") + + repeat { # to provide a way out ... + every 1 to 8 do write(output, read(input)) | break + line := read(input) | break + line ? { + write(output, ="# Date: ", date()) | write(output, tab(0)) + } + break + } + + while write(output, read(input)) + + close(output) + + if /opts["f"] then system("vi " || name) + +end diff --git a/ipl/progs/pack.icn b/ipl/progs/pack.icn new file mode 100644 index 0000000..8a45aa8 --- /dev/null +++ b/ipl/progs/pack.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: pack.icn +# +# Subject: Program to package multiple files +# +# Author: Ralph E. Griswold +# +# Date: July 1, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This programs takes a list of file names on the command line 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(args) + local in, name + + every name := !args do { + close(\in) + in := open(name) | stop("cannot open input file: ",name) + write("##########") + write(name) + while write(read(in)) + } + +end diff --git a/ipl/progs/paginate.icn b/ipl/progs/paginate.icn new file mode 100644 index 0000000..0b5cb5d --- /dev/null +++ b/ipl/progs/paginate.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: paginate.icn +# +# Subject: Program to insert formfeeds +# +# Author: Paul Abrahams +# +# Date: September 28, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program processes a document text file, inserting formfeeds +# at appropriate places. +# +############################################################################ + +procedure main() + local j, k, line, eof + + while /eof do { + line := list(66, "") + every k := 1 to 66 do + (line[k] := read()) | (eof := 0) + every k := 66 to 0 by -1 do + if k = 0 | *trim(line[k]) > 0 then break + every write(line[j := 1 to k]) + if k > 0 then + write("\f") + } +end diff --git a/ipl/progs/papply.icn b/ipl/progs/papply.icn new file mode 100644 index 0000000..03c5a5a --- /dev/null +++ b/ipl/progs/papply.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: papply.icn +# +# Subject: Program to apply procedure to lines of file +# +# Author: Ralph E. Griswold +# +# Date: May 31, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program applies the procedure given as a command-line argument +# to each line of standard input, writing out the results. For example, +# +# papply reverse <foo +# +# writes out the lines of foo reversed end-for-end. +# +# As it stands, there is no way to provide other arguments. That' easy +# to remedy. +# +# Except for use with (built-in) functions, this program needs to be linked +# with procedures that might be used with it. +# +############################################################################ + +invocable all + +procedure main(args) + local p, line + + p := proc(get(args)) | stop("*** invalid or missing procedure") + + while line := read() do + write(p(line)) + +end diff --git a/ipl/progs/parens.icn b/ipl/progs/parens.icn new file mode 100644 index 0000000..74b1acc --- /dev/null +++ b/ipl/progs/parens.icn @@ -0,0 +1,117 @@ +############################################################################ +# +# File: parens.icn +# +# Subject: Program to produce random balanced strings +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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- +# guages. 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, random +# +############################################################################ + +link options +link random + +global r, k, lp, rp + +procedure main(args) + local string, i, s, bound, limit, varying, opts + + randomize() + + 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 diff --git a/ipl/progs/pargen.icn b/ipl/progs/pargen.icn new file mode 100644 index 0000000..52d2681 --- /dev/null +++ b/ipl/progs/pargen.icn @@ -0,0 +1,204 @@ +############################################################################ +# +# File: pargen.icn +# +# Subject: Program to generate context-free parser +# +# Author: Ralph E. Griswold +# +# Date: March 31, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads a context-free BNF grammar and produces an Icon +# program that is a parser for the corresponding language. +# +# Nonterminal symbols are are enclosed in angular brackets. Vertical +# bars separate alternatives. All other characters are considered to +# be terminal symbols. The nonterminal symbol on the first line is +# taken to be the goal. +# +# An example is: +# +# <expression>::=<term>|<term>+<expression> +# <term>::=<element>|<element>*<term> +# <element>::=x|y|z|{<expression>} +# +# Parentheses can be used for grouping symbols, as in +# +# <term>::=<element>(|*<term>) +# +# Note that an empty alternative is allowable. +# +# The right-hand side metacharacters <, >, (, ), and | are accessible +# through the built-in symbols <lb>, <rb>, <lp>, <rp>, and <vb>, +# respectively. There are two other build-in symbols, <empty> and <nl> +# that match the empty string and a newline, respectively. +# +# Characters in nonterminal names are limited to letters, digits, and +# underscores. +# +# An underscore is appended to the parsing procedure name to avoid +# possible collisions with Icon function names. +# +# Lines beginning with an = are passed through unchanged. This allows +# Icon declarations to be placed in the parser. Lines beginning with +# a # are considered to be comments and are ignored. +# +# If the name of a ucode file is given on the command line, a link +# declaration for it is provided in the output. Otherwise the main +# procedure in recog is used. +# +############################################################################ +# +# Limitations: +# +# Left recursion in the grammar may cause the parser to loop. +# There is no check that all nonterminal symbols that are referenced +# are defined or that there may be duplicate definitions. +# +############################################################################ +# +# Reference: +# +# The Icon Programming Language, Second Edition, Ralph E. and Madge T. +# Griswold, Prentice-Hall, 1990, pp. 180-187. +# +############################################################################ +# +# Output links recog, matchlib +# +# See also: recog.icn, matchlib.icn, and parscond.icn +# +############################################################################ + +global declend # name suffix and record body +global goal # nonterminal goal name +global nchars # characters allowed in a nonterminal name +global procend # name suffix and parens +global sym # current nonterminal symbol + +procedure main(args) + local line # a line of input + + declend := "__" + procend := "_()" + nchars := &letters ++ &digits ++ '_' + + while line := read() do { # process lines of input + line ? { + case move(1) of { # action depends on first character + "<": tab(0) ? transprod() # transform the production + "=": write(tab(0)) # pass through + "#": &null # ignore + default: error() + } # end case + } # end scan + } # end while + + write("link ",args[1] | "recog") # link main procedure + write("link matchlib") # link built-in symbols + write("global goal\n") # write out global declaration + write("procedure init()") # write out initialization procedure + write(" goal := ",goal,"_") + write(" return") + write("end") + +end + +# +# Transform a production. +# + +procedure transprod() + + { + sym := tab(many(nchars)) & # get the nonterminal name + =">::=" + } | error() # catch syntactic error + write("record ",sym,declend,"(alts)")# record declaration + write("procedure ",sym,procend) # procedure header + write(" suspend {") # begin the suspend expression + writes(" ",sym,declend,"(") # write indentation + transalts() # transform the alternatives + write(")") + write(" }") # end the suspend expression + write("end") # end the procedure declaration + write() # space between declarations + /goal := sym # first symbol is goal + +end + +# +# Transform a sequence of alternatives. +# +procedure transalts() + local alt # an alternative + + while alt := tab(bal('|') | 0) do { # process alternatives + writes("[") # record for alternative + alt ? transseq() # transform the symbols + if move(1) then writes("] | ") # if more, close the parentheses + # and add the alternation. + else { + writes("]") # no more, so just close the parentheses + break + } # end else + } # end while + +end + +# +# Transform a sequence of symbols. +# +procedure transseq() + + repeat { + transsym() # process a symbols + if not pos(0) then writes(" , ") # if there's more, provide concatenation + else break # else get out and return + } # end while + + return + +end + +# +# Transform a symbol. +# +procedure transsym() + local group + + if ="<" then { # if it's a nonterminal + { # write it with suffix. + writes(tab(many(nchars)),procend) & + =">" # get rid of closing bracket + } | error() # or catch the error + } # end then + + else if ="(" then { # if it's a parenthesis, pass it + writes("(") # along and call transseq() + group := tab(bal(')')) | error() + group ? transalts() + writes(")") + move(1) + } + # else transform nonterminal string + else writes("=",image(tab(upto('<') | 0))) + + return + +end + +# +# Issue error message and terminate execution. +# +procedure error() + + stop("*** malformed definition: ",tab(0)) + +end diff --git a/ipl/progs/parse.icn b/ipl/progs/parse.icn new file mode 100644 index 0000000..ee3c11c --- /dev/null +++ b/ipl/progs/parse.icn @@ -0,0 +1,133 @@ +############################################################################ +# +# File: parse.icn +# +# Subject: Program to parse simple statements +# +# Author: Kenneth Walker +# +# Date: February 18, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program parses simple statements. +# +# It provides an interesting example of the use of co-expressions. +# +############################################################################ + +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 diff --git a/ipl/progs/parsex.icn b/ipl/progs/parsex.icn new file mode 100644 index 0000000..f5efee9 --- /dev/null +++ b/ipl/progs/parsex.icn @@ -0,0 +1,167 @@ +############################################################################ +# +# File: parsex.icn +# +# Subject: Program to parse arithmetic expressions +# +# Author: Cheyenne Wills +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/patchu.icn b/ipl/progs/patchu.icn new file mode 100644 index 0000000..b480070 --- /dev/null +++ b/ipl/progs/patchu.icn @@ -0,0 +1,153 @@ +############################################################################ +# +# File: patchu.icn +# +# Subject: Program to implement UNIX-like patch +# +# Author: Rich Morin +# +# Date: June 18, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads a source file and a diff file, producing an +# updated file. The diff file may be generated by the UNIX diff(1) +# utility, or by diffu.icn, which uses dif.icn for the hard work. +# +# The original patch(1) utility, written by Larry Wall, is widely +# used in the UNIX community. +# +# The diff file contains edit lines, separators, and text lines. +# Edit lines may take the forms: +# +# #a#[,#] <- add lines +# #[,#]c#[,#] <- change lines +# #[,#]d# <- delete lines +# +# Change lines contain only the string "---". All other lines are +# text lines. See diff(1) in any UNIX manual for more details. +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ +# +# Links: options, patch +# +############################################################################ + +link options, patch + +record diff_rec(pos, diffs) + +global n1, n2, n3, n4 + +procedure main(arg) + local t, rev, source, dfile, diffs + + t := options(arg, "r") + rev := t["r"] + + if *arg ~= 2 then + zot("usage: patchu source diffs") + + source := open(arg[1]) | zot("cannot open " || arg[1]) + dfile := open(arg[2]) | zot("cannot open " || arg[2]) + +# every write(patch(source, get_diff(dfile))) # ? shouldn't need diffs ? + + diffs := [] + every put(diffs, get_diff(dfile)) + every write(patch(source, diffs, rev)) + +end + + +procedure get_diff(dfile) # get diff record + local ef, i1, i2, l1, l2, i, line + + repeat { + if ef := get_edit(dfile) then { +# write(">>> ",n1,", ",n2,", ",ef,", ",n3,", ",n4) + if ef == "a" then i1 := n1+1 else i1 := n1 + if ef == "d" then i2 := n3+1 else i2 := n3 + l1 := [] + l2 := [] + if ef == !"cd" then { + every i := n1 to n2 do { + line := !dfile | zot("unexpected end of edit data(1)") + if line[1:3] ~== "< " then + zot("bad edit data(1): " || line) + put(l1, line[3:0]) + } + } + + if ef == "c" then { + line := !dfile | zot("unexpected end of edit data(2)") + if line ~== "---" then + zot("bad edit data(2): " || line) + } + + if ef == !"ac" then { + every i := n3 to n4 do { + line := !dfile | zot("unexpected end of edit data(3)") + if line[1:3] ~== "> " then + zot("bad edit data(3): " || line) + put(l2, line[3:0]) + } + } + suspend [diff_rec(i1,l1), diff_rec(i2,l2)] + } + else + fail + } + +end + + +procedure get_edit(dfile) # get edit parameters + local edit, i1, i2, ef, i3, i4 + + edit := !dfile | fail + i1 := i2 := many(&digits, edit) | zot("bad edit spec(1): " || edit) + n1 := n2 := edit[1:i1] + if edit[i1] == "," then { + i2 := many(&digits, edit, i1+1) | zot("bad edit spec(2): " || edit) + n2 := edit[i1+1:i2] + } + + if edit[i2] == !"acd" then { + ef := edit[i2] + i3 := i4 := many(&digits, edit, i2+1) | zot("bad edit spec(3): " || edit) + n3 := n4 := edit[i2+1:i3] + if edit[i3] == "," then { + i4 := many(&digits, edit, i3+1) | zot("bad edit spec(4): " || edit) + n4 := edit[i3+1:i4] + } + } + else + zot("bad edit spec(5): " || edit) + + if i4 ~= *edit+1 then + zot("bad edit spec(6): " || edit) + + if not 0 <= n3 <= n4 then + zot("bad edit spec(7): " || edit) + + if not 0 <= n1 <= n2 then + zot("bad edit spec(8): " || edit) + + return ef + +end + + +procedure zot(msg) # exit w/message + write(&errout, "patchu: " || msg) + exit(1) +end diff --git a/ipl/progs/pbkdump.icn b/ipl/progs/pbkdump.icn new file mode 100644 index 0000000..bec6c26 --- /dev/null +++ b/ipl/progs/pbkdump.icn @@ -0,0 +1,47 @@ +############################################################################ +# +# File: pbkdump.icn +# +# Subject: Program to dump HP95 phone book file +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to dump data from a HP95 phone book (pbk) file. +# +############################################################################ +# +# Links: pbkform, bkutil +# +############################################################################ +# +# See also: pbkform.icn, pbkutil.icn, abkform.icn +# +############################################################################ + +link pbkform,bkutil + +procedure main(args) + local fn, f, x + + every fn := !args do { + f := open(fn,"u") | stop("Can't open ",fn) + x := pbk_read_id(f) + while x := pbk_read_data(f) do { + write("Name: ",x.name) + write("Number: ",x.number) + write("Address:") + every write(!bk_format_lines(x.address)) + write() + } + pbk_read_end(f) | write("Fail on end record") + close(f) + } +end diff --git a/ipl/progs/pdecomp.icn b/ipl/progs/pdecomp.icn new file mode 100644 index 0000000..0247772 --- /dev/null +++ b/ipl/progs/pdecomp.icn @@ -0,0 +1,34 @@ +############################################################################ +# +# File: pdecomp.icn +# +# Subject: Program to list primes factors of an integer +# +# Author: Ralph E. Griswold +# +# Date: December 12, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program lists the prime factors of integers given in +# standard input. +# +############################################################################ +# +# Links: factors +# +############################################################################ + +link factors + +procedure main() + local i + + while i := factors(read()) do + every write(!i) + +end diff --git a/ipl/progs/polydemo.icn b/ipl/progs/polydemo.icn new file mode 100644 index 0000000..d90d8f9 --- /dev/null +++ b/ipl/progs/polydemo.icn @@ -0,0 +1,272 @@ +############################################################################ +# +# File: polydemo.icn +# +# Subject: Program to demonstrate polynomial library +# +# Author: Erik Eid +# +# Date: May 23, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is an example for the use of the polystuf library. The +# user is given a number of options that allow the creation, output, +# deletion, or operations on up to 26 polynomials, indexed by letter. +# +# Available commands: +# (R)ead - allows input of a polynomial by giving pairs of +# coefficients and exponents. For example, entering +# 5, 6, 2, and 3 will create 5x^6 + 2x^3. This polynomial +# will be stored by an index which is a lower-case letter. +# (W)rite - outputs to the screen a chosen polynomial. +# (A)dd - adds two polynomials and defines the sum as a third +# (S)ubtract - subtracts two polynomials and defines the difference as +# a third. +# (M)ultiply - multiplies two polynomials and defines the product as a +# third. +# (E)valuate - gives the result of setting x in a polynomial to a value +# (C)lear - deletes one polynomial +# (H)elp - lists all commands +# (Q)uit - end the demonstration +# +############################################################################ +# +# Links: polystuf +# +############################################################################ + +link polystuf + +global filled, undefined, poly_table + +procedure main() +local option + poly_table := table() # Set up a table that will hold + # all of the polynomials (which + # are tables themselves). + filled := "That slot is already filled!" + undefined := "That has not been defined!" + SetUpDisplay() + repeat { + ShowInUse() + writes ("RWASMECHQ> ") + option := choice(read()) # Get first letter of entry in + # lower-case format. + case option of { + "r": PRead() + "w": PWrite() + "a": PCalc ("+") + "s": PCalc ("-") + "m": PCalc ("*") + "e": PEval() + "c": PClear() + "h": ShowHelp() + "q": break + default: write ("Invalid command!") + } + write() + } +end + +procedure SetUpDisplay() + write (center ("Icon v8.10 Polynomial Demo", 80)) + write() + ShowHelp() + write (repl("-", 80)) + return +end + +procedure ShowHelp() + write (repl(" ", 10), "(R)ead (W)rite (A)dd (S)ubtract") + write (repl(" ", 10), "(M)ultiply (E)valuate (C)lear _ + (H)elp (Q)uit") + return +end + +procedure ShowInUse() +local keylist + keylist := list() + writes ("In Use:") + every push (keylist, key(poly_table)) # Construct a list of the keys in + # poly_table, corresponding to + # which slots are being used. + keylist := sort (keylist) + every writes (" ", !keylist) + write() + return +end + +procedure is_lower(c) + if /c then fail + if c == "" then fail + return (c >>= "a") & (c <<= "z") # Succeeds only if c is a lower- +end # case letter. + +procedure choice(s) + return map(s[1], &ucase, &lcase) # Returns the first character of + # the given string converted to + # lower-case. +end + +procedure PRead() +local slot, terms, c, e + repeat { + writes ("Which slot to read into? ") + slot := choice(read()) + if is_lower(slot) then break + } + if member (poly_table, slot) then { # Disallow reading into an + write (filled) # already occupied slot. + fail + } + write ("Input terms as coefficient-exponent pairs. Enter 0 for") + write ("coefficient to stop. Entries must be numerics.") + terms := list() + repeat { + write() + repeat { + writes ("Coefficient> ") + c := read() + if numeric(c) then break + } + if c = 0 then break + repeat { + writes (" Exponent> ") + e := read() + if numeric(e) then break + } + put (terms, c) # This makes a list compatible + put (terms, e) # with the format needed by + # procedure poly of polystuf. + } + if *terms = 0 then terms := [0, 0] # No terms = zero polynomial. + poly_table[slot] := poly ! terms # Send the elements of terms as + # parameters to poly and store + # the resulting polynomial in the + # proper slot. + return +end + +procedure PWrite () +local slot + repeat { + writes ("Which polynomial to display? ") + slot := choice(read()) + if is_lower(slot) then break + } + if member (poly_table, slot) then { # Make sure there is a polynomial + write (poly_string(poly_table[slot])) # to write! + return + } + else { + write (undefined) + fail + } +end + +procedure PCalc (op) +local slot1, slot2, slot_ans, res + writes ("Which two polynomials to ") + case op of { + "+": write ("add? ") # Note that this procedure is + "-": write ("subtract? ") # used for all three operations + "*": write ("multiply? ") # since similar tasks, such as + } # checking on the status of slots, + # are needed for all of them. + repeat { + writes ("First: ") + slot1 := choice(read()) + if is_lower(slot1) then break + } + if member (poly_table, slot1) then { + repeat { + writes ("Second: ") + slot2 := choice(read()) + if is_lower(slot2) then break + } + if member (poly_table, slot2) then { + repeat { + writes ("Slot for answer: ") + slot_ans := choice(read()) + if is_lower(slot_ans) then break + } + if member (poly_table, slot_ans) then { + write (filled) + fail + } + else { + case op of { + "+": { + res := poly_add(poly_table[slot1], poly_table[slot2]) + writes ("Sum ") + } + "-": { + res := poly_sub(poly_table[slot1], poly_table[slot2]) + writes ("Difference ") + } + "*": { + res := poly_mul(poly_table[slot1], poly_table[slot2]) + writes ("Product ") + } + } + write ("has been defined as polynomial \"", slot_ans, "\"") + poly_table[slot_ans] := res + } + } + else { + write (undefined) + fail + } + } + else { + write (undefined) + fail + } + return +end + +procedure PEval () +local slot, x, answer + repeat { + writes ("Which polynomial to evaluate? ") + slot := choice(read()) + if is_lower(slot) then break + } + if member (poly_table, slot) then { + repeat { + writes ("What positive x to evaluate at? ") + x := read() + if numeric(x) then if x > 0 then break + } + answer := poly_eval (poly_table[slot], x) + write ("The result is ", answer) + return + } + else { + write (undefined) + fail + } +end + +procedure PClear () +local slot + repeat { + writes ("Which polynomial to clear? ") + slot := choice(read()) + if is_lower(slot) then break + } + if member (poly_table, slot) then { + delete (poly_table, slot) + return + } + else { + write (undefined) + fail + } +end + diff --git a/ipl/progs/post.icn b/ipl/progs/post.icn new file mode 100644 index 0000000..bc6ffd4 --- /dev/null +++ b/ipl/progs/post.icn @@ -0,0 +1,366 @@ +############################################################################ +# +# File: post.icn +# +# Subject: Program to post news +# +# Author: Ronald Florence +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.5 +# +############################################################################ +# +# This program posts a news article to Usenet. Given an optional +# argument of the name of a file containing a news article, or an +# argument of "-" and a news article via stdin, post creates a +# follow-up article, with an attribution and quoted text. The +# newsgroups, subject, distribution, follow-up, and quote-prefix can +# optionally be specified on the command line. +# +# usage: post [options] [article | -] +# -n newsgroups +# -s subject +# -d distribution +# -f followup-to +# -p quote-prefix (default ` > ') +# +# See the site & system configuration options below. On systems +# posting via inews, post validates newsgroups and distributions in +# the `active' and `distributions' files in the news library directory. +# +############################################################################ +# +# Bugs: Newsgroup validation assumes the `active' file is sorted. +# Non-UNIX sites need hardcoded system information. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +global mode, sysname, domain, tz, tmpfile, opts, console, newslib, org + +procedure main(arg) + local usage, smarthost, editor, default_distribution, generic_from + local tmpdir, logname, fullname, sigfile, article, inf, edstr, outf, tmp2 + + usage := ["usage: post [options] [article]", + "\t-n newsgroups", + "\t-s subject", + "\t-d distribution", + "\t-f followup-to", + "\t-p quote-prefix (default ` > ')", + "\t- read article from stdin"] + + # Site configuration. Mode can be + # "local" (post via inews), + # "uux" (post via rnews to an upstream host), + # "mail" (post via mail to an upstream host). + # For either uux or mail mode, + # smarthost := the uucp nodename of the upstream news feed. + # Use generic_from to force a generic address instead + # of the hostname provided by system commands. + + mode := "local" + smarthost := "" + editor := "vi" + domain := ".UUCP" + default_distribution := "world" + generic_from := &null + + # For UNIX, the rest of the configuration is automatic. + + if find("UNIX", &features) then { + console := "/dev/tty" + newslib := "/usr/lib/news/" + tz := "unix" + tmpdir := "/tmp/" + logname := pipe("logname") + sysname := trim(pipe("hostname", "uname -n", "uuname -l")) + # BSD passwd: `:fullname[,...]:' + # SysV passwd: `-fullname(' + \logname & every lookup("/etc/passwd") ? { + =(logname) & { + every tab(upto(':')+1) \4 + fullname := (tab(upto('-')+1), tab(upto('(:'))) | tab(upto(',:')) + break + } + } + sigfile := getenv("HOME") || "/.signature" + } + + # For non-UNIX systems, we need hard coded configuration: + # console := the system's name for the user's terminal. + # libdir := the directory for news configuration files, like + # an `organization' file. + # tmpdir := optional directory for temporary files; terminated + # with the appropriate path separator: `/' or `\\'. + # logname := user's login name. + # tz := local time zone (e.g., EST). + # fullname := user's full name. + # sigfile := full path of file with user's email signature. + + else { + console := "CON" + newslib := "" + tmpdir := "" + logname := &null + tz := &null + fullname := &null + sigfile := &null + sysname := getenv("HOST") | &host + } + + # End of user configuration. + + (\logname & \sysname & \tz & (mode == "local" | *smarthost > 0)) | + stop("post: missing system information") + opts := options(arg, "n:s:d:f:p:h?") + \opts["h"] | \opts["?"] | arg[1] == "?" & { + every write(!usage) + exit(-1) + } + org := getenv("ORGANIZATION") | lookup(newslib || "organization") + article := open(tmpfile := tempname(tmpdir), "w") | + stop("post: cannot write temp file") + write(article, "Path: ", sysname, "!", logname) + writes(article, "From: ", logname, "@", \generic_from | sysname, domain) + \fullname & writes(article, " (", fullname, ")") + write(article) + + # For a follow-up article, reply_headers() does the work. + + if \arg[1] then { + inf := (arg[1] == "-" & &input) | + open(arg[1]) | (remove(tmpfile) & stop("post: cannot read " || arg[1])) + reply_headers(inf, article) + every write(article, \opts["p"] | " > ", !inf) + close(inf) + } + + # Query if newsgroups, subject, and distribution have + # not been specified on the command line. + + else { + write(article, "Newsgroups: ", + validate(\opts["n"] | query("Newsgroups: "), "active")) + write(article, "Subject: ", \opts["s"] | query("Subject: ")) + write(article, "Distribution: ", + validate(\opts["d"] | query("Distribution: ", default_distribution), + "distributions")) + every write(article, req_headers()) + write(article, "\n") + } + close(article) + edstr := (getenv("EDITOR") | editor) || " " || tmpfile || " < " || console + system(edstr) + upto('nN', query("Are you sure you want to post this to Usenet y/n? ")) & { + if upto('yY', query("Save your draft article y/n? ")) then + stop("Your article is saved in ", tmpfile) + else { + remove(tmpfile) + stop("Posting aborted.") + } + } + # For inews, we supply the headers, inews supplies the .signature. + + if mode == "local" then mode := newslib || "inews -h" + else { + \sigfile & { + article := open(tmpfile, "a") + write(article, "--") + every write(article, lookup(sigfile)) + } + # To post via sendnews (mail), we prefix lines with 'N'. + # For rnews, don't force an immediate poll. + + case mode of { + "mail": { + mode ||:= " " || smarthost || "!rnews" + outf := open(tmp2 := tempname(tmpdir), "w") + every write(outf, "N", lookup(tmpfile)) + remove(tmpfile) + rename(tmp2, tmpfile) + } + "uux": mode ||:= " - -r " || smarthost || "!rnews" + } + } + mode ||:= " < " || tmpfile + (system(mode) = 0) & write("Article posted!") + remove(tmpfile) +end + + # To parse the original article, we use case-insensitive + # matches on the headers. The Reply-to and Followup-To + # headers usually appear later than From and Newsgroups, so + # they take precedence. By usenet convention, we query + # the user if Followup-To on the original is `poster'. + +procedure reply_headers(infile, art) + local fullname, address, quoter, date, id, subject, distribution + local group, refs + + every !infile ? { + tab(match("from: " | "reply-to: ", map(&subject))) & { + if find("<") then { + fullname := (trim(tab(upto('<'))) ~== "") + address := (move(1), tab(find(">"))) + } + else { + address := trim(tab(upto('(') | 0)) + fullname := (move(1), tab(find(")"))) + } + quoter := (\fullname | address) + } + tab(match("date: ", map(&subject))) & date := tab(0) + tab(match("message-id: ", map(&subject))) & id := tab(0) + tab(match("subject: ", map(&subject))) & subject := tab(0) + tab(match("distribution: ", map(&subject))) & distribution := tab(0) + tab(match("newsgroups: " | "followup-to: ", map(&subject))) & + group := tab(0) + tab(match("references: ", map(&subject))) & refs := tab(0) + (\quoter & *&subject = 0) & { + find("poster", group) & { + write(quoter, " has requested followups by email.") + upto('yY', query("Do you want to abort this posting y/n? ")) & { + remove(tmpfile) + stop("Posting aborted.") + } + group := &null + } + write(art, "Newsgroups: ", \group | + validate(\opts["n"] | query("Newsgroups: "), "active")) + write(art, "Subject: ", \opts["s"] | \subject | query("Subject: ")) + \distribution | distribution := validate(\opts["d"], "distributions") & + write(art, "Distribution: ", distribution) + write(art, "References: ", (\refs ||:= " ") | "", id) + every write(art, req_headers()) + write(art, "In-reply-to: ", quoter, "'s message of ", date) + write(art, "\nIn ", id, ", ", quoter, " writes:\n") + return + } + } +end + + # We need a unique message-id, and a date in RFC822 format. + # Easy with UNIX systems that support `date -u'; with the + # others, we leave the local timezone. The first inews site + # will correct it. + +procedure req_headers() + local uniq, date, month, day, time, zone, year + + uniq := "<" + &date || &clock ? while tab(upto(&digits)) do uniq ||:= tab(many(&digits)) + uniq ||:= "@" || sysname || domain || ">" + if tz == "unix" then { + date := pipe("date -u", "date") + date ? { + month := (tab(find(" ") + 1), tab(many(&letters))) + day := (tab(upto(&digits)), tab(many(&digits))) + time := (tab(upto(&digits++':')), tab(many(&digits++':'))) + zone := (tab(upto(&ucase)), tab(many(&ucase))) + year := (tab(upto(&digits)+ 2), tab(0)) + } + date := day || " " || month || " " || year || " " || time || " " || zone + } + else { + &dateline ? { + month := left((tab(find(" ")+1), tab(many(&letters))), 3) || " " + date := (tab(upto(&digits)), tab(many(&digits))) || " " || month + date ||:= (tab(upto(&digits)), right(tab(many(&digits)), 2)) + } + date ||:= " " || &clock || " " || tz + } + mode ~== "local" & suspend "Message-ID: " || uniq + suspend "Date: " || date + \org & suspend "Organization: " || org + \opts["f"] & return "Followup-To: " || ((opts["f"] == "poster") | + validate(opts["f"], "active")) +end + + # Richard Goerwitz's generator. + +procedure tempname(dir) + local temp_name + + every temp_name := dir || "article." || right(1 to 999,3,"0") do { + close(open(temp_name)) & next + suspend \temp_name + } +end + + # On systems with pipes, pipe() will read from the first + # successful command of the list given as arguments. + +procedure pipe(cmd[]) + local inf, got + + initial find("pipes" | "compiled", &features) | stop("No pipes.") + while inf := open("(" || pop(cmd) || ") 2>&1", "pr") do { + got := [] + every put(got, !inf) + close(inf) = 0 & { + suspend !got + break + } + } +end + + # The dirty work of reading from a file. + +procedure lookup(what) + local inf + + inf := open(what, "r") | fail + suspend !inf + close(inf) +end + + # Query opens stdin because the system call to the editor + # redirects input. The optional parameter is a default + # response if the user answers with <return>. + +procedure query(prompt, def) + local ans + static stdin + + initial stdin := open(console) + writes(prompt) + ans := read(stdin) + return (*ans = 0 & \def) | ans +end + + # A quick and dirty kludge. Validate() builds a sorted list. + # When an element is found, it is popped and the search moves + # to the next item. The procedure assumes the file is also + # sorted. + +procedure validate(what, where) + local valid, stuff, sf, a + + mode ~== "local" & return what + valid := &letters ++ '.-' ++ &digits + stuff := [] + what ? while tab(upto(valid)) do put(stuff,tab(many(valid))) + sf := open(newslib || where) | { + remove(tmpfile) + stop("post: cannot open ", newslib || where) + } + stuff := sort(stuff) + a := pop(stuff) + every !sf ? match(a) & (a := pop(stuff)) | return what + remove(tmpfile) + stop("`", a, "' is not in ", newslib || where) +end diff --git a/ipl/progs/press.icn b/ipl/progs/press.icn new file mode 100644 index 0000000..9e703c6 --- /dev/null +++ b/ipl/progs/press.icn @@ -0,0 +1,896 @@ +############################################################################ +# +# File: press.icn +# +# Subject: Program to archive files +# +# Author: Robert J. Alexander +# +# Date: November 14, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Besides being a useful file archiving utility, this program can be +# used to experiment with the LZW compression process, as it contains +# extensive tracing facilities that illustrate the process in detail. +# +# Compression can be turned off if faster archiving is desired. +# +# The LZW compression procedures in this program are general purpose +# and suitable for reuse in other programs. +# +############################################################################ +# +# Instructions for use are summarized in "help" procedures that follow. +# +############################################################################ +# +# Links: options, colmize, wildcard +# +############################################################################ + +link options, colmize, wildcard + +procedure Usage(s) + /s := "" + stop("\nUsage:_ +\n Compress: press -c <archive file> [<options>] [<file to compress>...]_ +\n Archive: press -a <archive file> [<options>] [<file to archive>...]_ +\n Extract: press -x <archive file> [<options>] [<file to extract>...]_ +\n Print: press -p <archive file> [<options>] [<file to print>...]_ +\n List: press -l <archive file> [<options>] [<file to list>...]_ +\n Delete: press -d <archive file> [<options>] <file to delete>..._ +\n_ +\n Help: press (prints this message)_ +\n More help:press -h (prints more details)_ +\n_ +\n -c perform compression into <archive file>_ +\n -a add file(s) to <archive file> in uncompressed format_ +\n -x extract (& decompress) file(s) from <archive file>_ +\n -p extract (& decompress) from <archive file> to standard output_ +\n -l list file names in <archive file>_ +\n -d delete file(s) from <archive file>_ +\n (produces new file -- old file saved with \".bak\" suffix)_ +\n_ +\n Options:_ +\n -q work quietly_ +\n -t text file(s) (retrieves with correct line end format)_ +\n -n process all files in archive *except* specified files_ +\n_ +\n LZW Experimentor Options:_ +\n -T produce detailed compression trace info (to standard error file)_ +\n -S maximum compression string table size_ +\n (for -c only -- default = 1024)_ +\n" + ,s) +end + +procedure MoreHelp() + return "\n _ + The archive (-a) option means to add the file without compression._ +\n_ +\n If no files are specified to extract, print, or list, then all files_ +\n in the archive are used._ +\n_ +\n UNIX-style filename wildcard conventions can be used to express_ +\n the archived file names for extract, print, list, and delete_ +\n operations. Be sure to quote names containing wildcard characters_ +\n so that they aren't expanded by the shell (if applicable)._ +\n_ +\n If a <file to compress> or <file to archive> is \"-\", or if no files_ +\n are specified, standard input is archived._ +\n_ +\n If <archive file> for extract, print, or list is \"-\", standard input_ +\n is the archive file._ +\n_ +\n If <archive file> for compress or archive is \"-\", archive is written_ +\n to standard output._ +\n_ +\n New files archived to an existing archive file are always appended,_ +\n deleting any previously archived version of the same file name._ +\n_ +\n Archive files can be simply concatenated to create their union._ +\n However, if the same file exists in both archives, only the first_ +\n in the resulting file will be able to be accessed._ +\n_ +\n If a \"compressed\" file turns out to be longer than the uncompressed_ +\n file (rare but possible, usually for very short files), the file will_ +\n automatically be archived in uncompressed format._ +\n_ +\n A default file name suffix of \".prx\" is assumed for <archive file>_ +\n names that are specified without a suffix._ +\n_ +\n_ +\n LZW \"internals\" option:_ +\n_ +\n If the specified maximum table size is positive, the string table is_ +\n discarded when the maximum size is reached and rebuilt (usually the_ +\n better choice). If negative, the original table is not discarded,_ +\n which might produce better results in some circumstances. This_ +\n option was provided primarily for experimentors._ +\n" +end + +# +# Global variables. +# +# Note: additional globals that contain option values are defined near +# Options(), below. +# +global inchars,outchars,tinchars,toutchars,lzw_recycles, + lzw_stringTable,rf,wf,magic,rline,wline + +# +# Main procedure. +# +procedure main(arg) + local arcfile + # + # Initialize. + # + Options(arg) + inchars := outchars := tinchars := toutchars := lzw_recycles := 0 + magic := "\^p\^r\^e\^s\^s\^i\^c\^n" + # + # Do requested operation. + # + arcfile := + DefaultSuffix(\(compr | archive | extract | print | lister | deleter), + "prx") | Usage() + if \(compr | archive) then Archive(arcfile,arg) + else if \(extract | print) then Extract(arcfile,arg) + else if \lister then List(arcfile,arg) + else if \deleter then Delete(arcfile,arg) + return +end + + +# +# Option global variables. +# +global lzw_trace,maxTableSpecified,maxTableSize,print,quiet,tmode,WildMatch +global extract,compr,archive,lister,deleter + +# +# Options() -- Handle command line options. +# +procedure Options(arg) + local opt,n,x + opt := options(arg,"hc:a:x:p:l:d:qtTS+n") + if \opt["h"] then Usage(MoreHelp()) + extract := opt["x"] + print := opt["p"] + compr := opt["c"] + archive := opt["a"] + lister := opt["l"] + deleter := opt["d"] + quiet := opt["q"] + tmode := if \opt["t"] then "t" else "u" + WildMatch := if \opt["n"] then not_wild_match else whole_wild_match + lzw_trace := opt["T"] + maxTableSpecified := opt["S"] + maxTableSize := \maxTableSpecified | 1024 # 10 bits default + n := 0 + every x := compr | archive | extract | print | lister | deleter do + if \x then n +:= 1 + if n ~= 1 then Usage() + return +end + + +# +# Archive() -- Do archiving. +# +procedure Archive(arcfile,arg) + local fn,addr,realLen,maxT,length,addr2,deleteFiles,new_data_start + # + # Confirm options and open the archive file. + # + if *arg = 0 | WildMatch === not_wild_match then Usage() + if ("" | "-") ~== arcfile then { + if wf := open(arcfile,"ru") then { + if not (reads(wf,*magic) == magic) then { + stop("Invalid archive file ",arcfile) + } + close(wf) + } + wf := open(arcfile,"bu" | "wu") | stop("Can't open archive file ",arcfile) + if tmode == "t" then rline := "\n" + seek(wf,0) + if where(wf) = 1 then writes(wf,magic) + } + else { + wf := &output + arcfile := "stdout" + } + new_data_start := where(wf) + ## if /quiet then + ## write(&errout,"New data starting at byte ",new_data_start," of ",arcfile) + # + # Loop to process files on command line. + # + if *arg = 0 then arg := ["-"] + deleteFiles := [] + every fn := !arg do { + if fn === arcfile then next + if /quiet then + writes(&errout,"File \"",fn,"\" -- ") + rf := if fn ~== "-" then open(fn,tmode) | &null else &input + if /rf then { + if /quiet then + write(&errout,"Can't open input file \"",fn,"\" -- skipped") + next + } + put(deleteFiles,fn) + WriteString(wf,Tail(fn)) + addr := where(rf) + seek(rf,0) + realLen := where(rf) - 1 + WriteInteger(wf,realLen) + seek(rf,addr) + if /quiet then + writes(&errout,"Length: ",realLen) + addr := where(wf) + WriteInteger(wf,0) + writes(wf,"\1") # write a compression version string + if \compr then { + WriteInteger(wf,maxTableSize) + maxT := Compress(R,W,maxTableSize) + length := outchars + 4 + if /quiet then + writes(&errout," Compressed: ",length," ", + Percent(realLen - outchars,realLen)) + } + # + # If compressed file is larger than original, just copy the original. + # + if \archive | length > realLen then { + if /quiet then + writes(&errout," -- Archived uncompressed") + seek(wf,addr + 4) + writes(wf,"\0") # write a zero version string for uncompressed + seek(rf,1) + CopyFile(rf,wf) + inchars := outchars := length := realLen + maxT := 0 + lzw_stringTable := "" + } + if /quiet then + write(&errout) + close(rf) + addr2 := where(wf) + seek(wf,addr) + WriteInteger(wf,length) + seek(wf,addr2) + if /quiet then + Stats(maxT) + } + close(wf) + if /quiet then + if *arg > 1 then FinalStats() + Delete(arcfile,deleteFiles,new_data_start) + return +end + + +# +# Extract() -- Extract a file from the archive. +# +procedure Extract(arcfile,arg) + local fileSet,wfn,realLen,cmprLen,maxT,version,theArg + if \maxTableSpecified then Usage() + rf := OpenReadArchive(arcfile) + arcfile := rf[2] + rf := rf[1] + if *arg > 0 then fileSet := set(arg) + # + # Process input file. + # + while wfn := ReadString(rf) do { + (realLen := ReadInteger(rf) & + cmprLen := ReadInteger(rf) & + version := ord(reads(rf))) | + stop("Bad format in compressed file") + if /quiet then + writes(&errout,"File \"",wfn,"\" -- length: ",realLen, + " compressed: ",cmprLen," bytes -- ") + if /fileSet | WildMatch(theArg := !arg,wfn) then { + delete(\fileSet,theArg) + if not version = (0 | 1) then { + if /quiet then + write(&errout,"can't handle this compression type (",version, + ") -- skipped") + seek(rf,where(rf) + cmprLen) + } + else { + if /quiet then + write(&errout,"extracted") + if /print then { + wf := open(wfn,"w" || tmode) | &null + if /wf then { + if /quiet then + write(&errout,"Can't open output file \"",wfn, + "\" -- quitting") + exit(1) + } + } + else wf := &output + if version = 1 then { + maxT := ReadInteger(rf) | + stop("Error in archive file format: ","table size missing") + Decompress(R,W,maxT) + } + else { + maxT := 0 + CopyFile(rf,wf,cmprLen) + outchars := inchars := realLen + } + close(&output ~=== wf) + if /quiet then + Stats(maxT) + } + } + else { + if /quiet then + write(&errout,"skipped") + seek(rf,where(rf) + cmprLen) + } + } + close(rf) + FilesNotFound(fileSet) + return +end + + +# +# List() -- Skip through the archive, extracting info about files, +# then list in columns. +# +procedure List(arcfile,arg) + local fileSet,flist,wfn,realLen,cmprLen,version,theArg + if \maxTableSpecified then Usage() + rf := OpenReadArchive(arcfile) + arcfile := rf[2] + rf := rf[1] + write(&errout,"Archive file ",arcfile,":") + if *arg > 0 then fileSet := set(arg) + # + # Process input file. + # + flist := [] + while wfn := ReadString(rf) do { + (realLen := ReadInteger(rf) & + cmprLen := ReadInteger(rf) & + version := ord(reads(rf))) | + stop("Bad format in compressed file") + if /fileSet | WildMatch(theArg := !arg,wfn) then { + delete(\fileSet,theArg) + put(flist,"\"" || wfn || "\" " || realLen || "->" || cmprLen) + tinchars +:= realLen + toutchars +:= cmprLen + } + seek(rf,where(rf) + cmprLen) + } + close(rf) + every write(&errout,colmize(sort(flist))) + FilesNotFound(fileSet) + FinalStats() + return +end + + +# +# Delete() -- Delete a file from the archive. +# +procedure Delete(arcfile,arg,new_data_start) + local workfn,workf,fileSet,wfn,realLen,cmprLen,bakfn,deletedFiles, + head,version,hdrLen,theArg + if *arg = 0 | (\deleter & \maxTableSpecified) then Usage() + rf := OpenReadArchive(arcfile) + arcfile := rf[2] + rf := rf[1] + workfn := Root(arcfile) || ".wrk" + workf := open(workfn,"wu") | stop("Can't open work file ",workfn) + writes(workf,magic) + fileSet := set(arg) + # + # Process input file. + # + deletedFiles := 0 + head := if \deleter then "File" else "Replaced file" + while not (\new_data_start <= where(rf)) & wfn := ReadString(rf) do { + (realLen := ReadInteger(rf) & + cmprLen := ReadInteger(rf) & + version := ord(reads(rf))) | + stop("Bad format in compressed file") + if /quiet then + writes(&errout,head," \"",wfn,"\" -- length: ",realLen, + " compressed: ",cmprLen," bytes -- ") + if WildMatch(theArg := !arg,wfn) then { + deletedFiles +:= 1 + delete(fileSet,theArg) + if /quiet then + write(&errout,"deleted") + seek(rf,where(rf) + cmprLen) + } + else { + if /quiet then + write(&errout,"kept") + hdrLen := *wfn + 10 + seek(rf,where(rf) - hdrLen) + CopyFile(rf,workf,cmprLen + hdrLen) + } + } + if deletedFiles > 0 then { + CopyFile(rf,workf) + every close(workf | rf) + if (rf ~=== &input) then { + bakfn := Root(arcfile) || ".bak" + remove(bakfn) + rename(arcfile,bakfn) | stop("Couldn't rename ",arcfile," to ",bakfn) + } + rename(workfn,arcfile) | stop("Couldn't rename ",workfn," to ",arcfile) + } + else { + every close(workf | rf) + remove(workfn) + } + if \deleter then FilesNotFound(fileSet) + return +end + + +# +# OpenReadArchive() -- Open an archive for reading. +# +procedure OpenReadArchive(arcfile) + local rf + rf := if ("" | "-") ~== arcfile then + open(arcfile,"ru") | stop("Can't open archive file ",arcfile) + else { + arcfile := "stdin" + &input + } + if reads(rf,*magic) ~== magic then stop("Invalid archive file ",arcfile) + if tmode == "t" then wline := "\x0a" + return [rf,arcfile] +end + + +# +# FilesNotFound() -- List the files remaining in "fileSet". +# +procedure FilesNotFound(fileSet) + return if *\fileSet > 0 then { + write(&errout,"\nFiles not found:") + every write(&errout," ",colmize(sort(fileSet),78)) + &null + } +end + + +# +# Stats() -- Print stats after a file. +# +procedure Stats(maxTableSize) + # + # Write statistics + # + if \lzw_trace then write(&errout, + " table size = ",*lzw_stringTable,"/",maxTableSize, + " (recycles: ",lzw_recycles,")") + tinchars +:= inchars + toutchars +:= outchars + inchars := outchars := lzw_recycles := 0 + return +end + + +# +# FinalStats() -- Print final stats. +# +procedure FinalStats() + # + # Write final statistics + # + write(&errout,"\nTotals: ", + "\n input: ",tinchars, + "\n output: ",toutchars, + "\n compression: ",Percent(tinchars - toutchars,tinchars) | "", + "\n") + return +end + + +# +# WriteInteger() -- Write a 4-byte binary integer to "f". +# +procedure WriteInteger(f,i) + local s + s := "" + every 1 to 4 do { + s := char(i % 256) || s + i /:= 256 + } + return writes(f,s) +end + + +# +# ReadInteger() -- Read a 4-byte binary integer from "f". +# +procedure ReadInteger(f) + local s,v + s := reads(f,4) | fail + if *s < 4 then + stop("Error in archive file format: ","bad integer") + v := 0 + s ? while v := v * 256 + ord(move(1)) + return v +end + + +# +# WriteString() -- Write a string preceded by a length byte to "f". +# +procedure WriteString(f,s) + return writes(f,char(*s),s) +end + + +# +# ReadString() -- Read a string preceded by a length byte from "f". +# +procedure ReadString(f) + local len,s + len := ord(reads(f)) | fail + s := reads(f,len) + if *s < len then + stop("Error in archive file format: ","bad string") + return s +end + + +# +# CopyFile() -- Copy a file. +# +procedure CopyFile(rf,wf,len) + local s + if /len then { + while writes(wf,s := reads(rf,1000)) + } + else { + while len > 1000 & writes(wf,s := reads(rf,1000)) do len -:= *s + writes(wf,s := reads(rf,len)) & len -:= *s + } + return len +end + + +# +# Percent() -- Format a rational number "n"/"d" as a percentage. +# +procedure Percent(n,d) + local sign,whole,fraction + n / (0.0 ~= d) ? { + sign := ="-" | "" + whole := tab(find(".")) + move(1) + fraction := tab(0) + } + return (\sign || ("0" ~== whole | "") || + (if whole == "0" then integer else 1)(left(fraction,2,"0")) | "--") || + "%" +end + + +# +# R() -- Read-a-character procedure. +# +procedure R() + local c + + c := reads(rf) | fail + inchars +:= 1 + if c === rline then c := "\x0a" + return c +end + + +# +# W() -- Write-characters procedure. +# +procedure W(s) + local i + + every i := find(\wline,s) do s[i] := "\n" + outchars +:= *s + return writes(wf,s) +end + + +# +# Tail() -- Return the file name portion (minus the path) of a +# qualified file name. +# +procedure Tail(fn) + local i + i := 0 + every i := upto('/\\:',fn) + return .fn[i + 1:0] +end + + +# +# Root() -- Return the root portion (minus the suffix) of a file name. +# +procedure Root(fn) + local i + i := 0 + every i := find(".",fn) + return .fn[1:i] +end + + +procedure DefaultSuffix(fn,suf) + local i + return fn || "." || suf +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 # default 10 "bits" + 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 { + write(&errout,"\nInput string\tOutput code\tNew table entry") + writes(&errout,"\"",image(s)[2:-1]) + } + while c := inproc() do { + if \lzw_trace then + writes(&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 + writes(&errout,"\"\t\t", + image(char(*&cset > junk2) | junk2), + "(",junk1,")\t\t",lzw_stringTable[t]," = ",image(t),"\n\"") + s := c + } + } + Compress_output(outproc,junk2 := lzw_stringTable[s], + junk1 := *lzw_stringTable) + if *lzw_stringTable < maxTableSize then + {} + else if tossTable >= 0 then { + lzw_stringTable := copy(charTable) + lzw_recycles +:= 1 + } + if \lzw_trace then + writes(&errout,"\"\t\t", + image(char(*&cset > junk2) | junk2),"(",junk1,")\n") + Compress_output(outproc,EOF,*lzw_stringTable) + if \lzw_trace then write(&errout,"\"\t\t",EOF) + 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,maxTableSize) + local EOF,c,charSize,code,i,new_code,old_strg, + strg,tossTable + # + # Initialize. + # + /maxTableSize := 1024 # default 10 "bits" + 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 + write(&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 + write(&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 + write(&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 + + +procedure whole_wild_match(p,s) + return wild_match(p,s) > *s +end + + +procedure not_wild_match(p,s) + return not (wild_match(p,s) > *s) +end + diff --git a/ipl/progs/pretrim.icn b/ipl/progs/pretrim.icn new file mode 100644 index 0000000..42591e1 --- /dev/null +++ b/ipl/progs/pretrim.icn @@ -0,0 +1,40 @@ +############################################################################ +# +# File: pretrim.icn +# +# Subject: Program to filter out first terms in an input stream +# +# Author: Ralph E. Griswold +# +# Date: November 22, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program discards the first i values in input, given by -n i; default +# 0. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, i + + opts := options(args, "n+") + + i := \opts["n"] | 0 + + every 1 to i do + read() + + while write(read()) + +end diff --git a/ipl/progs/procprep.icn b/ipl/progs/procprep.icn new file mode 100644 index 0000000..c0635f4 --- /dev/null +++ b/ipl/progs/procprep.icn @@ -0,0 +1,63 @@ +############################################################################ +# +# File: procprep.icn +# +# Subject: Program to produce input to index for procedure comments +# +# Author: Ralph E. Griswold +# +# Date: November 22, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is used to produce the data needed to index the "#:" +# comments on procedure declarations that is needed to produces a +# permuted index to procedures. +# +############################################################################ + +procedure main() + local files, file, input, line, prefix + + files := open("ls [a-z]*.icn", "p") + + while file := read(files) do { + if *file > 13 then write(&errout,"*** file name too long: ", file) + prefix := file[1:-4] + input := open(file) + every 1 to 4 do read(input) # skip to subject line + line := read(input) | { + write(&errout, "*** no subject in ", file) + next + } + line ? { + if tab(find("Subject: Procedures") + 21) | + tab(find("Subject: Declarations ") + 23) | + tab(find("Subject: Declaration ") + 22) | + tab(find("Subject: Procedure ") + 20) then { + =("for " | "to ") + } + else { + write(&errout, "*** bad subject line in ", file) + close(input) + next + } + } + + while line := read(input) do + line ? { + if ="procedure" then { + tab(many(' \t')) + write(prefix, ":", tab(upto('(')), ": ", (tab(find("#: ") + 3), + tab(0))) + } + } + + close(input) + } + +end diff --git a/ipl/progs/procwrap.icn b/ipl/progs/procwrap.icn new file mode 100644 index 0000000..01fdcac --- /dev/null +++ b/ipl/progs/procwrap.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: procwrap.icn +# +# Subject: Program to produce Icon procedure wrappers +# +# Author: Ralph E. Griswold +# +# Date: September 29, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This little program takes procedure names from standard input and +# writes minimal procedure declarations for them. For example, the +# input line +# +# wrapper +# +# produces +# +# procedure wrapper() +# end +# +# This program is useful when you have a lot of procedures to write. +# +############################################################################ + +procedure main() + + while write("procedure ", read(), "()\nend\n") + +end diff --git a/ipl/progs/proto.icn b/ipl/progs/proto.icn new file mode 100644 index 0000000..0ade496 --- /dev/null +++ b/ipl/progs/proto.icn @@ -0,0 +1,217 @@ +############################################################################ +# +# File: proto.icn +# +# Subject: Program to show Icon syntactic forms +# +# Author: Ralph E. Griswold +# +# Date: January 3, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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) + +invocable all + +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 diff --git a/ipl/progs/psrsplit.icn b/ipl/progs/psrsplit.icn new file mode 100644 index 0000000..c0da16d --- /dev/null +++ b/ipl/progs/psrsplit.icn @@ -0,0 +1,64 @@ +############################################################################ +# +# File: psrsplit.icn +# +# Subject: Program to separate psrecord.icn output pages +# +# Author: Gregg M. Townsend +# +# Date: September 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# usage: psrsplit file +# +# If a file produced by the procedures in psrecord.icn contains multiple +# pages, it cannot be easily incorporated into another document. psrsplit +# reads such a file and breaks it into individual pages. The algorithm +# is frugal of memory and file descriptors at the expense of reading the +# input file multiple times. +# +# For an input file is named xxxx or xxxx.yyy, the output files are +# named xxxx.p01, xxxx.p02, etc. for as many pages as are available. +# It is assumed that the input file was written by psrecord.icn; the +# likelihood of correctly processing anything else is small. +# +############################################################################ + +procedure main(args) + local ifile, ofile, iname, basename, oname, pageno, line, n + + iname := args[1] | stop("usage: ", &progname, " file") + ifile := open(iname) | stop("can't open ", iname) + basename := (iname ? tab(upto('.') | 0)) + + every pageno := seq() do { # read file once for each page + if pageno < 10 then + oname := basename || ".p0" || pageno + else + oname := basename || ".p" || pageno + ofile := open(oname, "w") | stop("can't open ", oname) + + seek(ifile, 1) | stop("can't rewind ", iname) + line := read(ifile) | stop(iname, ": empty file") + line ? ="%!" | stop(iname, ": not a PostScript file") + write(&errout, " writing ", oname) + write(ofile, "%!PS-Adobe-3.0 EPSF-3.0") + + n := 0 + while n < pageno do { # copy to nth "copypage" + line := read(ifile) | break break + if line ? ="copypage" then + n +:= 1 + else + write(ofile, line) + } + write(ofile, "showpage") + write(ofile, "%%EOF") + close(ofile) + } +end diff --git a/ipl/progs/pt.icn b/ipl/progs/pt.icn new file mode 100644 index 0000000..3bb2db9 --- /dev/null +++ b/ipl/progs/pt.icn @@ -0,0 +1,1031 @@ +############################################################################ +# +# File: pt.icn +# +# Subject: Program to produce parse table generator +# +# Author: Deeporn H. Beardsley +# +# Date: December 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# See pt.man for a description of functionality as well as input and +# output format. +# +############################################################################ + +#********************************************************************** +#* * +#* Main procedure as well as * +#* a routine to generate production table, nonterminal, terminal * +#* and epsilon sets from the input grammar * +#********************************************************************** +# +# 1. Data structures:- +# +# E.g. Grammar:- +# +# A -> ( B ) +# A -> B , C +# A -> a +# B -> ( C ) +# B -> C , A +# B -> b +# C -> ( A ) +# C -> A , B +# C -> c +# +# prod_table prod +# __________________ _____ _____ _____ +# | | | num | 1 | | 2 | | 3 | +# | "A" | ------|-->[ |---| ,|---| ,|---| ] +# | | | rhs |_|_| |_|_| |_|_| +# | | | | | v +# | | | | v ["a"] +# | | | v ["B",",","C"] +# | | | ["(","B",")"] +# |_____|__________| _____ _____ _____ +# | | | num | 4 | | 5 | | 6 | +# | "B" | ------|-->[ |---| ,|---| ,|---| ] +# | | | rhs |_|_| |_|_| |_|_| +# | | | | | v +# | | | | v ["b"] +# | | | v ["C",",","A"] +# | | | ["(","C",")"] +# |_____|__________| _____ _____ _____ +# | | | num | 7 | | 8 | | 9 | +# | "C" | ------|-->[ |---| ,|---| ,|---| ] +# | | | rhs |_|_| |_|_| |_|_| +# | | | | | v +# | | | | v ["c"] +# | | | v ["A",",","B"] +# | | | ["(","A",")"] +# ------------------ +# +# __________________ +# firsts | "A" | ------|-->("(", "a", "b", "c") +# |-----|----------| +# | "B" | ------|-->("(", "a", "b", "c") +# |-----|----------| +# | "C" | ------|-->("(", "a", "b", "c") +# ------------------ +# +# _______ +# NTs | ---|-->("A", "B", "C") +# ------- +# +# _______ +# Ts | ---|-->("(", "a", "b", "c") +# ------- +# +# 2. Algorithm:- +# +# get_productions() -- build productions table (& NT, T +# and epsilon sets):- +# open grammar file or from stdin +# while can get an input line, i.e. production, do +# get LHS token and use it as entry value to table +# (very first LHS token is start symbol of grammar) +# (enter token in nonterminal, NT, set) +# get each RHS token & form a list, put this list +# in the list, i.e.assigned value, of the table +# (enter each RHS token in terminal, T, set) +# (if first RHS token is epsilon +# enter LHS token in the epsilon set) +# (T is the difference of T and NT) +# close grammar file +# +#********************************************************************** +global prod_table, NTs, Ts, firsts, stateL, itemL +global StartSymbol, start, eoi, epsilon +global erratta # to list all items in a state (debugging) +record prod(num, rhs) # assigned values for prod_table +record arc(From, To) # firsts computation -- closure +record item(prodN, lhs, rhs1, rhs2, NextI) +record state(C_Set, I_Set, goto) +procedure main(opt_list) + local opt + + start := "START" # start symbol for augmented grammar + eoi := "EOI" # end-of-input token (constant) + epsilon := "EPSILON" # epsilon token (constant) + prod_table := table() # productions + NTs := set() # non-terminals + Ts := set() # terminals + firsts := table() # nonterminals only; first(T) = {T} + get_firsts(get_productions()) + if /StartSymbol then exit(0) # input file empty + write_prods() + if opt := (!opt_list == "-nt") then + write_NTs() + if opt := (!opt_list == "-t") then + write_Ts() + if opt := (!opt_list == "-f") then + write_firsts() + if opt := (!opt_list == "-e") then + erratta := 1 + else + erratta := 0 + stateL := list() # not popped, only for referencing + itemL := list() # not popped, only for referencing + state0() # closure of start production + gotos() # sets if items + p_table() # output parse table +end + +procedure get_productions() + local Epsilon_Set, LHS, first_RHS_token, grammarFile, line, prods, temp_list + local token, ws + + prods := 0 # for enumeration of productions + ws := ' \t' + Epsilon_Set := set() # NT's that have epsilon production + grammarFile := (open("grammar") | &input) + while line := read(grammarFile) do { + first_RHS_token := &null # to detect epsilon production + temp_list := [] # RHS of production--list of tokens + line ? { + tab(many(ws)) + LHS := tab(upto(ws)) # LHS of production--nonterminal + /firsts[LHS] := set() + /StartSymbol := LHS # start symbol for unaug. grammar + insert(NTs, LHS) # collect nonterminals + tab(many(ws)); tab(match("->")); tab(many(ws)) + while put(temp_list, token := tab(upto(ws))) do { + /first_RHS_token := token + insert(Ts, token) # put all RHS tokens into T set for now + tab(many(ws)) + } + token := tab(0) # get last RHS non-ws token + if *token > 0 then { + put(temp_list, token) + /first_RHS_token := token + insert(Ts, token) + } + Ts --:= NTs # set of terminals + delete(Ts, epsilon) # EPSILON is not a terminal + /prod_table[LHS] := [] + put(prod_table[LHS], prod(prods +:=1, temp_list)) + } + if first_RHS_token == epsilon then + insert(Epsilon_Set, LHS) + } + if not (grammarFile === &input) then + close(grammarFile) + return Epsilon_Set +end +#********************************************************************** +#* * +#* Routines to generate first sets * +#********************************************************************** +# 1. Data structures:- +# (see also data structures in mainProds.icn) +# +# __________________ +# needs | "A" | ------|-->[B] +# |-----|----------| +# | "B" | ------|-->[C] +# |-----|----------| +# | "C" | ------|-->[A] +# ------------------ +# +# has_all_1st +# _______ +# | ---|-->("A", "C") +# ------- +# +# +# G |-----------------------| +# | __________________ v +# | | "A" | ------|-->(B)<--------| +# | |-----|----------| | +# |--|--- | ----|-->"A" | +# |-----|----------| | +# | "B" | ------|-->(C)<-----| | +# |-----|----------| | | +# | (C) | ------|-->"B" | | +# |-----|----------| | | +# | "C" | ------|-->(A)<--| | | +# |-----|----------| | | | +# | (A) | ------|-->"C" | | | +# ------------------ | | | +# | | | +# closure_table | | | +# __________________ | | | +# | "A" | ------|-->( ----| ,| ,| ) +# |-----|----------| +# | "B" | ------|-->( as above ) +# |-----|----------| +# | "C" | ------|-->( as above ) +# ------------------ +# +# (Note: G table: the entry values (B) and (C) should be analogous +# to that of '(A)'.) +# +# 2. Algorithms:- +# +# 2.1 Firsts sets (note: A is nonterminal & +# beta is a string of symbols):- +# For definition, see Aho, et al, Compilers... +# Addison-Wesley, 1986, p.188) +# for each production A -> beta (use production table above) +# loop1 +# case next RHS token, B, is +# epsilon : do nothing, break from loop1 +# terminal : insert it in first(A), break from loop1 +# nonterminal: put B in needs[A] table +# if B in epsilon set & last RHS token +# insert A in epsilon set +# break from loop1 +# loop1 +# collect has_all_1st set (NTs whose first is fully defined +# i.e. NTs not entry value of needs table) +# Loop2 (fill_firsts) +# for each NT B in each needs[A] +# if B is in has_all_1st +# insert all elements of first(B) in first(A) +# delete B from needs[A] +# if needs[A] is empty +# insert A in has_all_1st +# if *has_all_1st set equal to *NTs set +# exit loop2 +# if *has_all_1st set not equal to *NTs set +# if *has_all_1st not changed from beginning of loop2 +# (i.e. circular dependency e.g. +# needs[X] = [Y] +# needs[Y] = [Z] +# needs[Z] = [X]) +# find closure of each A +# find a set of A's whose closure sets are same +# pool their firsts together +# add pooled firsts to first set of each A +# goto loop2 +# +# +# This algorithm is implemented by the following procedures:- +# +# get_firsts(Epsilon_Set) -- compute first sets of all +# NTs, given the NTs that have epsilon productions. +# +# fill_firsts(needs) -- given the needs table that says +# which first set contains the elements of other +# first set(s), complete computation of first sets. +# +# buildgraph(tempL) -- given the productions in tempL, +# build table G above. +# +# closure(G, S1, S2) -- given the productions in tempL, +# the entry value S1 and its closure set S2, build +# closure_table. +# +# addnode(n, t) -- given table t ( G, actually), and +# 1. entry value of n, enter its assigned value in +# in table t to be a set (empty, for now) +# 2. use t[n] (in 1) as the entry value, enter its +# assigned value in table t to be "n". +# +# closed_loop(G, SS, closure_table, tempL_i) -- given +# table G, closure_table and a nonterminal tempL_i +# that still needs its firsts completed, return the +# set SS of nonterminals if each and every of these +# nonterminals has identical closure set. +# +# finish_firsts(closed_set) -- given the set closed_set +# of nonterminals where every member of of the set +# has identical closure set, pool the elements +# (terminals) from their so-far known firsts sets +# together and reenter this pooled value into their +# firsts sets (firsts table). +# +# 2.2 Note that buildgraph(), closure() and addnode() +# are either exactly or essentially the same as +# given in class (by R. Griswold). +# +#********************************************************************** + +procedure get_firsts(Epsilon_Set) + local needs, prods, i, j, k, token + + needs := table() + prods := sort(prod_table, 3) + every i := 1 to *prods by 2 do # production(s) of a NT + every j := 1 to *prods[i+1] do # RHS of each production + every k := 1 to *prods[i+1][j].rhs do # and each token + if ((token := prods[i+1][j].rhs[k]) == epsilon) then + break # did in get_productions + else if member(Ts, token) then { # leading token on RHS + insert(firsts[prods[i]], token) # e.g. A -> ( B ) + break + } + else { #if member(NTs, token) then # A -> B a C + /needs[prods[i]] := [] + put(needs[prods[i]], token) + if not (member(Epsilon_Set, token)) then # not B -> EPSILON + break + if k = *prods[i+1][j].rhs then # all RHS tokens are NTs & + insert(Epsilon_Set, prods[i]) # each has epsilon production + } + fill_firsts(needs) # do firsts that contain firsts of other NT(s) + every insert(firsts[!Epsilon_Set], epsilon) # add epsilon last +end + +procedure fill_firsts(needs) + local G, L, NTy, SS, closed_set, closure_table, has_all_1st, i, lhs + local new_temp, rhs, size_has_all_1st, ss, ss_table, tempL, x + + closure_table := table() + has_all_1st := copy(NTs) # set of NTs whose firsts fully defined + tempL := sort(needs, 3) + every i := 1 to *tempL by 2 do + delete(has_all_1st, tempL[i]) + repeat { + ss := "" + ss_table := table() + size_has_all_1st := *has_all_1st + new_temp := list() + while lhs := pop(tempL) do { + rhs := pop(tempL) + L := list() + while NTy := pop(rhs) do + if NTy ~== lhs then + if member(has_all_1st, NTy) then + firsts[lhs] ++:= firsts[NTy] + else + put(L, NTy) + if *L = 0 then + insert(has_all_1st, lhs) + else { + put(new_temp, lhs) + put(new_temp, L) + } + } + tempL := new_temp + if *has_all_1st = *NTs then + break + if size_has_all_1st = *has_all_1st then { + G := buildgraph(tempL) + every i := 1 to *tempL by 2 do + closure_table[tempL[i]] := closure(G, tempL[i]) + every i := 1 to *tempL by 2 do { + closed_set := set() + SS := set([tempL[i]]) + every x := !closure_table[tempL[i]] do + insert(SS, G[x]) + closed_set := closed_loop(G,SS,closure_table,tempL[i]) + if \closed_set then { + finish_firsts(closed_set) + every insert(has_all_1st, !closed_set) + break + } + } + } + } + return +end + +procedure buildgraph(tempL) # modified from the original version + local arclist, nodetable, x, i + + arclist := [] # by Ralph Griswold + nodetable := table() + every i := 1 to *tempL by 2 do { + every x := !tempL[i+1] do { + addnode(tempL[i], nodetable) + addnode(x, nodetable) + put(arclist, arc(tempL[i], x)) + } + } + while x := get(arclist) do + insert(nodetable[x.From], nodetable[x.To]) + return nodetable +end + +procedure closure(G, S1, S2) # modified from the original version + local S + + /S2 := set([G[S1]]) # by Ralph Griswold + every S := !(G[S1]) do + if not member(S2, S) then { + insert(S2, S) + closure(G, G[S], S2) + } + return S2 +end + +procedure addnode(n, t) # author: Ralph Griswold + local S + + if /t[n] then { + S := set() + t[n] := S + t[S] := n + } + return +end + +procedure closed_loop(G, SS, closure_table, tempL_i) + local S, x, y + + delete(SS, tempL_i) + every x := !SS do { + S := set() + every y := !closure_table[x] do + insert(S, G[y]) + delete(S, tempL_i) + if *S ~= *SS then fail + every y := !S do + if not member(SS, y) then fail + } + return insert(SS, tempL_i) +end + +procedure finish_firsts(closed_set) + local S, x + + S := set() + every x := !closed_set do + every insert(S, !firsts[x]) + every x := !closed_set do + every insert(firsts[x], !S) +end +#********************************************************************** +#* * +#* Routines to generate states * +#********************************************************************** +# +# 1. Data structures:- +# +# E.g. Augmented grammar:- +# +# START -> S (production 0) +# S -> ( S ) (production 1) +# S -> ( ) (production 2) +# +# Item is a record of 5 fields:- +# Example of an item: itemL[1] is [START->.S , $] +# prodN represents the production number +# lhs represents the nonterminal at the +# left hand side of the production +# rhs1 represents the list of tokens seen so +# far (i.e. left of the dot in item) +# rhs2 represents the list of tokens yet to be +# seen (i.e. right of the dot in item) +# NextI represents the next input symbol +# (the end of input symbol $ is +# represented by EOI.) +# +# +# item +# _________ _________ +# prodN| 0 | | 1 | +# |-------| |-------| +# lhs |"START"| | "S" | +# _______ |-------| |-------| +# itemL | ---|-->[ rhs1 | ---|---| , | -----|---| , ... ] +# ------- |-------| | |-------| | +# rhs2 | ---|-| | | -----|-| | +# |-------| | | |-------| | | +# NextI| "EOI" | | | | "EOI" | | | +# --------- | | --------- | | +# | | | | +# | | | | +# | v | v +# | [] | [] +# | | +# v v +# ["S"] ["(", "S", ")"] +# +# state +# _______ +# C_Set| ---|-----| +# _______ |-----| | +# stateL | ---|-->[ I_Set| ---|---| | , ... ] +# ------- |-----| | | +# goto | ---|-| | | +# ------- | | | +# | | v +# | | (1, 2, 3) +# | v +# | (1) +# v +# __________________ +# | "A" | 5 | +# |-----|----------| +# | "B" | 2 | +# |-----|----------| +# | "C" | 3 | +# ------------------ +# +# +# (Note: 1. The above 2 lists:- +# -- are not to be popped +# -- new elements are put in the back +# -- index represents the identity of the element +# -- no duplicate elements in either list +# 2. The state record:- +# I_Set represents J in function goto(I,x) in +# Compiler, Aho, et al, Addison-Wesley, 1986, +# p. 232. +# C_Set represents the closure if I_Set. +# goto is part of the goto table and the shift +# actions of the final parse table.) +# 3. The 1 in C_Set and I_Set in the diagrams above refer +# the same (physical) element. +# +# 2. Algorithms:- +# +# state0() -- create itemL[1] and stateL[1] as well as its +# closure. +# +# item_num(P_num, N_lhs, N_rhs1, N_rhs2, NI) -- +# if the item with the values given in the +# argument list already exists in itemL list, +# it returns the index of the item in the list, +# if not, it builds a new item and put it at the +# end of the list and returns the new index. +# +# prod_equal(prod1, prod2) -- prod1 and prod2 are lists of +# strings; fail if they are not the same. +# +# state_closure(st) -- given the item set (I_set of the state +# st), set the value of C_Set of st to the closure +# of this item set. For definition of closure, +# see Aho, et al, Compilers..., Addison-Wesley, +# 1986, pp. 222-224) +# +# new_item(st,O_itm) -- given the state st and an item O_itm, +# suppose the item has the following configuration:- +# [A -> B.CD,x] +# where CD is a string of terminal and nonterminal +# tokens. If C is a nonterminal, +# for each C -> E in the grammar, and +# for each y in first(Dx), add the new item +# [C -> .E,y] +# to the C_Set of st. +# +# all_firsts(itm) -- given an item itm and suupose it has the +# following configuration:- +# [A -> B.CD,x] +# where D is a string of terminal and nonterminal +# tokens. The procedure returns first(Dx). +# +# gotos() -- For definition of goto operation, see Aho, et al, +# Compilers..., Addison-Wesley, 1986, pp. 224-227) +# The C = {closure({[S'->S]})} is set up by the +# state0() +# call in the main procedure. +# +# It also compiles the goto table. The errata part +# (last section of the code in this procedure) is +# for debugging purposes and is left intact for now. +# +# moved_item(itm) -- given the item itm and suppose it has the +# following configuration:- +# [A -> B.CD,x] +# where D is a string of terminal and nonterminal +# tokens. The procedure builds a new item:- +# [A -> BC.D,x] +# It then looks up itemL to see if it already is +# in it. If so, it'll return its index in the list, +# else, it'll put it in the back of the list and +# return this new index. (This is done by calling +# item_num()). +# +# exists_I_Set(test) -- given the I_Set test, look in the stateL +# list and see if any state does contain similar +# I_Set, if so, return its index to the stateL list, +# else fail. +# +# set_equal(set1, set2) -- set1 and set2 are sets of integers; +# return set1 if the two sets have the same elements +# else fail. (It is used strictly in comparison of +# I_Sets). +# +# +#********************************************************************** + +procedure state0() + local itm, st + + itm := item_num(0, start, [], [StartSymbol], eoi) + st := state(set(), set([itm]), table()) + put(stateL, st) + state_closure(st) # closure on initial state +end + +procedure item_num(P_num, N_lhs, N_rhs1, N_rhs2, NI) + local itm, i + + itm := item(P_num, N_lhs, N_rhs1, N_rhs2, NI) + every i := 1 to *itemL do { + if itm.prodN ~== itemL[i].prodN then next + if itm.lhs ~== itemL[i].lhs then next + if not prod_equal(itm.rhs1, itemL[i].rhs1) then next + if not prod_equal(itm.rhs2, itemL[i].rhs2) then next + if itm.NextI == itemL[i].NextI then return i + } + put(itemL, itm) + return *itemL +end + +procedure prod_equal(prod1, prod2) # compare 2 lists of strings + local i + + if *prod1 ~= *prod2 then fail + every i := 1 to *prod1 do + if prod1[i] ~== prod2[i] then fail + return +end + +procedure state_closure(st) + local addset, more_set, i + + st.C_Set := copy(st.I_Set) + addset := copy(st.C_Set) + while *addset > 0 do { + more_set := set() + every i := !addset do + if (itemL[i].rhs2[1] ~== epsilon) then + if member(NTs, itemL[i].rhs2[1]) then + more_set ++:= new_item(st,itemL[i]) + addset := more_set + } +end + +procedure new_item(st,O_itm) + local N_Lhs, N_Rhs1, N_prod, NxtInput, T_itm, i, rtn_set + rtn_set := set() + NxtInput := all_firsts(O_itm) + N_Lhs := O_itm.rhs2[1] + N_Rhs1 := [] + every N_prod := !prod_table[N_Lhs] do + every i := !NxtInput do { + T_itm := item_num(N_prod.num, N_Lhs, N_Rhs1, N_prod.rhs, i) + if not member(st.C_Set, T_itm) then { + insert(st.C_Set, T_itm) + insert(rtn_set, T_itm) + } + } + return rtn_set +end + +procedure all_firsts(itm) + local rtn_set, i + + if *itm.rhs2 = 1 then + return set([itm.NextI]) + rtn_set := set() + every i := 2 to *itm.rhs2 do + if member(Ts, itm.rhs2[i]) then + return insert(rtn_set, itm.rhs2[i]) + else { + rtn_set ++:= firsts[itm.rhs2[i]] + if not member(firsts[itm.rhs2[i]], epsilon) then + return rtn_set + } + return insert(rtn_set, itm.NextI) +end + +procedure gotos() + local New_I_Set, gost, i, i_num, j, j_num, looked_at, scan, st, st_num, x + st_num := 1 + repeat{ + looked_at := set() + scan := sort(stateL[st_num].C_Set) + every i := 1 to *scan do { + i_num := scan[i] + if member(looked_at, i_num) then next + insert(looked_at, i_num) + x := itemL[i_num].rhs2[1] # next LHS + if ((*itemL[i_num].rhs2 = 0) | (x == epsilon)) then next + New_I_Set := set([moved_item(itemL[i_num])]) + every j := i+1 to *scan do { + j_num := scan[j] + if not member(looked_at, j_num) then + if (x == itemL[j_num].rhs2[1]) then { + insert(New_I_Set, moved_item(itemL[j_num])) + insert(looked_at, j_num) + } + } + if gost := exists_I_Set(New_I_Set) then + stateL[st_num].goto[x] := gost #add into goto + else { # add a new state + st := state(set(), New_I_Set, table()) + put(stateL, st) + state_closure(st) + stateL[st_num].goto[x] := *stateL #add into goto + } + } + if erratta=1 then { + write("--------------------------------") + write("State ", st_num-1) + write_state(stateL[st_num]) + } + st_num +:= 1 + if st_num > *stateL then { + if erratta=1 then + write("--------------------------------") + return stateL + } + } +end + +procedure moved_item(itm) + local N_Rhs1, N_Rhs2, i + + N_Rhs1 := copy(itm.rhs1) + put(N_Rhs1, itm.rhs2[1]) + N_Rhs2 := list() + every i := 2 to *itm.rhs2 do + put(N_Rhs2, itm.rhs2[i]) + return item_num(itm.prodN, itm.lhs, N_Rhs1, N_Rhs2, itm.NextI) +end + +procedure exists_I_Set(test) + local st + + every st := 1 to *stateL do + if set_equal(test, stateL[st].I_Set) then return st + fail +end + +procedure set_equal(set1, set2) + local i + + if *set1 ~= *set2 then fail + every i := !set2 do + if not member(set1, i) then fail + return set1 +end +#********************************************************************** +#* * +#* Miscellaneous write routines * +#********************************************************************** +# The following are write routines; some for optional output +# while others are for debugging purposes. +# +# write_item(itm) -- write the contents if item itm. +# write_state(st) -- write the contents of state st. +# write_tbl_list(out) -- (for debugging purposes only). +# write_prods()-- write the enmnerated grammar productions. +# write_NTs() -- write the set of nonterminals. +# write_Ts() -- write the set of terminals. +# write_firsts() -- write the first sets of each nonterminal. +# write_needs(L) -- write the list of all nonterminals and the +# associated nonterminals whose first sets +# it still needs to compute its own first +# set. +# +#********************************************************************** + +procedure write_item(itm) + local i + + writes("[(",itm.prodN,") ",itm.lhs," ->") + every i := !itm.rhs1 do writes(" ",i) + writes(" .") + every i := !itm.rhs2 do writes(" ",i) + writes(", ",itm.NextI,"]\n") +end + +procedure write_state(st) + local i, tgoto + + write("I_Set") + every i := ! st.I_Set do { + writes("Item ", i, " ") + write_item(itemL[i]) + } + write() + write("C_Set") + every i := ! st.C_Set do { + writes("Item ", i, " ") + write_item(itemL[i]) + } + tgoto := sort(st.goto, 3) + write() + write("Gotos") + every i := 1 to *tgoto by 2 do + write("Goto state ", tgoto[i+1]-1, " on ", tgoto[i]) +end + +procedure write_tbl_list(out) + local i, j + + every i := 1 to *out by 2 do { + writes(out[i], ", [") + every j := *out[i+1] do { + if j ~= 1 then + writes(", ") + writes(out[i+1][j]) + } + writes("]\n") + } +end + +procedure write_prods() + local i, j, k, prods + + prods := sort(prod_table, 3) + every i := 1 to *prods by 2 do + every j := 1 to *prods[i+1] do { + writes(right(string(prods[i+1][j].num),3," "),": ") + writes(prods[i], " ->") + every k := 1 to *prods[i+1][j].rhs do + writes(" ", prods[i+1][j].rhs[k]) + writes("\n") + } +end + +procedure write_NTs() + local temp_list + + temp_list := sort(NTs) + write("\n") + write("nonterminal sets are:") + every write(|pop(temp_list)) +end + +procedure write_Ts() + local temp_list + + temp_list := sort(Ts) + write("\n") + write("terminal sets are:") + every write(|pop(temp_list)) +end + +procedure write_firsts() + local temp_list, i, j, first_list + + temp_list := sort(firsts, 3) + write("\nfirst sets:::::") + every i := 1 to *temp_list by 2 do { + writes(temp_list[i], ": ") + first_list := sort(temp_list[i+1]) + every j := 1 to *first_list do + writes(" ", pop(first_list)) + writes("\n\n") + } +end + +procedure write_needs(L) + local i, temp + + write("tempL : ") + every i := 1 to *L by 2 do { + writes(L[i], " ") + temp := copy(L[i+1]) + every writes(|pop(temp)) + writes("\n") + } +end +#********************************************************************** +#* * +#* Output the parse table routines * +#********************************************************************** +# +# p_table() -- output parse table: tablulated (vertical and +# horizontal lines, etc.) if the width is within +# 80 characters long else a listing. +# +# outline(size, out, st_num, T_list, NT_list) -- print the header; +# used in table form. +# +# border(size, T_list, NT_list, col) -- draw a horizontal line +# for the table form, given the table size that tells +# the length of each token given the lists of +# terminals and nonterminals. If the line is the +# last line of the table, col given is "-", else it +# is "-". +# +# outstate(st, out, T_list, NT_list) -- print the shift, reduce +# and goto for state st from information given in +# out, and the lists of terminals and nonterminals; +# used to output the parse table in the listing form. +# +#********************************************************************** + +procedure p_table() + local NT_list, T_list, action, gs, i, itm, msize, out, s, size, st_num, tsize + + T_list := sort(Ts) + put(T_list, eoi) + NT_list := sort(NTs) + size := table() + out := table() + if *stateL < 1000 then msize := 4 + else if *stateL < 10000 then msize := 5 + else msize := 6 + tsize := 7 + every s := !T_list do { + size[s] := *s + size[s] <:= msize + tsize +:= size[s] + 3 + out[s] := s + } + every s := !NT_list do { + size[s] := *s + size[s] <:= msize + tsize +:= size[s] + 3 + out[s] := s + } + write() + write() + write("PARSE TABLE") + write() + if tsize <= 80 then { + outline(size, out, 0, T_list, NT_list) + border(size, T_list, NT_list, "+") + } + every st_num := 1 to *stateL do { + out := table() + gs := sort(stateL[st_num].goto,3) + every i := 1 to * gs by 2 do { # do the shifts and gotos + if member(Ts, gs[i]) then + out[gs[i]] := "S" || string(gs[i+1]-1) # shift (action table) + else + out[gs[i]] := string(gs[i+1]-1) # for goto table + } + every itm := itemL[!stateL[st_num].C_Set] do { + if ((*itm.rhs2 = 0) | (itm.rhs2[1] == epsilon)) then { + if itm.prodN = 0 then + action := "ACC" # accept state + else + action := "R" || string(itm.prodN) # reduce (action table) + if /out[itm.NextI] then + out[itm.NextI] := action + else { # conflict + write(&errout, "Conflict on state ", st_num-1, " symbol ", + itm.NextI, " between ", action, " and ", out[itm.NextI]) + write(&errout, " ", out[itm.NextI], " takes presidence") + } + } + } + if tsize <= 80 then + outline(size, out, st_num, T_list, NT_list) + else + outstate(st_num, out, T_list, NT_list) + } +end + +procedure outline(size, out, st_num, T_list, NT_list) + local s + + if st_num = 0 then + writes("State") + else + writes(right(string(st_num-1),5," ")) + writes(" ||") + every s := !T_list do { + /out[s] := "" + writes(" ", center(out[s],size[s]," "), " |") + } + writes("|") + every s := !NT_list do { + /out[s] := "" + writes(" ", center(out[s],size[s]," "), " |") + } + write() + if st_num < * stateL then + border(size, T_list, NT_list, "+") + else + border(size, T_list, NT_list, "-") +end + +procedure border(size, T_list, NT_list, col) + local s + + writes("------", col, col) + every s := !T_list do + writes("-", center("",size[s],"-"),"-", col) + writes(col) + every s := !NT_list do + writes("-",center("",size[s],"-"), "-", col) + writes("\n") +end + +procedure outstate(st, out, T_list, NT_list) + local s + + write() + write("Actions for state ", st-1) + every s := !T_list do + if \out[s] then + if out[s][1] == "R" then + write(" On ", s, " reduce by production ", out[s][2:0]) + else if out[s][1] == "A" then + write(" On ", s, " ACCEPT") + else + write(" On ", s, " shift to state ", out[s][2:0]) + every s := !NT_list do + if \out[s] then + write(" On ", s, " Goto ", out[s]) + write() +end + diff --git a/ipl/progs/puzz.icn b/ipl/progs/puzz.icn new file mode 100644 index 0000000..363a038 --- /dev/null +++ b/ipl/progs/puzz.icn @@ -0,0 +1,147 @@ +############################################################################ +# +# File: puzz.icn +# +# Subject: Program to create word search puzzle +# +# Author: Chris Tenaglia +# +# Date: February 18, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program creates word search puzzles. +# +############################################################################ + +global matrix, # the actual puzzle board + width, # width of the puzzle + height, # height of the puzzle + completed # number of completed word placements + +procedure main(param) + local i, j, line, pass, tokens, word, words + +# +# initial set up : x=20, y=20 by default +# + width := param[1] | 20 + height := param[2] | 20 + words := [] +# +# load words to place in a space delimited +# file. more than one word per line is ok. +# + while line := map(read()) do + { + tokens := parse(line,' \t') + while put(words,pop(tokens)) + } +# +# get ready for main processing +# + matrix := table(" ") + pass := 0 + completed := 0 + &random:= map(&clock,":","0") +# +# here's the actual word placement rouinte +# + every word := !words do place(word) +# +# fill in the unchosen areas with random alphas +# + every i := 1 to height do + every j := 1 to width do + if matrix[i||","||j] == " " then + matrix[i||","||j] := ?(&ucase) +# +# output results (for the test giver, words are lcase, noise is ucase) +# + write(completed," words inserted out of ",*words," words.\n") + write("\nNow for the puzzle you've been waiting for! (ANSWER)\n") + every i := 1 to height do + { + every j := 1 to width do writes(matrix[i||","||j]," ") + write() + } +# +# output results (for the test taker, everything is upper case +# + write("\fNow for the puzzle you've been waiting for! (PUZZLE)\n") + every i := 1 to height do + { + every j := 1 to width do writes(map(matrix[i||","||j],&lcase,&ucase)," ") + write() + } + end + +# +# this procedure tries to place the word in a copy of the matrix +# if successful the updated copy is moved into the original +# if not, the problem word is skipped after 20 tries +# +procedure place(str) + local byte, construct, direction, item, pass, x, xinc, y, yinc + static xstep,ystep + + initial { + xstep := [0,1,1,1,0,-1,-1,-1] + ystep := [-1,-1,0,1,1,1,0,-1] + } + pass := 0 + + repeat { + if (pass +:= 1) > 20 then + { + write("skipping ",str) + fail + } + direction := ?8 + xinc := integer(xstep[direction]) + yinc := integer(ystep[direction]) + + if xinc < 0 then x := *str + ?(width - *str) + if xinc = 0 then x := ?height + if xinc > 0 then x := ?(width - *str) + + if yinc < 0 then y := *str + ?(height - *str) + if yinc = 0 then y := ?width + if yinc > 0 then y := ?(height - *str) + + if (x < 1) | (y < 1) then stop(str," too long.") + + construct := copy(matrix) + item := str + write("placing ",item) + every byte := !item do + { + if (construct[x||","||y] ~== " ") & + (construct[x||","||y] ~== byte) then break next + construct[x||","||y] := byte + x +:= xinc + y +:= yinc + } + matrix := copy(construct) + completed +:= 1 + return "ok" + } # end repeat + return "ok" + end + +# +# parse a string into a list with respect to a delimiter (cset) +# +procedure parse(line,delims) + local tokens + static chars + + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end diff --git a/ipl/progs/qei.icn b/ipl/progs/qei.icn new file mode 100644 index 0000000..94a939a --- /dev/null +++ b/ipl/progs/qei.icn @@ -0,0 +1,306 @@ +############################################################################ +# +# File: qei.icn +# +# Subject: Program to evaluate Icon expressions interactively +# +# Authors: William H. Mitchell and Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program takes expressions entered at the command line and +# evaluates them. +# +# A semicolon is required to complete an expression. If one is not +# provided, the subsequent line is added to what already has been +# entered. +# +# It is important to know that qei accumulates expressions and evaluates +# all previously entered expressions before it evaluates a new one. +# +# A line beginning with a colon is a command. The commands are: +# +# +# :clear clear the accumulated expressions. +# +# :every generate all the results from the expression; +# otherwise, at most one is produced. +# +# :exit terminate the session +# :quit terminate the session +# +# :list list the accumulated expressions. +# +# :type toggle switch that displays the type of the +# result; the program starts with this switch on. +# +############################################################################ +# +# "qei" is derived from the Latin "quod erat inveniendum" -- "which was +# to be found out". +# +############################################################################ +# +# Requires: co-expressions and system() +# +############################################################################ + +procedure main() + local a, tag, header, incfiles, prog, extras, showtype + local uselines, line, inline, src, files, w, f, Generate, sfile + local curexp, t, rc, sc + + write("Icon Expression Evaluator, Version 1.2, type :? for help") + + if not(&features == "co-expressions") | not(&features == "system function") + then stop("*** This program requires co-expressions ***") + + tag := create "r" || seq() || "_" + + header := [ + "global showtype, showimage, showImage", + "procedure main()", "hwrite := -1; write :=: hwrite", + "hwrites := -1; writes :=: hwrites", + "hread := -1; read :=: hread" + ] + + incfiles := [] + prog := [] + extras := ["write := hwrite", "read := hread", "writes := hwrites"] + showtype := 1 + uselines := [] + + repeat { + line := "" + repeat { + if *uselines ~= 0 then { + inline := get(uselines) + } + else { + writes(if *line = 0 then "> " else "... ") + inline := (read() | shut_down()) + } + + inline := trim(inline, ' \t') + case inline of { + ":type": { + (/showtype := 1) | (showtype := &null) + write("Will ",(/showtype & "not ")|"","display types") + next + } + ":exit" | ":quit": shut_down() + ":clear": { + prog := [] + tag := ^tag # reset variable numbering + next + } + ":list": { + every(write(!prog)) + next + } + ":help" | ":?": { + Help() + next + } + } + inline ? { + if =":edit" then { + src := prog[-1][1:-1] + src := replace(src, "\n#", "\n") + src ? { + tab(upto('(') + 1) & + line := atos(Edit([tab(0)]), "\n") & + break + } + } + else if =":edit all" then { + prog := Edit(prog) + next + } + else if =":link" then { + push(header, inline[2:0] ? tab(upto(';') | 0)) + next + } + else if =":include" then { + inline := replace(inline, ";", "") + inline ? (tab(upto(' \t') + 1) & files := tab(0)) + files := split(files, ', \t') + incfiles |||:= files + next + } + else if =":load" then { + w := split(inline, ' ,\t\'\";') + if f := open(w[2]) then { + while put(uselines, read(f)) + close(f) + next + } + else { + write("*** cannot open ", image(w[2])) + next + } + } + } + + line ||:= inline || "\n" + if line[-2:0] == ";\n" then { + line[-2:0] := "" + break + } + } + + if \showtype then + put(extras, "showtype := 1") + + if line ?:= (=":every " & tab(0)) then Generate := 1 + + sfile := open("qei_.icn","w") + + every write(sfile, !(header | prog | extras)) + + curexp := (t :=@tag) || " := (" || line || ")" + + if \Generate then { + write(sfile, "every WR(\"\",", curexp, ")") + } + else { + write(sfile, "if (", curexp, ") then WR(\"", t, " := \",", t, ")") + write(sfile, "else write(\"Failure\")") + } + + write(sfile, "end") + + WriteWR(sfile) + + close(sfile) + +$ifdef _MS_WINDOWS + sc := system("wicont -s qei_.icn " || atos(incfiles, " ")) +$else + sc := system("icont -s qei_.icn " || atos(incfiles, " ")) +$endif + if sc = 0 then rc := system("qei_") + + if sc = 0 & rc = 0 then + put(prog, curexp) + else + put(prog, "#" || replace(curexp, "\n", "\n#")) + + extras := ["write := hwrite", "read := hread", "writes := hwrites"] + + Generate := &null + + } + +end + +procedure WriteWR(f) + write(f, "procedure WR(tag, e)") + write(f, "writes(\" \",tag, image(e))") + write(f, "\twrite(if \\showtype then \" (\"|| type(e)|| \")\" else \"\")") + write(f, "end"); + +end + +procedure Help() + + write("Enter any Icon expression to evaluate it") + write() + write(":edit -- edit last expression") + write(":edit all -- edit the list of expressions") + write(":every <expression> -- show generated results for expresion") + write(":exit or :quit -- exit qei") + write(":help or :? -- print this message") + write(":include <files>, e.g. :include \"x.icn\" -- include Icon files") + write(":limit <n> -- limit results of :every to <n>") + write(":link <files>, e.g. link image -- link ucode files") + write(":list -- list expressions") + write(":load <file>, e.g. :load x -- load expressions from the file x") + write(":type -- toggle display of type") + + return + +end + +procedure Edit(p) + local f + + f := open("qei_.icn", "w") | stop("*** cannot open program file") + + every write(f, !p) + + close(f) + + system("$EDITOR qei_.icn") + + f := open("qei_.icn") | stop("*** cannot re-open program file") + + p := [] + + while put(p, read(f)) + + return p + +end + +procedure atos(a,delim) + local e, s + + s := "" + /delim := "," + + every e := !a do + (/s := e) | (s ||:= delim || e) + + return s + +end + +# +# replace string (from the IPL) +# +procedure replace(s1,s2,s3) + local result, i + + result := "" + i := *s2 + + s1 ? { + while result ||:= tab(find(s2)) do { + result ||:= s3 + move(i) + } + return result || tab(0) + } + +end + +procedure split(line,dlms) + local w + + /dlms := ' \t' + w := [] + + line ? repeat { + tab(upto(~dlms)) + put(w, tab(many(~dlms))) | break + } + + return w + +end + +procedure shut_down() + + remove("qei_") + remove("qei_.icn") + + exit() + +end diff --git a/ipl/progs/qt.icn b/ipl/progs/qt.icn new file mode 100644 index 0000000..ab9723a --- /dev/null +++ b/ipl/progs/qt.icn @@ -0,0 +1,47 @@ +############################################################################ +# +# File: qt.icn +# +# Subject: Program to announce time in English +# +# Author: Robert J. Alexander +# +# Date: November 26, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: qt [-a] +# +# If -a is present, only the time is printed (for use in scripts), e.g.: +# +# just after a quarter to three +# +# otherwise, the time is printed as a sentence: +# +# It's just after a quarter to three. +# +############################################################################ +# +# Links: datetime +# +############################################################################ + +link datetime + +procedure main(arg) + local pre,suf + if arg[1] == "-a" then { + pop(arg) + pre := suf := "" + } + else { + pre := "It's " + suf := "." + } + arg[1] | put(arg) + every write(pre,saytime(!arg),suf) +end diff --git a/ipl/progs/queens.icn b/ipl/progs/queens.icn new file mode 100644 index 0000000..a9d2144 --- /dev/null +++ b/ipl/progs/queens.icn @@ -0,0 +1,103 @@ +############################################################################ +# +# File: queens.icn +# +# Subject: Program to generate solutions to the n-queens problem +# +# Author: Stephen B. Wampler +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/ranstars.icn b/ipl/progs/ranstars.icn new file mode 100644 index 0000000..21c0c53 --- /dev/null +++ b/ipl/progs/ranstars.icn @@ -0,0 +1,92 @@ +############################################################################ +# +# File: ranstars.icn +# +# Subject: Program to display star field +# +# Author: Ralph E. Griswold +# +# Date: March 2, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program display a random field of "stars" on an ANSI terminal. +# It displays stars at randomly chosen positions on the screen until +# the specified maximum number is reached. It then extinguishes existing +# stars and creates new ones for the specified steady-state time, after +# which the stars are extinguished, one by one. +# +# The programming technique is worth noting. It is originally due to +# Steve Wampler. +# +# The options are: +# +# -m n maximum number of stars, default 10. +# +# -t n length of steady-state time before stars are extinguished, +# default 50. +# +# -s c the character to be used for "stars", default *. If +# more than one character is given, only the first is +# used. +# +############################################################################ +# +# Requires: co-expressions, ANSI terminal +# +############################################################################ +# +# Links: ansi, options, random +# +############################################################################ + +link ansi +link options +link random + +procedure main(args) + local length, steady, star, opts, r, ran1, ran2 + + randomize() + + opts := options(args,"m+t+s:") + length := \opts["m"] | 10 + steady := \opts["t"] | 50 + star := \opts["s"] | "*" + star := star[1] + r := 0 + + ran1 := create 2(&random :=: r, |?(24 | 80), &random <-> r) + ran2 := ^ran1 + clear() # clear the screen + every 1 to length do # start up the universe + place(ran1,star) + every 1 to steady do { # steady state condition + place(ran2," ") # clean up the beginning + place(ran1,star) # create more + } + every 1 to length do # and the universe dies + place(ran2," ") # clean up the end + clear() # clear the screen + home() # home the cursor +end + +procedure clear() + ED() + return +end + +procedure home() + CUP(1,1) + return +end + +procedure place(e,s) + CUP(@e,@e) + writes(s) + return +end diff --git a/ipl/progs/rcat.icn b/ipl/progs/rcat.icn new file mode 100644 index 0000000..a655695 --- /dev/null +++ b/ipl/progs/rcat.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: rcat.icn +# +# Subject: Program to output a file from back to front +# +# Author: Gregg M. Townsend +# +# Date: March 7, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program outputs in reverse order the lines of one or more files. +# Unlike some versions of "tail -r", the input file does not need to +# fit in memory; but it must be seekable. +# +# usage: rcat file... +# +############################################################################ + +$define BUFSIZE 65536 + +procedure main(args) + local f, fname, len, i, nseg, buf, leftover, lines + + if *args = 0 then + stop("usage: ", &progname, " file...") + + every fname := !args do { + + lines := [] + leftover := "" + f := open(fname, "u") | stop("cannot open ", fname) + len := where(seek(f, 0)) - 1 | stop("cannot seek ", fname) + nseg := (len + BUFSIZE - 1) / BUFSIZE + + every i := nseg - 1 to 0 by -1 do { + seek(f, 1 + BUFSIZE * i) + (reads(f, BUFSIZE) || leftover) ? { + leftover := tab(upto('\n') + 1 | 0) + while push(lines, tab(upto('\n') + 1)) + if not pos(0) then + push(lines, tab(0)) + } + while writes(get(lines)) + } + + writes(leftover) + } +end diff --git a/ipl/progs/recgen.icn b/ipl/progs/recgen.icn new file mode 100644 index 0000000..ce47878 --- /dev/null +++ b/ipl/progs/recgen.icn @@ -0,0 +1,169 @@ +############################################################################ +# +# File: recgen.icn +# +# Subject: Program to generate context-free recognizer +# +# Author: Ralph E. Griswold +# +# Date: January 28, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads a context-free BNF grammar and produces an Icon +# program that is a recognizer for the corresponding language. +# +# Nonterminal symbols are are enclosed in angular brackets. Vertical +# bars separate alternatives. All other characters are considered to +# be terminal symbols. The nonterminal symbol on the first line is +# taken to be the goal. +# +# An example is: +# +# <expression>::=<term>|<term>+<expression> +# <term>::=<element>|<element>*<term> +# <element>::=x|y|z|(<expression>) +# +# Characters in nonterminal names are limited to letters and underscores. +# An underscore is appended for the recognizing procedure name to avoid +# possible collisions with Icon function names. +# +# Lines beginning with an = are passed through unchanged. This allows +# Icon code to be placed in the recognizer. +# +############################################################################ +# +# 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 or for duplicate definitions. +# +############################################################################ +# +# Reference: +# +# The Icon Programming Language, Second Edition, Ralph E. and Madge T. +# Griswold, Prentice-Hall, 1990. pp. 180-187. +# +############################################################################ +# +# See also: pargen.icn +# +############################################################################ + +global call # name suffix and parens +global goal # nonterminal goal name +global nchars # characters allowed in a nonterminal name + +procedure main() + local line # a line of input + + call := "_()" + nchars := &letters ++ '_' + + while line := read() do { # process lines of input + line ? { + case move(1) of { # action depends on first character + "<": tab(0) ? transprod() # transform the production + "=": write(tab(0)) # pass through + default: error() + } # end case + } # end scan + } # end while + + write("procedure main()") # write out the main procedure + write(" while line := read() do {") + write(" writes(image(line))") + write(" if line ? (",goal,call," & pos(0)) then ") + write(" write(\": accepted\")") + write(" else write(\": rejected\")") + write(" }") + write("end") + +end + +# +# Transform a production. +# + +procedure transprod() + local sym # the symbol being defined + + { + # begin the procedure declaration + write("procedure ",sym := tab(many(nchars)),call) & + =">::=" # skip definition symbols + } | error() # catch syntactic error + write(" suspend {") # begin the suspend expression + transalts() # transform the alternatives + write(" }") # end the suspend expression + write("end") # end the procedure declaration + write() # space between declarations + /goal := sym # first symbol is goal + +end + +# +# Transform a sequence of alternatives. +# +procedure transalts() + local alt # an alternative + + writes(" ") # write indentation + while alt := tab(upto('|') | 0) do { # process alternatives + writes(" (") # open parenthesis for alternative + alt ? transseq() # transform the symbols + if move(1) then writes(") |") # if there's more, close the parentheses + # and add the alternation. + else { + write(")") # no more, so just close the parentheses + break + } # end else + } # end while + +end + +# +# Transform a sequence of symbols. +# +procedure transseq() + + repeat { + transsym() # process a symbols + if not pos(0) then writes(",") # if there's more, provide concatenation + else break # else get out and return + } # end while + +end + +# +# Transform a symbol. +# +procedure transsym() + + if ="<" then { # if it's a nonterminal + { # write it with suffix. + writes(tab(many(nchars)),call) & + =">" # get rid of closing bracket + } | error() # or catch the error + } # end then + # otherwise transform nonterminal string + else writes("=",image(tab(upto('<') | 0))) + + return + +end + +# +# Issue error message and terminate execution. +# +procedure error() + + stop("*** malformed definition: ",tab(0)) + +end diff --git a/ipl/progs/repeats.icn b/ipl/progs/repeats.icn new file mode 100644 index 0000000..5a272ed --- /dev/null +++ b/ipl/progs/repeats.icn @@ -0,0 +1,48 @@ +############################################################################ +# +# File: repeats.icn +# +# Subject: Program to repeat stream +# +# Author: Ralph E. Griswold +# +# Date: January 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program repeat the input stream. The following options are +# supported: +# +# -l i limit on length of input stream; default 1000. +# -r i number of time input stream is repeated; default no limit. +# +# Note that the input stream must be limited, since it is stored internally. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, limit, repeats, values + + opts := options(args, "l+r+") + + limit := \opts["l"] | 1000 + repeats := \opts["2"] | (2 ^ 20) # kludge ... + + values := [] + + every put(values, !&input) \ limit + + every 1 to repeats do + every write(!values) + +end diff --git a/ipl/progs/reply.icn b/ipl/progs/reply.icn new file mode 100644 index 0000000..e919650 --- /dev/null +++ b/ipl/progs/reply.icn @@ -0,0 +1,115 @@ +############################################################################ +# +# File: reply.icn +# +# Subject: Program to reply to news-articles or mail +# +# Author: Ronald Florence +# +# Date: March 8, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.4 +# +############################################################################ +# +# This program creates the appropriate headers and attribution, +# quotes a news or mail message, and uses system() calls to put the +# user in an editor and then to mail the reply. The default prefix +# for quoted text is ` > '. +# +# usage: reply [prefix] < news-article or mail-item +# +# If a smarthost is defined, Internet addresses are converted to bang +# paths (name@site.domain -> site.domain!name). The mail is routed +# to a domained smarthost as address@smarthost.domain, otherwise to +# smarthost!address. +# +# The default editor can be overridden with the EDITOR environment variable. +# +############################################################################ + +procedure main(arg) + local smarthost, editor, console, tmpdir, tmpfile, reply, fullname + local address, quoter, date, id, subject, newsgroup, refs, edstr, stdin + local mailstr + + smarthost := "" + editor := "vi" + + if find("UNIX", &features) then { + console := "/dev/tty" + tmpdir := "/tmp/" + } + else if find("MS-DOS", &features) then { + console := "CON" + tmpdir := "" + } + (\console & \tmpdir) | stop("reply: missing system information") + + every tmpfile := tmpdir || "reply." || right(1 to 999,3,"0") do + close(open(tmpfile)) | break + reply := open(tmpfile, "w") | stop("reply: cannot write temp file") + + # Case-insensitive matches for headers. + every !&input ? { + tab(match("from: " | "reply-to: ", map(&subject))) & { + if find("<") then { + fullname := tab(upto('<')) + address := (move(1), tab(find(">"))) + } + else { + address := trim(tab(upto('(') | 0)) + fullname := (move(1), tab(find(")"))) + } + while match(" ", \fullname, *fullname) do fullname ?:= tab(-1) + quoter := if *\fullname > 0 then fullname else address + } + tab(match("date: ", map(&subject))) & date := tab(0) + tab(match("message-id: ", map(&subject))) & id := tab(0) + match("subject: ", map(&subject)) & subject := tab(0) + match("newsgroups: ", map(&subject)) & newsgroup := tab(upto(',') | 0) + match("references: ", map(&subject)) & refs := tab(0) + (\address & *&subject = 0) & { + \subject & write(reply, subject) + \newsgroup & write(reply, newsgroup) + \refs & write(reply, refs, " ", id) + write(reply, "In-reply-to: ", quoter, "'s message of ", date); + write(reply, "\nIn ", id, ", ", quoter, " writes:\n") + break + } + } + + every write(reply, \arg[1] | " > ", !&input) + edstr := (getenv("EDITOR") | editor) || " " || tmpfile || " < " || console + system(edstr) + stdin := open(console) + writes("Send y/n? ") + upto('nN', read(stdin)) & { + writes("Save your draft reply y/n? ") + if upto('yY', read(stdin)) then + stop("Your draft reply is saved in ", tmpfile) + else { + remove(tmpfile) + stop("Reply aborted.") + } + } + + (*smarthost > 0) & not find(map(smarthost), map(address)) & { + find("@", address) & address ? { + name := tab(upto('@')) + address := (move(1), tab(upto(' ') | 0)) || "!" || name + } + if find(".", smarthost) then address ||:= "@" || smarthost + else address := smarthost || "!" || address + } + mailstr := "mail " || address || " < " || tmpfile + system(mailstr) + write("Reply sent to " || address) + remove(tmpfile) +end diff --git a/ipl/progs/repro.icn b/ipl/progs/repro.icn new file mode 100644 index 0000000..c1d8264 --- /dev/null +++ b/ipl/progs/repro.icn @@ -0,0 +1,27 @@ +############################################################################ +# +# File: repro.icn +# +# Subject: Program to self-reproduce +# +# Author: Kenneth Walker +# +# Date: August 4, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program generates the shortest known self-reproducing Icon +# program. The generated program is identical to this file except +# for deletion of this header and the "global x" declaration, which +# appear here so that the Icon library builds cleanly. +# +############################################################################ + +global x + +procedure main();x:="procedure main();x:= \nx[21]:=image(x);write(x);end" +x[21]:=image(x);write(x);end diff --git a/ipl/progs/revfile.icn b/ipl/progs/revfile.icn new file mode 100644 index 0000000..d111bc7 --- /dev/null +++ b/ipl/progs/revfile.icn @@ -0,0 +1,31 @@ +############################################################################ +# +# File: revfile.icn +# +# Subject: Program to reverse the order of lines in a file +# +# Author: Ralph E. Griswold +# +# Date: August 11, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reverses the order of lines in a file. Beware of large +# files. +# +############################################################################ + +procedure main() + local lines + + lines := [] + + every push(lines, !&input) + + every write(!lines) + +end diff --git a/ipl/progs/revsort.icn b/ipl/progs/revsort.icn new file mode 100644 index 0000000..2b55c4d --- /dev/null +++ b/ipl/progs/revsort.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: revsort.icn +# +# Subject: Program to sort strings backwards +# +# Author: Ralph E. Griswold +# +# Date: September 5, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program sorts strings with characters in reverse order. +# +############################################################################ + +procedure main() + local terms + + terms := [] + + while put(terms, reverse(read())) + + terms := sort(terms) + + while write(reverse(get(terms))) + +end diff --git a/ipl/progs/roffcmds.icn b/ipl/progs/roffcmds.icn new file mode 100644 index 0000000..bfeb153 --- /dev/null +++ b/ipl/progs/roffcmds.icn @@ -0,0 +1,59 @@ +############################################################################ +# +# File: roffcmds.icn +# +# Subject: Program to list roff commands and macros +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/rsg.icn b/ipl/progs/rsg.icn new file mode 100644 index 0000000..747e78b --- /dev/null +++ b/ipl/progs/rsg.icn @@ -0,0 +1,391 @@ +############################################################################ +# +# File: rsg.icn +# +# Subject: Program to generate randomly selected sentences +# +# Author: Ralph E. Griswold +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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. +# +# -r In the absence of -s, set the seed to 0 for repeatable +# results. Otherwise the seed is set to a different value +# for each run (as far as this is possible). -r is equivalent +# to -s 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, random +# +############################################################################ + +link options +link random + +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+r") + limit := \opts["l"] | 1000 + tswitch := \opts["t"] + &random := \opts["s"] + if /opts["s"] & /opts["r"] then randomize() + + 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 diff --git a/ipl/progs/ruler.icn b/ipl/progs/ruler.icn new file mode 100644 index 0000000..9561de5 --- /dev/null +++ b/ipl/progs/ruler.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: ruler.icn +# +# Subject: Program to write a character ruler +# +# Author: Robert J. Alexander +# +# Date: December 5, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/sample.icn b/ipl/progs/sample.icn new file mode 100644 index 0000000..16b283a --- /dev/null +++ b/ipl/progs/sample.icn @@ -0,0 +1,30 @@ +############################################################################ +# +# File: sample.icn +# +# Subject: Program to "sample" input stream +# +# Author: Ralph E. Griswold +# +# Date: January 21, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program filters the input stream, producing every ith +# value, starting at 1. i is given as a command-line argument; default 0. +# +############################################################################ + +procedure main(args) + local line, skip + + skip := integer(args[1]) | 0 + + while write(read()) do + every 1 to skip do read() + +end diff --git a/ipl/progs/scale.icn b/ipl/progs/scale.icn new file mode 100644 index 0000000..a88224b --- /dev/null +++ b/ipl/progs/scale.icn @@ -0,0 +1,37 @@ +############################################################################ +# +# File: scale.icn +# +# Subject: Program to scale numeric values in visualization stream +# +# Author: Ralph E. Griswold +# +# Date: January 20, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program scales the numerical channel of a visualization stream. +# It leaves color channel alone, if there is one. Scale factor is +# given on command line; default 10. +# +# Note: This program can be used on a numerical stream. +# +############################################################################ + +procedure main(args) + local factor, line, i + + factor := \args[1] | 10 + + while line := read() do { + line ? { + i := tab(upto(' \t') | 0) + write(i * factor, tab(0)) + } + } + +end diff --git a/ipl/progs/scramble.icn b/ipl/progs/scramble.icn new file mode 100644 index 0000000..2dc4791 --- /dev/null +++ b/ipl/progs/scramble.icn @@ -0,0 +1,93 @@ +############################################################################ +# +# File: scramble.icn +# +# Subject: Program to scramble a document +# +# Author: Chris Tenaglia +# +# Date: June 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program takes a document and re-outputs it in a cleverly +# scrambled fashion. It uses the next two most likely words to +# to follow. +# +# The concept was found in a recent Scientific American and Icon +# seemed to offer the best implementation. +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +global vocab,index + +procedure main() + local line, i, n, word, follows + + vocab:= [] + index:= table([]) + while line := read() do + { + vocab |||:= parse(line,' ') + } + + every i := 1 to *vocab-2 do index[vocab[i]] |||:= [i] + index[vocab[-2]] |||:= [-2] # wrap end to front in order to + index[vocab[-1]] |||:= [-1] # prevent stuck loop if last word chosen + + n := -1 ; + randomize() + line := "" + every 1 to *vocab/2 do + { + (n > 1) | (n := ?(*vocab-2)) + word := vocab[n] + follows := vocab[(?(index[word]))+1] + n := (?(index[follows])) + 1 + if (*line + *word + *follows + 2) > 80 then + { + write(line) + line := "" + } + line ||:= word || " " || follows || " " + } + write(line,".") + end + +# +# This procedure pulls all the elements (tokens) out of a line +# buffer and returns them in a list. A variable named chars +# can be statically defined here or global. It is a cset that +# contains the valid characters that can compose the elements +# one wishes to extract. +# + +procedure parse(line,delims) + local tokens + static chars + + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end + +# +# This procedure is terribly handy in prompting and getting +# an input string +# + +procedure input(prompt) + writes(prompt) + return read() + end diff --git a/ipl/progs/setmerge.icn b/ipl/progs/setmerge.icn new file mode 100644 index 0000000..b12598d --- /dev/null +++ b/ipl/progs/setmerge.icn @@ -0,0 +1,70 @@ +############################################################################ +# +# File: setmerge.icn +# +# Subject: Program to combine sets of text items +# +# Author: Gregg M. Townsend +# +# Date: May 31, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Setmerge combines sets of items according to the specified operators. +# Sets are read from files, one entry per line. Operation is from left +# to right without any precedence rules. After all operations are +# complete the resulting set is sorted and written to standard output. +# +# Usage: setmerge file [[op] file]... +# +# Operations: +# + add contents to set +# - subtract contents from set +# * intersect contents with set +# +# Note that operators must be separate command options, and that some +# shells my require some of them to be quoted. +# +# Example 1: combine files, sorting and eliminating duplicates: +# +# setmerge file1 + file2 + file3 + file4 +# +# Example 2: print lines common to three files +# +# setmerge file1 '*' file2 '*' file3 +# +# Example 3: print lines in file1 or file2 but not in file3 +# +# setmerge file1 + file2 - file3 +# +############################################################################ + + +procedure main(args) + local items, a, op, f, s + + items := set() + op := "+" + every a := !args do { + if *a = 1 & any('+-*', a) then { + op := a + } + else { + f := open(a) | stop("can't open ", a) + case op of { + "+": every insert(items, !f) + "-": every delete(items, !f) + "*": { + s := set() + every insert(s, member(items, !f)) + items := s + } + } + } + } + every write(!sort(items)) +end diff --git a/ipl/progs/shar.icn b/ipl/progs/shar.icn new file mode 100644 index 0000000..44b0254 --- /dev/null +++ b/ipl/progs/shar.icn @@ -0,0 +1,62 @@ +############################################################################ +# +# File: shar.icn +# +# Subject: Program to create UNIX shell archive +# +# Author: Robert J. Alexander +# +# Date: May 6, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to create Bourne shell archive of text files. +# +# Usage: shar text_file... +# +############################################################################ + +procedure main(arg) + local fn, chars, f, line + + write( + "#! /bin/sh_ + \n# This is a shell archive, meaning:_ + \n# 1. Remove everything above the #! /bin/sh line._ + \n# 2. Save the resulting text in a file._ + \n# 3. Execute the file with /bin/sh (not csh) to create:") + every write("#\t",!arg) + write( + "# This archive created: ",&dateline, + "\nexport PATH; PATH=/bin:/usr/bin:$PATH") + every fn := !arg do { + chars := 0 + f := open(fn) | stop("Can't open \",fn,"\"") + write( + "if test -f '",fn,"'_ + \nthen_ + \n\techo shar: \"will not over-write existing file '",fn,"'\"_ + \nelse_ + \ncat << \\SHAR_EOF > '",fn,"'") + while line := read(f) do { + write(line) + chars +:= *line + 1 + } + write( + "SHAR_EOF_ + \nif test ",chars," -ne \"`wc -c < '",fn,"'`\"_ + \nthen_ + \n\techo shar: \"error transmitting '",fn,"'\" '(should have been ", + chars," characters)'_ + \nfi_ + \nfi") + close(f) + } + write( + "exit 0_ + \n#\tEnd of shell archive") +end diff --git a/ipl/progs/shortest.icn b/ipl/progs/shortest.icn new file mode 100644 index 0000000..d73adc4 --- /dev/null +++ b/ipl/progs/shortest.icn @@ -0,0 +1,44 @@ +############################################################################ +# +# File: shortest.icn +# +# Subject: Program to write shortest line in a file +# +# Author: Ralph E. Griswold +# +# Date: November 25, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes the (last) shortest line in the input file. If the +# command-line option -# is given, the number of the shortest line is +# written first. +# +############################################################################ + +procedure main(argl) + local shortest, min, count, countl, number, line + + if argl[1] == "-#" then number := 1 + + shortest := read() | exit() + count := 1 + min := *shortest + + every line := !&input do { + count +:= 1 + if *line <= min then { + min := *line + shortest := line + countl := count + } + } + + if \number then write(countl) + write(shortest) + +end diff --git a/ipl/progs/shuffile.icn b/ipl/progs/shuffile.icn new file mode 100644 index 0000000..dca8e8b --- /dev/null +++ b/ipl/progs/shuffile.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: shuffile.icn +# +# Subject: Program to shuffle lines in a file +# +# Author: Ralph E. Griswold +# +# Date: May 12, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 +# +# The following options are supported: +# +# -s i Set random seed to i; default 0 +# -r Set random seed using randomize(); overrides -s +# +# 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, random +# +############################################################################ + +link options +link random + +procedure main(args) + local opts, L + + opts := options(args, "rs+") + &random := \opts["s"] + if \opts["r"] then randomize() + + L := [] + every put(L, !&input) + every write(!shuffle(L)) +end diff --git a/ipl/progs/shuffle.icn b/ipl/progs/shuffle.icn new file mode 100644 index 0000000..ad774e7 --- /dev/null +++ b/ipl/progs/shuffle.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: shuffle.icn +# +# Subject: Program to randomly reorder the lines of a file +# +# Author: Gregg M. Townsend +# +# Date: December 10, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program outputs in random order the lines of one or more files. +# The input data must fit in memory. +# +# usage: shuffle [file...] +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +procedure main(args) + local data, fname, f + + randomize() + data := [] + if *args = 0 then + while put(data, read()) + else + every fname := !args do { + f := open(fname, "u") | stop("cannot open ", fname) + while put(data, read(f)) + close(f) + } + shuffle(data) + every write(!data) +end diff --git a/ipl/progs/sing.icn b/ipl/progs/sing.icn new file mode 100644 index 0000000..02015c8 --- /dev/null +++ b/ipl/progs/sing.icn @@ -0,0 +1,99 @@ +############################################################################ +# +# File: sing.icn +# +# Subject: Program to sing The Twelve Days of Christmas +# +# Author: Frank J. Lhota +# +# Date: September 14, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is an Icon adaptation of a SNOBOL program by Mike +# Shapiro in the book The SNOBOL4 Programming Language. The procedure +# sing writes the lyrics to the song, "The Twelve Days of Christmas" +# to the singer parameter. "singer" can be any file open for output, +# but it would be especially nice to send the lyrics to a speech +# synthesiser (perhaps via a pipe). +# +# The algorithm used can be adapted to other popular songs, such as +# "Old McDonald had a Farm". +# +# Reference: +# +# "The SNOBOL 4 Programming Language" by Griswold, Poage, and +# Polonsky, 2nd ed. Englewood Cliffs, N.J. Prentiss-Hall, Inc. 1971. +# +# +############################################################################ + +procedure sing(singer) + + local which, and + static day, gift + + initial { + day := [ + "first", + "second", + "third", + "fourth", + "fifth", + "sixth", + "seventh", + "eighth", + "ninth", + "tenth", + "eleventh", + "twelfth"] + + gift := [ + "twelve lords a'leaping,", + "eleven ladies dancing,", + "ten pipers piping,", + "nine drummers drumming,", + "eight maids a'milking,", + "seven swans a'swimming,", + "six geese a'laying,", + "five golden rings,", + "four colly birds,", + "three french hens,", + "two turtle doves,", + "a partridge in a pear tree."] + } + + every which := 1 to 12 do { + write (singer) # Take a breath + write (singer, "On the ", day [which], " day of Christmas,") + write (singer, "my true love gave to me,") + every write (singer, !(gift[-which : 0])) + + if (/and := "and ") then gift[-1] := and || gift[-1] + } + + # + # Reset gift[-1] in case sing is called again. + # + + gift[-1] ?:= (=and & tab (0)) + + return + +end + +############################################################################ + +procedure main () + + # + # Try out sing procedure with standard output. + # + + sing(&output) + +end diff --git a/ipl/progs/slice.icn b/ipl/progs/slice.icn new file mode 100644 index 0000000..d00048b --- /dev/null +++ b/ipl/progs/slice.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: slice.icn +# +# Subject: Program to write long line as multiple short lines +# +# Author: Ralph E. Griswold +# +# Date: June 27, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The maximum line length is given on the command line, as in +# +# slice 60 < foo > baz +# +############################################################################ + +procedure main(args) + local i, line + + i := args[1] | 60 + integer(i) | stop("*** invalid argument") + + while line := read() do + line ? { + while write(move(i)) + if not pos(0) then write(tab(0)) + } + +end diff --git a/ipl/progs/snake.icn b/ipl/progs/snake.icn new file mode 100644 index 0000000..60186eb --- /dev/null +++ b/ipl/progs/snake.icn @@ -0,0 +1,248 @@ +############################################################################ +# +# File: snake.icn +# +# Subject: Program to play the snake game +# +# Author: Richard L. Goerwitz +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.9 +# +############################################################################ +# +# While away the idle moments watching the snake eat blank squares +# on your screen. Snake has only one (optional) argument - +# +# usage: snake [character] +# +# where "character" represents a single character to be used in drawing +# the snake. The default is an "o." In order to run snake, your ter- +# minal must have cursor movement capability, and must be able to do re- +# verse video. +# +# I wrote this program to test itlib.icn, iscreen.icn, and some +# miscellaneous utilities I wrote. It clears the screen, moves the cur- +# sor to arbitrary squares on the screen, changes video mode, and in +# general exercises the terminal capability database on the target ma- +# chine. +# +############################################################################ +# +# Bugs: Most magic cookie terminals just won't work. Terminal really +# needs reverse video (it will work without, but won't look as cute). +# +############################################################################ +# +# Requires: UNIX (MS-DOS is okay, if you replace itlib with itlibdos.icn) +# +############################################################################ +# +# Links: itlib, iscreen, random +# +############################################################################ + +link itlib +link iscreen +link random + +global max_l, max_w, snake_char + +record wholething(poop,body) + +procedure main(a) + + local snake, limit, sl, sw, CM, x, r, leftbehind + + randomize() + + if not (getval("so"), CM := getval("cm")) + then stop("snake: Your terminal is too stupid to run me. Sorry.") + clear(); Kludge() # if your term likes it, use emphasize(); clear() + # Decide how much space we have to operate in. + max_l := getval("li")-2 # global + max_w := getval("co")-1 # global + # Determine the character that will be used to represent the snake. + snake_char := (\a[1])[1] | "o" + + # Make the head. + snake := []; put(snake,[?(max_l-1)+1, ?(max_w-1)+1]) + # Make the body, displaying it as it grows. + every x := 2 to 25 do { + display(,snake) + put(snake,findnext(snake[x-1],snake)) + } + + # Begin "eating" all the standout mode spaces on the screen. + repeat { + r := makenew(snake) + leftbehind := r.poop + snake := r.body + display(leftbehind,snake) | break + } + + # Shrink the snake down to nothing, displaying successively smaller bits. + while leftbehind := get(snake) + do display(leftbehind,snake) + + iputs(igoto(getval("cm"), 1, getval("li")-1)) + normal() + +end + + + +procedure findnext(L, snake) + + local i, j, k, op, l + static sub_lists + initial { + sub_lists := [[1,2,3], [1,3,2], [3,2,1], [3,1,2], [2,1,3], [2,3,1]] + } + # global max_l, max_w + + i := L[1]; j := L[2] # for clarity, use i, j (not l[i|j]) + + # L is the last snake segment; find k and l, such that k and l are + # valid line and column numbers differing from l[1] and l[2] by no + # more than 1, respectively. Put simply: Create a new segment + # [k, l] adjacent to the last one (L). + + op := (different | Null) & + (k := max_l+1 > [i,i+1,i-1][!sub_lists[?6]]) > 1 & + (l := max_w+1 > [j,j+1,j-1][!sub_lists[?6]]) > 1 & + op([k, l], snake) + + return [k, l] + +end + + + +procedure different(l,snake) + + local bit + (l[1] = (bit := !\snake)[1], l[2] = bit[2]) & fail + return + +end + + + +procedure Null(a[]) + return +end + + + +procedure display(lb,snake) + + local last_segment, character + static CM + initial CM := getval("cm") + + # Change the mode of the square just "vacated" by the moving snake. + if *snake = 0 | different(\lb,snake) then { + iputs(igoto(CM, lb[2], lb[1])) + normal() + writes(" ") + } + + if last_segment := (0 ~= *snake) then { + # Write the last segment (which turns out to be the snakes head!). + iputs(igoto(CM, snake[last_segment][2], snake[last_segment][1])) + emphasize(); writes(snake_char) # snake_char is global + } + + # Check to see whether we've eaten every edible square on the screen. + if done_yet(lb) + then fail + else return + +end + + + +procedure makenew(snake) + local leftbehind, i + + # Move each constituent list up one position in snake, discard + # the first element, and tack a new one onto the end. + + every i := 1 to *snake - 1 do + snake[i] :=: snake[i+1] + leftbehind := copy(snake[i+1]) + snake[i+1] := findnext(snake[i],snake) + return wholething(leftbehind,snake) + +end + + + +procedure the_same(l1, l2) + + if l1[1] = l2[1] & l1[2] = l2[2] + then return else fail + +end + + + +procedure done_yet(l) + local i, j + + # Check to see if we've eaten every edible square on the screen. + # It's easy for snake to screw up on this one, since somewhere + # along the line most terminal/driver/line combinations will con- + # spire to drop a character somewhere along the line. + + static square_set + initial { + + square_set := set() + every i := 2 to max_l do { + every j := 2 to max_w do { + insert(square_set, i*j) + } + } + } + + /l & fail + delete(square_set, l[1]*l[2]) + if *square_set = 0 then return + else fail + +end + + + +procedure Kludge() + local i + + # Horrible way of clearing the screen to all reverse-video, but + # the only apparent way we can do it "portably" using the termcap + # capability database. + + iputs(igoto(getval("cm"),1,1)) + if getval("am") then { + emphasize() + every 1 to (getval("li")-1) * getval("co") do + writes(" ") + } + else { + every i := 1 to getval("li")-1 do { + iputs(igoto(getval("cm"), 1, i)) + emphasize() + writes(repl(" ",getval("co"))) + } + } + iputs(igoto(getval("cm"),1,1)) + +end diff --git a/ipl/progs/solit.icn b/ipl/progs/solit.icn new file mode 100644 index 0000000..1f631d8 --- /dev/null +++ b/ipl/progs/solit.icn @@ -0,0 +1,965 @@ +############################################################################ +# +# File: solit.icn +# +# Subject: Program to play solitaire +# +# Author: Jerry Nowlin +# +# Date: November 25, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Phillip L. Thomas and Ralph E. Griswold +# +############################################################################ +# +# 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. +# +############################################################################ +# +# Requires: keyboard functions +# +############################################################################ + +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")) + +# if keyboard functions are not available, disable ability to +# get out of auto mode. + + if not(&features == "keyboard functions") then + stop("*** requires keyboard functions") + + 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[0;31;47m" + BLACK := "\e[1;30;47m" + } + + default: { # same as IBM PC and vt100 + CLEAR := "\e[H\e[2J" + CLREOL := "\e[0K" + NORMAL := "\e[0m" + RED := "\e[0;31;47m" + BLACK := "\e[1;30;47m" + } + } + + # 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(cheat) + + # 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 map(act) of { + + # turn on the automatic pilot + "a": autopilot(cheat) + + # move a card or run of cards + "m": { + if {from := move(1) + tab(many(whitespace)) + dest := move(1) + } # Keep failure of parsing + then { # from movecard(); + if not movecard(from,dest) then { # otherwise, program + whoops(cmd) # aborts. + next # Exit from wrong + } # instruction. + else if cardsleft() = 0 then + finish(cheat) + else &null + } + else { # Exit from incomplete + whoops(cmd) # command. + next + } + } + + # 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," card", plural(*deck + *over), + " 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," time", plural(cheat), "!") + 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, " time", plural(cheat), "!") + else + write("...and without cheating...congratulations!") + + exit(0) + +end + +# this procedure takes over and plays the game for you + +procedure autopilot(cheat) + local tseq, totdeck + + movecursor(16,0) + writes("Going into automatic mode...") + if proc(kbhit) then writes( " [Press any key to return.]") + writes(CLREOL) + + # 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 + + if kbhit() then { + movecursor(16,0) + write("Now in manual mode ...", CLREOL) + amode := 0 + return + } + 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,30) + + # if all the cards are in runs or the aces piles + if cardsleft() = 0 then { + + writes("\007YEA...\007", CLREOL) + + # finish moving the runs to the aces piles + while movecard(!"7654321","a") + + movecursor(16,37) + write("I won!!!!!") + if cheat > 0 then write("But you cheated ", cheat, " time", + plural(cheat), ".") + + exit(0) + + } else { + + writes("I couldn't win this time.", CLREOL) + if cheat > 0 then writes(" But you cheated ", cheat, " time", + plural(cheat), ".") + + # print the information needed to verify that the + # program couldn't win + + movecursor(17,0) + writes(*deck + *over," card", plural(*deck + *over), + " 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 + +# A correction to my corrections for solit.icn. +# The zero case never happens in solit.icn, but this +# procedure is more general. From Phillip L. Thomas: + +# Return "s" for values equal to 0 or greater than 1, e.g., +# 0 horses, 1 horse, 2 horses. + +procedure plural(n) + /n := 0 # Handle &null values. + if n = 1 then return "" + else return "s" +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 diff --git a/ipl/progs/sortname.icn b/ipl/progs/sortname.icn new file mode 100644 index 0000000..abcfb0b --- /dev/null +++ b/ipl/progs/sortname.icn @@ -0,0 +1,40 @@ +############################################################################ +# +# File: sortname.icn +# +# Subject: Program to order by last name +# +# Author: Ralph E. Griswold +# +# Date: February 18, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program sorts a list of person's names by the last names. +# +############################################################################ + +link namepfx, lastname + +procedure main() + local names, line, last, first + + names := table() + + while line := read() do { + last := lastname(line) + first := namepfx(line) + /names[last] := set() + insert(names[last], first) + } + + names := sort(names, 3) + + while last := get(names) do + every write(!sort(get(names)), " ", last) + +end diff --git a/ipl/progs/splitlit.icn b/ipl/progs/splitlit.icn new file mode 100644 index 0000000..b066581 --- /dev/null +++ b/ipl/progs/splitlit.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: splitlit.icn +# +# Subject: Program to create string literal +# +# Author: Ralph E. Griswold +# +# Date: September 15, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The idea is to create a string literal with continuations in case +# it's too long. +# +# The options are: +# +# -w i width of piece on line, default 50 +# -i i indent, default 3 +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local width, line, chunk, opts, prefix, indent + + opts := options(args, "w+i+") + + width := \opts["w"] | 50 + indent := \opts["i"] | 3 + + prefix := repl(" ", indent) + + while line := read() do { + line ? { + writes(prefix, "\"") + while chunk := move(50) do { + write(image(chunk)[2:-1], "_") + writes(prefix) + } + write(image(tab(0))[2:-1], "\"") + } + } + +end diff --git a/ipl/progs/spread.icn b/ipl/progs/spread.icn new file mode 100644 index 0000000..98eecd2 --- /dev/null +++ b/ipl/progs/spread.icn @@ -0,0 +1,87 @@ +############################################################################ +# +# File: spread.icn +# +# Subject: Program to format tab-separated data columns +# +# Author: Gregg M. Townsend +# +# Date: June 6, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Spread reads data presented in tab-separated fields, such +# as some some spreadsheets export, and outputs the data in +# space-separated columns of the minimum necessary width. +# +# Usage: spread [-t c] [-g n] [-r] [file...] +# +# -g n set gutter width between output columns (default is 1) +# -r right-justify the fields instead of left-justifying +# -t c set separator character(s) for data (default is \t) +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, sep, gutter, justify, fname, f + local data, colsz, s, n, i, t + + # process options and set defaults + opts := options(args, "g+t:r") # command options + sep := cset(\opts["t"]) | '\t' # separator cset + gutter := integer(\opts["g"]) | 1 # output gutter width + justify := if \opts["r"] then right else left # justifying procedure + + # load data into memory + data := [] + if *args = 0 then + while put(data, read()) + else { + every fname := !args do { + f := open(fname) | stop("can't open ", fname) + while put(data, read(f)) + } + } + + # scan data to record maximum column widths needed + colsz := [] + every s := !data do s ? { + i := 0 + while n := (*tab(upto(sep)) | (0 < *tab(0))) do { + move(1) + i +:= 1 + if n <= colsz[i] then + next + if i > *colsz then + put(colsz, n) + else + colsz[i] := n + } + } + + # adjust column sizes to allow for gutters + every !colsz +:= gutter + if justify === right then + colsz[1] -:= gutter + + # write padded output + every s := !data do s ? { + i := 0 + while t := tab(upto(sep)) do { + writes(justify(t, colsz[i +:= 1])) + move(1) + } + write(justify(tab(0), colsz[i +:= 1])) + } + +end diff --git a/ipl/progs/streamer.icn b/ipl/progs/streamer.icn new file mode 100644 index 0000000..ae6e9d6 --- /dev/null +++ b/ipl/progs/streamer.icn @@ -0,0 +1,52 @@ +############################################################################ +# +# File: streamer.icn +# +# Subject: Program to append lines of file into one long line +# +# Author: Ralph E. Griswold +# +# Date: June 12, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program outputs one long line obtained by concatenating the +# lines of the input file. +# +# The supported options are: +# +# -l i stop when line reaches or exceeds i; default no limit +# -s s insert s after each line; default no separator +# +# Separators are counted in the length limit. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, length, line, limit, sep, ssize + + opts := options(args, "l+s:") + limit := opts["l"] + sep := \opts["s"] | "" + ssize := *sep + + length := 0 + + while line := writes(read(), sep) do { + length +:= *line + ssize + if length >= \limit then break + } + + write() + +end diff --git a/ipl/progs/strimlen.icn b/ipl/progs/strimlen.icn new file mode 100644 index 0000000..224290c --- /dev/null +++ b/ipl/progs/strimlen.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: strimlen.icn +# +# Subject: Program to produce lengths of string images +# +# Author: Ralph E. Griswold +# +# Date: February 25, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is a filter that reads images of Icon strings from standard +# input and writes the lengths of the strings to standard output. +# +############################################################################ +# +# Links: ivalue +# +############################################################################ + +link ivalue + +procedure main() + + while write(*ivalue(read())) + +end diff --git a/ipl/progs/strpsgml.icn b/ipl/progs/strpsgml.icn new file mode 100644 index 0000000..9b58349 --- /dev/null +++ b/ipl/progs/strpsgml.icn @@ -0,0 +1,88 @@ +############################################################################ +# +# File: strpsgml.icn +# +# Subject: Program to strip/translate SGML tags +# +# Author: Richard L. Goerwitz +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.9 +# +############################################################################ +# +# Strip or perform simple translation on SGML <>-style tags. Usage +# is as follows: +# +# strpsgml [-f translation-file] [left-delimiter [right-delimiter]] +# +# The default left-delimiter is <, the default right delimiter is >. +# If no translation file is specified, the program acts as a strip- +# per, simply removing material between the delimiters. Strpsgml +# takes its input from stdin, writing to stdout. +# +# The format of the translation file is: +# +# code initialization completion +# +# A tab or colon separates the fields. If you want to use a tab or colon +# as part of the text (and not as a separator), place a backslash before +# it. The completion field is optional. There is not currently any way +# of specifying a completion field without an initialization field. Do +# not specify delimiters as part of code. +# +# Note that, if you are translating SGML code into font change or escape +# sequences, you may get unexpected results. This isn't strpsgml's +# fault. It's just a matter of how your terminal or WP operate. Some +# need to be "reminded" at the beginning of each line what mode or font +# is being used. Note also that stripsgml assumes < and > as delimiters. +# If you want to put a greater-than or less-than sign into your text, +# put a backslash before it. This will effectively "escape" the spe- +# cial meaning of those symbols. It is now possible to change the +# default delimiters, but the option has not been thoroughly tested. +# +############################################################################ +# +# Links: scan, stripunb, readtbl +# +############################################################################ + +link scan +link stripunb +link readtbl + +procedure main(a) + + local usage, _arg, L, R, map_file, t, readtbl, line, stripunb, last_k + + usage:= + "usage: stripsgml [-f map-file] [left-delimiter(s) [right-delimiter(s)]]" + + L := '<'; R := '>' + while _arg := get(a) do { + if _arg == "-f" then { + map_file := open(get(a)) | + stop("stripsgml: can't open map_file\n",usage) + t := readtbl(map_file) + } + else { + L := _arg + R := cset(get(a)) + } + } + + every line := !&input do + write(stripunb(L,R,line,&null,&null,t)) # t is the map table + + # last_k is the stack used in stripunb.icn + if *\last_k ~= 0 then + stop("Unexpected EOF encountered. Expecting ", pop(last_k), ".") + +end diff --git a/ipl/progs/tabexten.icn b/ipl/progs/tabexten.icn new file mode 100644 index 0000000..bf6aa4c --- /dev/null +++ b/ipl/progs/tabexten.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: tabexten.icn +# +# Subject: Program to tabulate file extensions +# +# Author: Ralph E. Griswold +# +# Date: March 10, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program tabulates the file name extensions -- what follows the +# last period in a file name. +# +# It is designed handle output UNIX ls -R, but it will handle a list +# of file names, one per line. +# +############################################################################ + +procedure main() + local line, base, ext, dir + + ext := table(0) + + while line := read() do { + if *line = 0 then next # skip blank lines + line ? { + if upto(':') then next + if not tab(upto('.')) then next + while tab(upto('.')) + do move(1) + if &pos > 1 then ext[tab(0)] +:= 1 + } + } + + ext := sort(ext, 3) + + while write(left(get(ext), 20), right(get(ext), 6)) + +end diff --git a/ipl/progs/tablc.icn b/ipl/progs/tablc.icn new file mode 100644 index 0000000..96b2524 --- /dev/null +++ b/ipl/progs/tablc.icn @@ -0,0 +1,62 @@ +############################################################################ +# +# File: tablc.icn +# +# Subject: Program to tabulate characters in a file +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/tablw.icn b/ipl/progs/tablw.icn new file mode 100644 index 0000000..a770dac --- /dev/null +++ b/ipl/progs/tablw.icn @@ -0,0 +1,96 @@ +############################################################################ +# +# File: tablw.icn +# +# Subject: Program to tabulate words in a file +# +# Author: Ralph E. Griswold +# +# Date: December 27, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/tabulate.icn b/ipl/progs/tabulate.icn new file mode 100644 index 0000000..6b03d3c --- /dev/null +++ b/ipl/progs/tabulate.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: tabulate.icn +# +# Subject: Program to tabulate lines in a file +# +# Author: Ralph E. Griswold +# +# Date: February 28, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program produces a tabulation showing how many times each +# line of a file occurs. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local opts, tabulation + + tabulation := table(0) + + while tabulation[read()] +:= 1 + + tabulation := sort(tabulation, 3) + + while write(get(tabulation), " ", right(get(tabulation), 6)) + +end diff --git a/ipl/progs/textcnt.icn b/ipl/progs/textcnt.icn new file mode 100644 index 0000000..48f0bf6 --- /dev/null +++ b/ipl/progs/textcnt.icn @@ -0,0 +1,51 @@ +############################################################################ +# +# File: textcnt.icn +# +# Subject: Program to tabulate properties of text file +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program tabulates the number of characters, "words", and +# lines in standard input and gives the maximum 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 diff --git a/ipl/progs/textcvt.icn b/ipl/progs/textcvt.icn new file mode 100644 index 0000000..94fa6c8 --- /dev/null +++ b/ipl/progs/textcvt.icn @@ -0,0 +1,131 @@ +############################################################################ +# +# File: textcvt.icn +# +# Subject: Program to convert text file formats +# +# Author: Robert J. Alexander +# +# Date: November 21, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# +# Program to convert text file(s) among various platforms' formats. +# +# The supported text file types are UNIX, MS-DOS, and Macintosh. A +# universal input text reading algorithm is used, so only the output +# file format must be specified. +# +# The files are either converted in-place by converting to a temporary +# file and copying the result back to the original, or are copied to a +# separate new file, depending on the command line options. If the +# conversion is interrupted, the temporary file might still remain as +# <original name>.temp (or, for MS-DOS, <original name root>.tmp. +# +############################################################################ +# +# Links: io, options +# +############################################################################ + +link io +link options + +procedure Usage(s) + write(&errout,\s) + stop("Usage: textcvt [-options] -<output format> textfile..._ + \n options:_ + \n f <file name> output file name if different from input_ + \n o <dir name> output filename prefix (e.g. directory)_ + \n c copy first file to second file_ + \n <output format>:_ + \n u: UNIX_ + \n d: MS-DOS_ + \n m: Macintosh") +end + +procedure Options(arg) + local opt + opt := options(arg,"udmo:f:c",Usage) + OutEnder := + if \opt["u"] then "\x0a" + else if \opt["d"] then "\x0d\x0a" + else if \opt["m"] then "\x0d" + else Usage() + OutDir := opt["o"] + if OutFile := \opt["f"] then { + if *arg > 1 then Usage("Only one input file allowed with -f") + } + else if \opt["c"] then { + if *arg ~= 2 then Usage("Exactly two files required for -c") + OutFile := pull(arg) + } + return opt +end + + +global OutEnder,OutDir,OutFile + +procedure main(arg) + local oldName,old,newName,tmp,notInPlace,tmpName + Options(arg) + notInPlace := \(OutFile | OutDir) + every oldName := !arg do { + old := open(oldName,"ru") | { + write(&errout,"Can't open ",oldName) + next + } + if \notInPlace then { + tmpName := (\OutDir | "") || (\OutFile | tail(oldName)[2]) + tmp := open(tmpName,"wu") | { + write(&errout,"Can't open output file ",tmpName) + close(old) + next + } + writes(&errout,"Converting ",oldName," -> ",tmpName," -- ") + } + else { + tmpName := if match("MS_DOS",&host) then suffix(oldName)[1] || ".tmp" + else oldName || ".temp" + tmp := open(tmpName,"wu") | { + write(&errout,"Can't open work file ",tmpName) + close(old) + next + } + writes(&errout,"Converting ",oldName," -- ") + } + flush(&errout) + ConvertText(old,tmp) + close(tmp) + close(old) + if \notInPlace then { + write(&errout,"done.") + } + else { + (fcopy(tmpName,oldName) & write(&errout,"done.")) | + write(&errout,"done.") + remove(tmpName) + } + } +end + +procedure ConvertText(old,new) + local buf,c,trail + while buf := reads(old,2000) do { + if buf[-1] == "\x0d" then buf ||:= reads(old) + buf ? { + while writes(new,tab(upto('\x0a\x0d')),OutEnder) do { + c := move(1) + if c == "\x0d" then ="\x0a" + } + writes(new,trail := tab(0)) + } + } + if *\trail > 0 then writes(new,OutEnder) + return +end diff --git a/ipl/progs/toktab.icn b/ipl/progs/toktab.icn new file mode 100644 index 0000000..98e6784 --- /dev/null +++ b/ipl/progs/toktab.icn @@ -0,0 +1,126 @@ +############################################################################ +# +# File: toktab.icn +# +# Subject: Program to summarize Icon token counts +# +# Author: Ralph E. Griswold +# +# Date: June 21, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads the token files given on the command line and +# summarizes them in a single file. +# +# The supported options are: +# +# -n sort tokens by category in decreasing numerical order; +# default alphabetical sorting +# -l i limit output in any category to i items; default no limit +# +############################################################################ +# +# Links: options, showtbl +# +############################################################################ + +link options +link showtbl + +global binops, unops, vars, controls, procs, others, keys +global clits, ilits, rlits, slits +global summary, globals, locals, statics, declarations, fields, files, parms +global fldref + +procedure main(args) + local names, tables, i, file, input, count, line, tbl, opts, k, limit + local total, result + + opts := options(args, "nl+") + k := if \opts["n"] then "val" else "ref" + limit := \opts["l"] | 2 ^ 31 + + total := 0 + + # WARNING: The following data must match the data in tokgen.icn. + # Ideally, they both should work from an include file. + # Later ... + + # Build a list of tables for the different types of tokens. The order + # of the tables determines the order of output. + + tables := [] + every put(tables, (unops | binops | others | controls | keys | clits | + ilits | rlits | slits | vars | fldref | declarations | globals | + locals | statics | parms | fields | files) := table(0)) + + # Create a list of names for the different types of tokens. The order + # of the names must correspond to the order of the tables above. + + names := ["Unary operators", "Binary operators", "Other operations", + "Control structures", "Keywords", "Cset literals", "Integer literals", + "Real literals", "String literals", "Variable references", + "Field references", "Declarations", "Globals", "Locals", "Statics", + "Procedure parameters", "Record fields", "Included files"] + + # Read the token files + + every file := !args do { + input := open(file) | stop("*** cannot open ", file) + read(input) # get rid of first line + while line := trim(read(input)) do { + line ? { + if ="Total tokens:" then break + if any(&ucase) & name := tab(upto(':')) & pos(-1) then { + (tbl := tables[index(names, name)]) | + stop("*** invalid token category: ", name) + read(input) # get rid of blank line + next + } + if *line = 0 then { + read(input) # get rid of "total" + read(input) # and blank line + next + } + if tab(upto(&digits)) then { + count := tab(many(&digits)) | next + tab(many(' ')) + name := tab(0) + tbl[name] +:= count + } + } + } + close(input) + } + + # Now output the results + + every i := 1 to *names do { + result := showtbl(names[i], tables[i], k, limit) + count := result[1] + total +:= count + if result[2] > limit then write(" ...") else write() + write(right(count, 8), " total") + } + write("\nTotal tokens: ", total) + + +end + +# This procedure returns the first index in L whose corresponding element +# is x + +procedure index(L, x) + local i + + every i := 1 to *L do + if L[i] === x then return i + + fail + +end diff --git a/ipl/progs/trim.icn b/ipl/progs/trim.icn new file mode 100644 index 0000000..f3920b6 --- /dev/null +++ b/ipl/progs/trim.icn @@ -0,0 +1,52 @@ +############################################################################ +# +# File: trim.icn +# +# Subject: Program to trim lines in a file +# +# Author: Ralph E. Griswold +# +# Date: December 26, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program copies lines from standard input to standard out- +# put, truncating the lines at n characters and removing any trail- +# ing blanks and tabs. 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, ' \t') + if pad = 1 then line := left(line,n) + write(line) + } +end diff --git a/ipl/progs/ttt.icn b/ipl/progs/ttt.icn new file mode 100644 index 0000000..dc4ba77 --- /dev/null +++ b/ipl/progs/ttt.icn @@ -0,0 +1,316 @@ +############################################################################ +# +# File: ttt.icn +# +# Subject: Program to play tic-tac-toe +# +# Author: Chris Tenaglia +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program plays the game of tic-tac-toe. +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +global me,you,true,false,draw,pointer,wins,pass,taken,winner +global mark,row,routes,route + +procedure main() + local again, index, path, play, square, tmp, victory, your_last_move + + init() + play := true + while play == true do + { + me := set() # computer is me + you := set() # player is you + victory := "" # nobodys' won yet + winner := "" # winner flag + pass := 0 # start flag + taken := table(false) # taken position table (rather than set?) + display() +# +# computer makes first move +# + insert(me,1) + taken[1] := true + display() +# +# player follows +# + insert(you,(tmp := integer(get_your_move()))) + taken[integer(tmp)] := true + display() + path := routes[tmp] # players' move determines strategy + index := 2 # points at 2nd move just happened + +# +# computers' next move determined from strategy list +# + insert(me,(tmp := integer(path[(index+:=1)]))) + taken[tmp] := true + display() +# +# player follows +# + insert(you,(tmp := integer(get_your_move()))) + taken[integer(tmp)] := true + your_last_move := tmp + display() +# +# if didn't take position dictated, loss ensues +# + if your_last_move ~= (tmp := integer(path[(index+:=1)])) then + { + winner := "me" + insert(me,tmp) + taken[tmp] := true + display() + done_yet() + write(at(1,22),chop(&host)," Wins, You Loose!") + every square := !row do writes(pointer[square],mark) + again := map(input(at(1,23) || "Another game? Y/N :"))[1] + if again=="y" then next + stop(at(1,23),"Game Over.",chop()) + } + +# +# user made a good move, continue (computer plays now) +# + insert(me,(tmp := integer(path[(index+:=1)]))) + taken[tmp] := true + display() +# +# player follows +# + insert(you,(tmp := integer(get_your_move()))) + taken[integer(tmp)] := true + your_last_move := tmp + display() + +# +# if didn't take position dictated, loss ensues +# + if your_last_move ~= (tmp := integer(path[(index+:=1)])) then + { + winner := "me" + insert(me,tmp) + taken[tmp] := true + display() + done_yet() + write(at(1,22),chop(&host)," Wins, You Loose!") + every square := !row do writes(pointer[square],mark) + again := map(input(at(1,23) || "Another game? Y/N :"))[1] + if again=="y" then next + stop(at(1,23),"Game Over.",chop()) + } +# +# if players first move wasn't 5, they lose now too +# + if integer(path[2]) ~= 5 then + { + tmp := integer(path[(index+:=1)]) + winner := "me" + insert(me,tmp) + taken[tmp] := true + display() + done_yet() + write(at(1,22),chop(&host)," Wins, You Loose!") + every square := !row do writes(pointer[square],mark) + again := map(input(at(1,23) || "Another game? Y/N :"))[1] + if again=="y" then next + stop(at(1,23),"Game Over.",chop()) + } + +# +# user made a good move, continue (computer plays now) +# + insert(me,(tmp := integer(path[(index+:=1)]))) + taken[tmp] := true + display() + write(at(1,22),chop(),"Game was a draw.") + again := map(input(at(1,23) || "Another game? Y/N :"))[1] + if again=="y" then next + stop(at(1,23),"Game Over.",chop()) + } + end +# +# procedure to display the current tictactoe grid and plays +# +procedure display() + local line, x, y + + if (pass +:= 1) = 1 then + { + write(cls(),uhalf()," T I C - T A C - T O E") + write(lhalf()," T I C - T A C - T O E") + write(trim(center("Computer is 'O' and you are 'X'",80))) + line := repl("q",60) ; line[21] := "n" ; line[41] := "n" + every y := 5 to 20 do writes(at(30,y),graf("x")) + every y := 5 to 20 do writes(at(50,y),graf("x")) + writes(at(10,10),graf(line)) + writes(at(10,15),graf(line)) + every x := 1 to 9 do writes(pointer[x],dim(x)) + } + every writes(pointer[!me],high("O")) + every writes(pointer[!you],under("X")) + end + +# +# procedure to obtain a move choice from the player +# +procedure get_your_move() + local yours,all_moves + repeat { + writes(at(5,22)) + yours := input("Enter block # (1-9) :") + writes(at(5,23),chop()) + if not(integer(yours)) then + { + writes(at(5,23),beep(),"Invalid Input! Choose 1-9.") + next + } + if (1 > yours) | (yours > 9) then + { + writes(at(5,23),beep(),"Value out of range! Choose 1-9.") + next + } + if taken[integer(yours)] == true then + { + writes(at(5,23),beep(),"That position is already taken! Try again.") + next + } + break } + return integer(yours) + end + +# +# procedure to test if computer has won, or the game is a draw +# +procedure done_yet() + local outcome, test, part + + every outcome := !wins do + { + test := 0 + every part := !outcome do + if member(you,part) then test +:= 1 + if test = 3 then + { + winner := "you" + row := outcome + mark := high(blink("X")) + return true + } + } + every outcome := !wins do + { + test := 0 + every part := !outcome do + if member(me,part) then test +:= 1 + if test = 3 then + { + winner := "me" + row := outcome + mark := high(blink("O")) + return true + } + } + if *me + *you > 8 then + { + winner := draw + return draw + } + return "not done yet" + end +# +# prompts for an input from the user +# +procedure input(prompt) + writes(prompt) + return read() + end +# +# procedures to output ansi graphics and attributes +# +procedure at(x,y) + return "\e[" || y || ";" || x || "f" + end + +procedure graf(str) + return "\e(0" || str || "\e(B" + end + +procedure uhalf(str) + /str := "" + return "\e#3" || str + end + +procedure lhalf(str) + /str := "" + return "\e#4" || str + end + +procedure high(str) + return "\e[1m" || str || "\e[0m" + end + +procedure normal(str) + return "\e[0m" || str + end + +procedure dim(str) + return "\e[2m" || str || "\e[0m" + end + +procedure under(str) + return "\e[4m" || str || "\e[0m" + end + +procedure blink(str) + return "\e[5m" || str || "\e[0m" + end + +procedure cls(str) + /str := "" + return "\e[2J\e[H" || str + end + +procedure chop(str) + /str := "" + return "\e[J" || str + end + +procedure beep() + return "\7" + end +# +# procedure to init useful global variables for later use +# +procedure init() + true := "y" + false := "n" + draw := "?" + randomize() + routes := ["-","1274958","1374958","1432956","1547328", + "1632745","1732956","1874352","1974352"] + wins := [set([1,5,9]),set([3,5,7]),set([1,2,3]),set([4,5,6]), + set([7,8,9]),set([1,4,7]),set([2,5,8]),set([3,6,9])] + pointer := [at(17,7), at(37,7), at(57,7), + at(17,12),at(37,12),at(57,12), + at(17,17),at(37,17),at(57,17)] + end + + diff --git a/ipl/progs/turing.icn b/ipl/progs/turing.icn new file mode 100644 index 0000000..57ab464 --- /dev/null +++ b/ipl/progs/turing.icn @@ -0,0 +1,175 @@ +############################################################################ +# +# File: turing.icn +# +# Subject: Program to simulate a Turing machine +# +# Author: Gregg M. Townsend +# +# Date: November 14, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 +# command-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 exercise... :-) +# +# 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 performing 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 diff --git a/ipl/progs/unclog.icn b/ipl/progs/unclog.icn new file mode 100644 index 0000000..ec7fe41 --- /dev/null +++ b/ipl/progs/unclog.icn @@ -0,0 +1,109 @@ +############################################################################ +# +# File: unclog.icn +# +# Subject: Program to reformat CVS log output +# +# Author: Gregg M. Townsend +# +# Date: May 2, 2005 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: unclog [-n nnn] [file] +# +# -n nnn maximum number of files to be listed individually +# (default is 50) +# +# Unclog reads the output of "cvs log", as run without arguments in +# a directory maintained by CVS, and reformats it to correlate CVS +# changes that affected multiple files. The log entries are produced +# in chronological order. +# +############################################################################ + +link options + +$define MAXFILES 50 + +procedure main(args) + local opts, maxfiles, f, line, mods, fname, files, text, s + + opts := options(args, "n+") + maxfiles := \opts["n"] | MAXFILES + + if *args = 0 then + f := &input + else + f := open(args[1]) | stop("cannot open ", args[1]) + + mods := table() + + while line := read(f) do line ? { + + # look for "date:" line + if ="Working file: " then # save working file name + fname := tab(0) + ="date: " | next + tab(find("author: ") + 8) | next + tab(upto(';') + 1) | next + + # this is the "date:" line + # save as first part of description + s := tab(1) + s[23+:3] := "" # remove seconds from clock reading + + # read description of modification + while line := read(f) do { + if line ? =("-----------" | "===========") then break + s ||:= "\n" || line + } + + # have reached end of this entry + # add to table, indexed by text + files := mods[s] + if /files then + files := mods[s] := [] + put(files, fname) + } + + # sort mods by timestamp, which is first part of text + mods := sort(mods, 3) + + # output the mods in order, giving affected files first + while text := get(mods) do { + files := get(mods) + if same(text, mods[1]) then { + # this entry differs from the next one only in timestamp details, + # so combine this entry with the next one + every put(mods[2], !files) + } + else { + # this is a unique entry + write() + if *files >= maxfiles then + write("file: [", *files, " files]") + else + every write("file: ", !sort(files)) + write(text) + write() + } + } +end + + + +# same(text1,text2) -- succeed if two mods are "the same", +# meaning that have identical nontrivial log messages + +procedure same(text1, text2) + + if text1 ? find("*** empty log message ***") then + fail + else + return text1[24:0] == text2[24:0] +end diff --git a/ipl/progs/unique.icn b/ipl/progs/unique.icn new file mode 100644 index 0000000..edfc2d3 --- /dev/null +++ b/ipl/progs/unique.icn @@ -0,0 +1,26 @@ +############################################################################ +# +# File: unique.icn +# +# Subject: Program to delete identical adjacent lines +# +# Author: Anthony V. Hewitt, modified by Bob Alexander +# +# Date: October 21, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Filters out identical adjacent lines in a file. +# +############################################################################ + +procedure main() + local s + + every write(s ~===:= !&input) + +end diff --git a/ipl/progs/unpack.icn b/ipl/progs/unpack.icn new file mode 100644 index 0000000..12245ed --- /dev/null +++ b/ipl/progs/unpack.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: unpack.icn +# +# Subject: Program to unpackage files +# +# Author: Ralph E. Griswold +# +# Date: May 27, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/upper.icn b/ipl/progs/upper.icn new file mode 100644 index 0000000..37d1cc7 --- /dev/null +++ b/ipl/progs/upper.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: upper.icn +# +# Subject: Program to map file names to uppercase +# +# Author: Ralph E. Griswold +# +# Date: March 10, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program maps the names of all files in the current directory to +# uppercase. +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure main() + local input, old, new + + input := open("ls", "p") + + while old := read(input) do { + new := map(old, &lcase, &ucase) + if new ~== old then rename(old, new) + } + +end diff --git a/ipl/progs/url2link.icn b/ipl/progs/url2link.icn new file mode 100644 index 0000000..15806c6 --- /dev/null +++ b/ipl/progs/url2link.icn @@ -0,0 +1,26 @@ +############################################################################ +# +# File: url2link.icn +# +# Subject: Program to convert bookmarked URLs to link references +# +# Author: Ralph E. Griswold +# +# Date: October 19, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program reads URLs from standard input and writes HTML links to +# standard output. +# +############################################################################ + +procedure main() + + while write("<A HREF=\"", read(), "\"></A><BR>") + +end diff --git a/ipl/progs/utrim.icn b/ipl/progs/utrim.icn new file mode 100644 index 0000000..2596a94 --- /dev/null +++ b/ipl/progs/utrim.icn @@ -0,0 +1,208 @@ +############################################################################ +# +# File: utrim.icn +# +# Subject: Program to remove unneeded procs from ucode +# +# Author: Gregg M. Townsend +# +# Date: August 7, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: utrim [-s | -v] file... +# +# Utrim alters a set of uncode files comprising a complete Icon program +# by removing unreferenced procedures. The resulting files are smaller, +# and they produce a smaller icode file. +# +# The basename of each command argument is used to find a pair of +# .u1 and .u2 files; each pair is renamed to .u1o and .u2o and +# replaced by new .u1 and .u2 files. +# +# -s invokes silent mode; -v invokes verbose mode. +# +# Warning: utrim may break programs that use string invocation. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +record prc(name, size, calls, need) # proc record +record lcl(name, flags) # local record + +global pnames, ptable # proc names and table + + +# main procedure + +procedure main(args) + local opts, fname, name, need + + # process options + opts := options(args, "sv") + if *args = 0 then + stop("usage: ", &progname, " [-s | -v] file.u1 ...") + every !args ?:= tab(upto('.')) + + # scan .u1 files to decide what's needed + pnames := set() + ptable := table() + every scan1(!args) + if /ptable["main"] then + stop(&progname, ": no main procedure") + dependencies() + report(opts) + + # write new .u1 and .u2 files + every fname := !args || (".u1" | ".u2") do { + remove(fname || "o") + rename(fname, fname || "o") | stop("can't rename ", fname) + } + every filter1(!args) + every filter2(!args) +end + + +# scan1(fname) -- read .u1 file, add proc names and refs to ptable + +procedure scan1(fname) + local u1, line, i, name, flags, curr, locals + u1 := open(fname || ".u1") | stop(&progname, ": can't open", fname || ".u1") + while line := read(u1) do line ? { + if ="proc " then { + # new proc: make table entry + name := tab(0) + insert(pnames, name) + ptable[name] := curr := prc(name, 0, set()) + locals := [] + } + else if ="\tlocal\t" then { + # new local: remember its name + i := tab(many(&digits)) + ="," + flags := tab(upto(',')) + ="," + name := tab(0) + put(locals, lcl(name, flags)) + } + else if ="\tvar\t" then { + # ref to "local": note as needed if it's a global + i := tab(0) + 1 + if locals[i].flags = 0 then + insert(curr.calls, locals[i].name) + } + curr.size +:= 1 # tally number of lines + } + close(u1) + return +end + + +# dependencies() -- mark procs called directly or indirectly from main proc + +procedure dependencies() + local need, p + + need := ["main"] + while name := get(need) do + if (p := \ptable[name]) & (/p.need := 1) then + every put(need, !p.calls) + return +end + + +# report(opts) -- write reports as selected by command options + +procedure report(opts) + local name, p, ptrim, ltrim, ltotal + + ltotal := ltrim := ptrim := 0 + every name := !sort(pnames) do { + p := ptable[name] + ltotal +:= p.size + if /p.need then { + ltrim +:= p.size + ptrim +:= 1 + } + if /opts["v"] then + next + writes(right(p.size, 6)) + writes(if \p.need then " * " else " ") + writes(left(p.name, 16)) + every writes(" ", !sort(p.calls)) + write() + } + if /opts["s"] then + write(&errout, "Trimming ", ptrim, "/", *pnames, " procedures (", + (100 * ptrim + 5) / *pnames, "%), ", ltrim, "/", ltotal, " lines (", + (100 * ltrim + 5) / ltotal, "%)") + return +end + + +# filter1(fname) -- filter .u1o file to make new .u1 file +# +# For each proc body, copy only if marked as needed in ptable. + +procedure filter1(fname) + local old, new, line + + old := open(fname||".u1o") | stop(&progname, ": can't open", fname||".u1o") + new := open(fname||".u1","w") | stop(&progname,": can't write",fname||".u1") + + while line := read(old) do line ? + if ="proc " & /ptable[tab(0)].need then # check new proc + until (line ? ="\tend") | not (line := read(old)) # skip to proc end + else + write(new, line) + close(old) + close(new) + return +end + + +# filter2(fname) -- filter .u2o file to make new .u2 file +# +# Copy header verbatim; read list of globals, remove procs trimmed from .u1, +# and write new (renumbered) global list. + +procedure filter2(fname) + local old, new, line, n, glist, flags, name, args, p + + old := open(fname||".u2o") | stop(&progname, ": can't open ", fname||".u2o") + new := open(fname||".u2","w") | stop(&progname,": can't write ",fname||".u2") + + write(new, read(old)) | stop(&progname, ": empty ", fname || ".u2o") + while (line := read(old)) & not (line ? ="global") do + write(new, line) + + glist := [] + while line := read(old) do line ? { + ="\t" + tab(many(&digits)) + p := &pos + ="," + flags := tab(upto(',')) + ="," + name := tab(upto(',')) + if flags = 5 & /(\ptable[name]).need then + next + tab(p) + put(glist, tab(0)) + } + write(new, "global\t", *glist) + every write(new, "\t", 0 to *glist - 1, get(glist)) + + close(old) + close(new) + return +end diff --git a/ipl/progs/verse.icn b/ipl/progs/verse.icn new file mode 100644 index 0000000..95114cb --- /dev/null +++ b/ipl/progs/verse.icn @@ -0,0 +1,445 @@ +############################################################################ +# +# File: verse.icn +# +# Subject: Program to generate bizarre verses +# +# Author: Chris Tenaglia +# +# Date: May 26, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This verse maker was initially published in an early 1980s Byte magazine in +# TRS80 Basic. In 1985 I translated it to BASICA, and in 1987 I translated it +# to Icon. Recently, I've polished it to fetch the vocabulary all from one +# file. +# +# A vocabulary file can be specified on the command line; otherwise +# file it looks for verse.dat by default. See that file for examples +# of form. +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +global nouns,nounp,adjt,advb,more,most,ivpre,ivpas,tvpre,tvpas,prep +global being,art,ques,cond,nompro,punc,noun1,noun2,tv,iv,adjv,prpo +global be,pun,pron,con,ar,tnnum,tadjno,ttvnum,tprnum,cls,name,watch + +procedure main(param) + local in, part, line, tmp, reply, Out, In, t + + randomize() + nouns := [] #singular nouns + nounp := [] #plural nouns + adjt := [] #adjectives + advb := [] #adverbized + more := [] #more adjective + most := [] #most adjective + tvpas := [] #transitive verb past + tvpre := [] #transitive verb present + ivpas := [] #intransitive verb past + ivpre := [] #intransitive verb present + prep := [] #prepositions + punc := [] #punctuations + art := [] #articles of speech + ques := [] #question words + being := [] #being verbs + cls := "\e[H\e[2J" #clear screen string (or system("clear")) + +############################################################################ +# # +# load the vocabulary arrays # +# # +############################################################################ + + name := param[1] | "verse.dat" + (in := open(name)) | stop("Can't open vocabulary file (",name,")") + part := "?" ; watch := "?" + write(cls,"VERSE : AI Mysterious Poetry Generator\n\nInitializing\n\n") + while line := read(in) do + { + if match("%",line) then + { + part := map(trim(line[2:0])) + write("Loading words of type ",part) + next + } + tmp := parse(line,'|@#') + case part of + { + "noun" : { + put(nouns,tmp[1]) + put(nounp,tmp[2]) + } + "adjt" : { + put(adjt,tmp[1]) + put(advb,tmp[2]) + put(more,tmp[3]) + put(most,tmp[4]) + } + "ivrb" : { + put(ivpre,tmp[1]) + put(ivpas,tmp[2]) + } + "tvrb" : { + put(tvpre,tmp[1]) + put(tvpas,tmp[2]) + } + "prep" : put(prep,line) + "been" : put(being,line) + default: write("Such Language!") + } + loadrest() + } + close(in) +reply := "" +while map(reply) ~== "q" do + { +# +# output the title +# + (Out := open("a.out","w")) | stop ("can't open a.out for some reason!") + + t := ?7 + tnnum := ?*(nouns) #title noun selector + tadjno:= ?*(adjt) #title adjective selector + ttvnum:= ?*(tvpre) #title transitive verb selector + tprnum:= ?*(prep) #title preposition selector + + clrvdu() + write(title(t)) + write(Out,title(t)) + write() + write(Out) + +# +# output the lines +# + every 1 to (12+?6) do + { + noun1 := ?*(nouns) + noun2 := ?*(nouns) + tv := ?*(tvpre) + iv := ?*(ivpre) + adjv := ?*(adjt) + prpo := ?*(prep) + be := ?*(being) + pun := ?*(punc) + pron := ?*(nompro) + con := ?*(cond) + ar := ?*(art) + + case ?19 of + { + 1 : {write(form1()) ; write(Out,form1())} + 2 : {write(form2()) ; write(Out,form2())} + 3 : {write(form3()) ; write(Out,form3())} + 4 : {write(form4()) ; write(Out,form4())} + 5 : {write(form5()) ; write(Out,form5())} + 6 : {write(form6()) ; write(Out,form6())} + 7 : {write(form7()) ; write(Out,form7())} + 8 : {write(form8()) ; write(Out,form8())} + 9 : {write(form9()) ; write(Out,form9())} + 10 : {write(form10()) ; write(Out,form10())} + 11 : {write(form11()) ; write(Out,form11())} + 12 : {write(form12()) ; write(Out,form12())} + 13 : {write(form13()) ; write(Out,form13())} + 14 : {write(form14()) ; write(Out,form14())} + 15 : {write(form15()) ; write(Out,form15())} + 16 : {write(form16()) ; write(Out,form16())} + 17 : {write(form17()) ; write(Out,form17())} + 18 : {write(form18()) ; write(Out,form18())} + 19 : {write(form19()) ; write(Out,form19())} + } + } +# last line + case ?2 of + { + 1 : { + write(nounp[tnnum]," ",prep[prpo]," THE ",nouns[noun1], + " ",being[be]," ",adjt[tadjno],".") + write(Out,nounp[tnnum]," ",prep[prpo]," THE ",nouns[noun1], + " ",being[be]," ",adjt[tadjno],".") + } + 2 : { + write("THE ",nounp[tnnum]," OR ",nouns[noun1]," ", + adjt[adjv]," ",being[be],".") + write(Out,"THE ",nounp[tnnum]," OR ",nouns[noun1]," ", + adjt[adjv]," ",being[be],".") + } + } + close(Out) + + write() + writes("Press <RET> for another, Q to quit, or a name to save it>") + reply := read() + if (reply ~== "Q") & (trim(reply) ~== "") then + { + (In := open("a.out")) | stop ("can't open a.out for some reason!") + (Out := open(reply,"w")) | stop ("can't open ",reply) + while write(Out,read(In)) + close(In) ; close(Out) + } + } + end + +############################################################################ + +procedure aoran(word) + local vowels + + vowels := 'AEIOU' + if any(vowels,word) then return ("AN " || word) + else return ("A " || word) +end + +############################################################################ + +procedure clrvdu() + writes(cls) +end + +############################################################################ + +procedure gerund(word) + static vowel + initial vowel := 'AEIOU' + if word[-1] == "E" then word[-1] := "" + return(word || "ING") +end + +############################################################################ + +procedure title(a) + + local text + + case a of + { + 1 : text := aoran(adjt[tadjno]) || " " || nouns[tnnum] + 2 : text := "TO " || tvpre[ttvnum] || " SOME " || nouns[tnnum] + 3 : text := prep[tprnum] || " " || nounp[tnnum] + 4 : text := "THE " || nouns[tnnum] + 5 : text := prep[tprnum] || " " || aoran(nouns[tnnum]) || " " || advb[tadjno] + 6 : text := "THE " || more[tadjno] || " " || nouns[tnnum] + 7 : text := "THE " || most[tadjno] || " " || nouns[tnnum] + } + return(text) +end + +############################################################################ + +procedure form1() + local text, n, prefix + n := 1 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || nounp[noun1] || " " || tvpre[tv] || " THE " + text ||:= more[adjv] || " " || nouns[noun2] || punc[pun] + return(text) +end + +procedure form2() + local text, n, prefix + n := 2 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || nounp[noun1] || " " || tvpre[tv] || " THE " + text ||:= most[adjv] || " " || nouns[noun2] || punc[pun] + return(text) +end + +procedure form3() + local text, n, prefix + n := 3 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || adjt[adjv] || " " || nounp[noun1] || " " || being[be] + text ||:= " " || gerund(ivpre[iv]) || " " || punc[pun] + return(text) +end + +procedure form4() + local text, n, prefix + n := 4 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || adjt[adjv] || " " || nounp[noun1] || " " || ivpre[iv] + text ||:= " " || punc[pun] + return(text) +end + +procedure form5() + local text, n, prefix + n := 5 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || ques[?*ques] || " " || adjt[adjv] || " " + text ||:= nounp[noun1] || " " || ivpre[iv] || "?" + return(text) +end + +procedure form6() + local text, n, prefix + n := 6 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || art[ar] || " " || adjt[adjv] || " " || nouns[noun1] + text ||:= " " || tvpas[tv] || " THE " || nouns[noun2] || punc[pun] + return(text) +end + +procedure form7() + local text, n, prefix + n := 7 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || "THE " || nounp[tnnum] || " " || ivpas[iv] + text ||:= " " || prep[prpo] || " THE " || more[tadjno] || " " + text ||:= nounp[noun1] || " " || punc[pun] + return(text) +end + +procedure form8() + local text, n, prefix + n := 8 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || "THE " || nounp[tnnum] || " " || ivpas[iv] || " " + text ||:= prep[prpo] || " THE " || most[tadjno] || " " || nounp[noun1] + text ||:= " " || punc[pun] + return(text) +end + +procedure form9() + local text, n, prefix + n := 9 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || ques[?*ques] || " " || nounp[tnnum] || " " || ivpre[iv] + text ||:= " " || prep[prpo] || " " || aoran(adjt[adjv]) || " " + text ||:= nouns[noun2] || "?" + return(text) +end + +procedure form10() + local text, n, prefix + n := 10 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || nounp[noun1] || " " || ivpre[iv] || " " || advb[adjv] + text ||:= " " || prep[prpo] || " " || nompro[pron] || punc[pun] + return(text) +end + +procedure form11() + local text, n, prefix + n := 11 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || adjt[adjv] || " " || nounp[noun1] || " " || being[be] + text ||:= " " || adjt[tadjno] || " " || cond[con] + return(text) +end + +procedure form12() + local text, n, prefix + n := 12 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || art[ar] || " " || nouns[noun1] || " " || ivpas[iv] + text ||:= " " || advb[adjv] || punc[pun] + return(text) +end + +procedure form13() + local text, n, prefix + n := 13 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || cond[con] || " " || nounp[noun1] || " " || being[be] + text ||:= " " || gerund(tvpre[ttvnum]) || " " || prep[prpo] || " " + text ||:= gerund(ivpre[iv]) || " " || nounp[noun2] || punc[pun] + return(text) +end + +procedure form14() + local text, n, prefix + n := 14 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || art[ar] || " " || adjt[adjv] || " " || gerund(tvpre[tv]) + text ||:= " OF THE " || nouns[tnnum] || " AND " || nouns[noun1] || punc[pun] + return(text) +end + +procedure form15() + local text, n, prefix + n := 15 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || gerund(tvpre[ttvnum]) || " " || nouns[noun1] + text ||:= " AND " || nouns[noun2] + return(text) +end + +procedure form16() + local text, n, prefix + n := 16 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || "THE " || nounp[tnnum] || " " || ivpre[iv] || punc[pun] + return(text) +end + +procedure form17() + local text, n, prefix + n := 17 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || nompro[pron] || " " || tvpas[ttvnum] || " THE " + text ||:= adjt[adjv] || " " || nouns[noun1] || punc[pun] + return(text) +end + +procedure form18() + local text, n, prefix + n := 18 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || adjt[adjv] || " " || nounp[noun2] || " " || being[be] + text ||:= " " || nounp[noun1] || punc[pun] + return(text) +end + +procedure form19() + local text, n, prefix + n := 19 + if watch=="true" then prefix := "(" || n || ") " else prefix := "" + text := prefix || "THE " || nounp[tnnum] || "'S " || nounp[noun1] || " " + text ||:= adjt[adjv] || " " || being[be] || punc[pun] + return(text) +end + +############################################################################ + +procedure parse(line,delims) + static chars + local tokens + + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end + +procedure loadrest() + art := ["ITS" , "THIS" , "SOME", "ANY" , "ONE" , "THAT" , + "ITS" , "MY" , "YOUR" , "OUR"] + + ques := ["WHY DO" , "WHEN DO" , "WHERE DO" , "HOW DO" , "CANNOT" , + "HOW COME" , "WHY DON'T"] + + nompro := ["SOMETHING" , "ANYTHING" , "IT" , "THAT" , "ONE" , "YOU" , "THIS"] + + cond := ["SINCE" , "BECAUSE" , "UNTIL" , "IF" , "THEN" , "OR" , + "UNLESS" , "THEREFORE" , "AND THEN" , "OR ELSE" , "ELSE IF"] + + punc := ["." , "," , "?" , "!" , "," , "-" , ";"] +end + + + + diff --git a/ipl/progs/versum.icn b/ipl/progs/versum.icn new file mode 100644 index 0000000..0bdf674 --- /dev/null +++ b/ipl/progs/versum.icn @@ -0,0 +1,75 @@ +############################################################################ +# +# File: versum.icn +# +# Subject: Program to produce versum sequence +# +# Author: Ralph E. Griswold +# +# Date: August 12, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program writes the versum sequence for an integer to a file of a +# specified name. If such a file exists, it picks up where +# it left off, appending new values to the file. +# +# The supported options are: +# +# -s i The seed for the sequence, default 196 +# -f s Name of file to extend, no default +# -F s Name of file, default <i>.vsq, where <i> is the +# seed of the sequence +# -t i The number of steps to carry the sequence out to, default +# essentially unlimited +# -m i Stop when value equals or exceeds m; default no limit +# +# If both -f and -F are given, -f overrides. +# +############################################################################ +# +# Links: options +# +############################################################################ + +link options + +procedure main(args) + local start, output, input, i, opts, limit, name, max, count + + opts := options(args, "t+s+m+f:F:") + start := (0 < \opts["s"]) | 196 + limit := \opts["t"] | -1 + max := opts["m"] + name := \opts["F"] | (start || ".vsq") + name := \opts["f"] + + if input := open(name) then { + count := 0 + while i := read(input) do { + if not integer(i) then exit() # link, not term + count +:= 1 + if count > limit then exit() + } + close(input) + } + + /i := start # in case file doesn't exist or is empty + + if not integer(i) then stop("*** invalid data") + + output := open(name, "a") | stop("*** cannot open file") + + limit -:= \count + + until (limit -:= 1) = -1 do { + i +:= reverse(i) + if i > \max then break + write(output, i := string(i)) + } + +end diff --git a/ipl/progs/vnq.icn b/ipl/progs/vnq.icn new file mode 100644 index 0000000..479e02b --- /dev/null +++ b/ipl/progs/vnq.icn @@ -0,0 +1,165 @@ +############################################################################ +# +# File: vnq.icn +# +# Subject: Program to display solutions to n-queens problem +# +# Author: Stephen B. Wampler +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program displays solutions to the n-queens problem. +# +############################################################################ +# +# 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 diff --git a/ipl/progs/vrepl.icn b/ipl/progs/vrepl.icn new file mode 100644 index 0000000..0fbd9cf --- /dev/null +++ b/ipl/progs/vrepl.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: vrepl.icn +# +# Subject: Program to replicate input lines +# +# Author: Ralph E. Griswold +# +# Date: January 14, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program replicates every line of standard input a specified +# number of times and writes the result to standard output. The +# replication factor is given on the command line. +# +############################################################################ + +procedure main(args) + local i, line + + i := integer(args[1]) | 1 + + while line := read() do + every 1 to i do + write(line) + +end diff --git a/ipl/progs/weblinks.icn b/ipl/progs/weblinks.icn new file mode 100644 index 0000000..b46fad5 --- /dev/null +++ b/ipl/progs/weblinks.icn @@ -0,0 +1,393 @@ +############################################################################ +# +# File: weblinks.icn +# +# Subject: Program to check links in HTML files +# +# Author: Gregg M. Townsend +# +# Date: September 27, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Weblinks is a program for checking links in a collection of HTML +# files. It is designed for use directly on the file structure +# containing the HTML files. +# +# Given one or more starting points, weblinks parses each file and +# validates the HTTP: and FILE: links it finds. Errors are reported +# on standard output. FILE: links, including relative links, can be +# followed recursively. +# +############################################################################ +# +# By design, only local files are scanned. Only an existence check is +# performed for HTTP: links. Validation of HTTP: links is aided by +# caching and subject to speed limits; see "vhttp.icn" for details. +# +# Remote links are checked by sending an HTTP "HEAD" request. +# Unfortunately, some sites respond with "Server Error" or even with +# snide remarks like "Because I felt like it". These are reported +# as errors and must be inspected manually. +# +# NOTE: if the environment variable USER is set, as it usually is, +# then "From: $USER@hostname" is sent as part of each remote inquiry +# in order to identify the source. This is standard etiquette for +# automated checkers. +# +# Limitations: +# url(...) links within embedded stylesheets are not recognized. +# FTP:, MAILTO:, and other link types are not validated. +# Files are checked recursively only if named *.htm*. +# Proper file permission (for web export) is not checked. +# +# The common error of failing to put a trailing slash on a directory +# specification results in a "453 Is A Directory" error message for a +# local file or, typically, a "301 Moved Permanently" message for a +# remote file. +# +############################################################################ +# +# usage: weblinks [options] file... +# +# -R follow file links recursively +# (http links are never followed recursively) +# +# -t trace files as visited +# +# -s report successes as well as problems +# +# -v report tracing and successes, if selected, more verbosely +# +# -r root +# specify starting point for file names beginning with "/" +# (e.g. -r /cs/www). This is needed if such references are +# to be followed or checked. If a root is specified it +# affects all file specifications including those on the +# command line. +# +# -h home +# specify starting point for file names beginning with "/~". +# +# -p prefix[,prefix...] +# prune (don't check) files beginning with given prefix +# +# -b prefix +# specify bounds for files scanned: do not scan files +# that do not begin with prefix. Default bounds are +# directory of last file name. For example, +# weblinks /foo/bar /foo/baz +# implies "-b /foo/". +# +# If the environment variable WEBLINKS_INIT is set, its whitespace- +# separated words are prepended to the explicit command argument list. +# +############################################################################ +# +# Examples (all assuming a web area rooted at /cs/www) +# +# To check one new page: +# weblinks -r /cs/www /icon/books.htm +# +# To check a personal hierarchy, with tracing: +# setenv WEBLINKS_INIT "-r /cs/www -h /cs/www/people" +# weblinks -R -t /~gmt/ +# +# To check with pruning: +# weblinks -R -t -r /cs/www -p /icon/library /icon/index.htm +# +############################################################################ +# +# Links: options, strings, html, vhttp +# +############################################################################ +# +# Requires: Unix, dynamic loading +# +############################################################################ + + +# to do: +# add -u option (report unchecked URLs); -s should imply -u +# provide way to ask for warnings about (e.g.) /http/html paths +# provide way to specify translation from http:lww... into file: /... +# provide way to specify translation from ftp:... into file: /... +# provide depth limit control +# allow longer history persistence +# history is clumsy -- hard to recheck a connection that failed +# add option to retry failed entries (but believe cached successes) +# add option to sort report by referencing page + + +$define URLCOLS 56 # number of columns allotted for tracing URLs +$define STATCOLS 22 # number of columns allotted for status messages + +link options +link strings +link html +link vhttp + + +global root +global home +global prune +global bounds + +global recurse +global trace +global verbose +global successes + +global todo, done, nscanned +global refto, reffrom + + +procedure main(args) + local opts, url, tmp + + # initialize data structures + + prune := list() + todo := list() + done := table() + refto := table() + reffrom := table() + nscanned := 0 + + # add arguments from the environment to the command line + + tmp := list() + every put(tmp, words(getenv("WEBLINKS_INIT"))) + while push(args, pull(tmp)) + + # process command line + + opts := options(args, "b:p:r:h:Rstv") + recurse := opts["R"] + successes := opts["s"] + trace := opts["t"] + verbose := opts["v"] + + if *args = 0 then + stop("usage: ", &progname, " [options] file ...") + + setroot(\opts["r"] | "/") + sethome(\opts["h"] | "/usr/") + setbounds(\opts["b"] | urlmerge(args[-1], "")) + every setprune(words(\opts["p"], ' ,')) + setfrom() + + register("initial:") + register("implicit:") + every addref("initial:", urlmerge("file:", !args)) + + wheader() + + while url := get(todo) do + try(url) + + if \trace then + write() + + report() +end + +procedure setroot(s) + if s[-1] ~== "/" then + s ||:= "/" + root := s + return +end + +procedure sethome(s) + if s[-1] ~== "/" then + s ||:= "/" + home := s + return +end + +procedure setprune(s) + put(prune, s) + return +end + +procedure setbounds(s) + bounds := s + return +end + +procedure setfrom() + local user, host, f + + user := getenv("USER") | fail + *user > 0 | fail + f := open("uname -n", "rp") | fail + host := read(f) + close(f) + *\host > 0 | fail + vhttp_from := user || "@" || host + return +end + + +procedure wheader() + write("From:\t", \vhttp_from | "[none]") + write("root:\t", root) + write("home:\t", home) + write("bounds:\t", bounds) + every write("start:\t", (!todo)[6:0]) + every write("prune:\t", !prune) + write() + return +end + +procedure try(url) + local result + + (/done[url] := "[processing]") | return # return if already checked + + if \trace then { + writes(pad(url, URLCOLS)) + flush(&output) + } + + result := check(url) + done[url] := result + + if \trace then + write(" ", result) + return +end + + +procedure check(url) + local protocol, fspec, fname, f, s, ref, base + + url ? { + protocol := map(tab(upto(':'))) | "" + =":" + fspec := tab(0) + } + + if protocol == "http" then + return vhttp(url) | "451 Illegal URL" + + if protocol ~== "file" then + return "152 Not Checked" + + fspec ? { + if ="/~" then + fname := home || tab(0) + else if ="/" then + fname := root || tab(0) + else if pos(0) then + fname := "./" + else + fname := fspec + } + + if fname[-1] == "/" then { + if (close(open(fname || "index.html"))) then { + addref("implicit:", url || "index.html") + return "154 Found index.html" + } + if (close(open(fname || "index.htm"))) then { + addref("implicit:", url || "index.htm") + return "155 Found index.htm" + } + if (close(open(fname || "."))) then + return "153 Found Directory" + } + + if not (f := open(fname)) then + return "452 Cannot Open" + + if (/recurse & not member(reffrom["initial:"], url)) | + (fspec ? (not match(bounds)) | match(!prune)) | + (not find(".htm", map(url))) then { + close(f) + if close(open(fname || "/.")) then + return "453 Is A Directory" + else + return "251 File Exists" + } + + base := url + every s := htrefs(f) do s ? { + if ="BASE HREF " then { + base := tab(0) + } + else { + tab(upto(' ') + 1) + tab(upto(' ') + 1) + ref := urlmerge(base, tab(0)) + addref(url, ref) + } + if \verbose then + writes("\n references: ", ref) + } + if \verbose then + writes("\n", repl(" ", URLCOLS)) + + close(f) + nscanned +:= 1 + return "252 File Scanned" +end + +procedure report() + local l, url, stat + + l := sort(done, 4) + while (url := get(l)) & (stat := get(l)) do { + if \successes | (any('3456789', stat) & stat ~== "302 Found") then { + write(pad(stat || ":", STATCOLS), " ", url) + if \verbose | any('3456789', stat) then + every write(" referenced by:\t", !sort(refto[url])) + } + } + + write() + + if nscanned = 1 then + write("1 file scanned") + else + write(nscanned, " files scanned") + + if *done = 1 then + write("1 reference checked") + else + write(*done, " references checked") + + return +end + +procedure addref(src, dst) + dst := (dst ? tab(upto('#') | 0)) + register(dst) + insert(refto[dst], src) + insert(reffrom[src], dst) + if /done[dst] then + put(todo, dst) + return +end + +procedure register(url) + /refto[url] := set() + /reffrom[url] := set() + return +end + + + +# pad(s, n) -- pad string to length n, never truncating + +procedure pad(s, n) + if *s < n then + return left(s, n) + else + return s +end diff --git a/ipl/progs/what.icn b/ipl/progs/what.icn new file mode 100644 index 0000000..9b0bbe9 --- /dev/null +++ b/ipl/progs/what.icn @@ -0,0 +1,69 @@ +############################################################################ +# +# File: what.icn +# +# Subject: Program to identify source-code information +# +# Author: Phillip Lee Thomas +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Writes all strings beginning with "@" followed by "(#)" +# and ending with null, newline, quotes, greater-than +# or backslash. Follows UNIX what conventions. +# +############################################################################ +# +# Requires: Tested with DOS, AIX UNIX +# +############################################################################ +# +# Links: basename +# +############################################################################ + +link basename + +procedure main(args) + local ID, line, terminator, key, f, fin, here + + ID := "@(#)what.icn (1.0) - plt - 2 May, 96" + ID := "@(#)-- Identify source code information." + + line := "" + terminator := '\0\n\">\\' # ++ char(10) + key := "@" || "(#)" + + if *args = 0 then { + write("Usage: ", basename(&progname, ".EXE"), + " file1 [file2 [file3]]") + exit(1) + } + + while f := pop(args) do { + fin := open(f, "ru") | next + write(f, ":") + + while line ||:= reads(fin, 32768) do { + line ? { + here := 1 + every (tab(here := upto('@')) | next) do { + if match(key) then { + move(4) + write('\t', tab(here := upto(terminator))) + } + } + line := line[here:0] + } # line + } # while + close(fin) + } # while files + write("[Time: ", &time / 1000.0, " seconds.]") + exit(0) +end diff --git a/ipl/progs/when.icn b/ipl/progs/when.icn new file mode 100644 index 0000000..0fb9462 --- /dev/null +++ b/ipl/progs/when.icn @@ -0,0 +1,300 @@ +############################################################################ +# +# File: when.icn +# +# Subject: Program to show file age +# +# Author: Chris Tenaglia +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This one was developed for UNIX (namely ULTRIX 4.3 rev 44). Maybe +# it will work on some other UNIX too. I'd like to know. This program +# is called 'when'. It's like a date based ls command. Some have told +# me 'find' can do the same things, but I find find a bit arcane? +# +# So 'when' is what I use. Here are some samples: +# +# when before 4/12/92 # files before a date +# when before 300 # files older than an age +# when after 3/25 # or younger than a date this year +# when before 2/1/94 and after 10/31/93 # even a range +# +# More options and clauses are supported. Look at the code for clues. +# This one only works in the current directory. It also has an interesting +# property. Maybe this is just ULTRIX, maybe not, I'd like to know anyway... +# The interpreted version works fine, but the compiled version has a +# numeric overflow. That'll make for some fun debugging. I wrote it for +# myself as a tool to locate old files for archiving or deleting. Study and +# enjoy! +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +global base, # 1970 calculation baseline number + today, # displacement from 12:00:01am today + now, # upto the second mark for right now + method, # ascending or descending order + output, # long (ls -al) or brief (ls -1) style + command, # optional command to do on each file + files # list with files, sizes, and ages + +procedure main(param) + local i, option, j + calc_today() + files := directory() + method := "none" + output := "long" + command := "" + if *param = 0 then show_age() + every i := 1 to *param do + { + (option := param[i]) | break + case option of + { + "to" | + "before" | + "until" : { + files := before(files,param[i+1]) + i +:= 1 + } + "from" | + "since" | + "after" : { + files := since(files,param[i+1]) + i +:= 1 + } + "asc" : method:="ascending" + "des" : method:="descending" + "long" : output:="long" + "brief" : output:="brief" + "do" : { + every j := i+1 to *param do + command ||:= param[j] || " " + } + default : 5 # stop("Unrecognized option :",option) + } + } + show_age() + end + +# +# just show another ls with days old numbers & optionally sorts +# +procedure show_age() + local line, age, ks, file, text, results, i + case method of + { + "none" : { + every line := !files do + { + age := (today - parse(line,' ')[1]) / 86400 + ks := parse(line,' ')[2] / 1024 + file:= line[23:0] + (command == "") | + { + write(command,line[37:0]) + system(command || line[37:0]) + next + } + if output == "brief" then text := line[37:0] + else text:= right(age,6) || " days " || right(ks,6) || " kb | " || file + write(text) + } + } + "descending" : { + results := sort(files) + every line := !results do + { + age := (today - parse(line,' ')[1]) / 86400 + ks := parse(line,' ')[2] / 1024 + file:= line[23:0] + (command == "") | + { + write(command,line[37:0]) + system(command || line[37:0]) + next + } + if output == "brief" then text := line[37:0] + else text:= right(age,6) || " days " || right(ks,6) || " kb | " || file + write(text) + } + } + "ascending" : { + results := sort(files) + every i := *results to 1 by -1 do + { + line:= results[i] + age := (today - parse(line,' ')[1]) / 86400 + ks := parse(line,' ')[2] / 1024 + file:= line[23:0] + (command == "") | + { + write(command,line[37:0]) + system(command || line[37:0]) + next + } + if output == "brief" then text := line[37:0] + else text:= right(age,6) || " days " || right(ks,6) || " kb | " || file + write(text) + } + } + default : 5 + } + end + +# +# remove elements later than a date +# +procedure before(lst,days) + local i, mo, da, yr, tmp, dd, age, work, file, old + static mtab + initial mtab := [0,31,59,90,120,151,181,212,243,273,304,334] + if find("/",days) then + { + mo := parse(days,'/')[1] + da := parse(days,'/')[2] + yr := parse(days,'/')[3] | parse(&date,'/')[1] + if yr < 100 then yr +:= 1900 + tmp := yr * 31557600 + dd := mtab[mo] + da + if ((yr % 4) = 0) & (mo > 2) then dd +:= 1 + tmp+:= dd * 86400 + age := tmp + } else { + age := now - (days * 86400) + } + work := [] + every file := !lst do + { + old := parse(file,' ')[1] + if old <= age then put(work,file) + } + return copy(work) + end + +# +# remove elements earlier than a date +# +procedure since(lst,days) + local mo, da, yr, tmp, dd, age, work, file, old + static mtab + initial mtab := [0,31,59,90,120,151,181,212,243,273,304,334] + if find("/",days) then + { + mo := parse(days,'/')[1] + da := parse(days,'/')[2] + yr := parse(days,'/')[3] | parse(&date,'/')[1] + if yr < 100 then yr +:= 1900 + tmp := yr * 31557600 + dd := mtab[mo] + da + if ((yr % 4) = 0) & (mo > 2) then dd +:= 1 + tmp+:= dd * 86400 + age := tmp + } else { + age := now - (days * 86400) + } + work := [] + every file := !lst do + { + old := parse(file,' ')[1] + if old >= age then put(work,file) + } + return copy(work) + end + +# +# calculate today and now figures +# +procedure calc_today() + local tmpy, tmpm, tmpd, here + static mtab + initial { + base := 1970*31557600 + mtab := [0,31,59,90,120,151,181,212,243,273,304,334] + } + tmpy := parse(&date,'/')[1] + tmpm := parse(&date,'/')[2] + tmpd := parse(&date,'/')[3] + here := tmpy * 31557600 + + (mtab[tmpm] + tmpd) * 86400 + if ((tmpy%4) = 0) & (tmpm > 2) then here +:= 86400 + today := here + now := here + + parse(&clock,':')[1] * 3600 + + parse(&clock,':')[2] * 60 + + parse(&clock,':')[3] + end + +# +# convert a ls -al output into a list for sorting and printing +# +procedure directory() + local pipe, entries, line, size, file, day, year, sec, mark, text + static mtab + initial { + mtab := table(0) + mtab["Jan"] := 0 + mtab["Feb"] := 31 + mtab["Mar"] := 59 + mtab["Apr"] := 90 + mtab["May"] := 120 + mtab["Jun"] := 151 + mtab["Jul"] := 181 + mtab["Aug"] := 212 + mtab["Sep"] := 243 + mtab["Oct"] := 273 + mtab["Nov"] := 304 + mtab["Dec"] := 334 + } + pipe := open("ls -al","pr") + entries := [] + every line := !pipe do + { + if any('dclst',line) then next # ignore info and dirs + size := parse(line,' ')[4] + file := line[33:0] + day := mtab[parse(line,' ')[5]] + parse(line,' ')[6] + year := if line[40] == " " then parse(line,' ')[7] else parse(&date,'/')[1] + sec := if line[40] == " " then 0 else hhmm(parse(line,' ')[7]) + mark := year * 31557600 + day * 86400 + sec + if (now-mark) < 0 then mark -:= 31557600 + text := right(mark,12) || right(size,10) || " " || file + put(entries,text) + } + close(pipe) + return entries + end + +# +# convert hh:mm into seconds since midnight +# +procedure hhmm(str) + local hh, mm + hh := str[1+:2] + mm := str[4+:2] + return hh*3600 + mm*60 + end + +# +# parse a string into a list with respect to a delimiter +# +procedure parse(line,delims) + local tokens + static chars + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + return tokens + end + + diff --git a/ipl/progs/wshfdemo.icn b/ipl/progs/wshfdemo.icn new file mode 100644 index 0000000..3382a4e --- /dev/null +++ b/ipl/progs/wshfdemo.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: wshfdemo.icn +# +# Subject: Program to demonstrate weighted shuffle procedure +# +# Author: Erik Eid +# +# Date: May 23, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is a short demo of the WeightedShuffle procedure. The +# user is first prompted for a random number seed. Then, the user is asked +# to enter a size for the list to be shuffled and what percentage of that +# list to be shuffled. The original and shuffled lists are then displayed. +# +############################################################################ +# +# Links: weighted +# +############################################################################ + +link weighted + +procedure main() +local before, after, num, pct, yn, seed + write (center("Weighted Shuffle Demonstration", 80)) + repeat { + writes ("Enter random number seed: ") + seed := read() + if seed == "" then break # Use default random seed. + if seed = integer(seed) then + break &random := seed # Use given random seed. + } + repeat { + repeat { + writes ("Size of list to shuffle (1-500)? ") + num := read() + if num = integer(num) then if (0 < num <= 500) then break + } + repeat { + writes ("Shuffle what percentage (0=none, 100=all)? ") + pct := read() + if pct = numeric(pct) then if (0 <= pct <= 100) then break + } + before := list() + every put (before, (1 to num)) + write ("\nBefore shuffle:") + DisplayList (before) + after := WeightedShuffle (before, pct) + write ("\nAfter ", pct, "% shuffle:") + DisplayList (after) + writes ("\nDo another [Y/N]? ") + yn := getche() + write("\n") + if not (yn == ("Y" | "y")) then break + } +end + +procedure DisplayList (L) + every writes (right(!L, 4)) +end + diff --git a/ipl/progs/xtable.icn b/ipl/progs/xtable.icn new file mode 100644 index 0000000..afa9061 --- /dev/null +++ b/ipl/progs/xtable.icn @@ -0,0 +1,138 @@ +############################################################################ +# +# File: xtable.icn +# +# Subject: Program to show character code translations +# +# Author: Robert J. Alexander, modified by Alan Beale +# +# Date: July 20, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Program to print various character translation tables. See +# procedure help() for the capabilities. +# +############################################################################ +# +# Links: options, colmize, hexcvt, ebcdic +# +############################################################################ + +link options, colmize, hexcvt, ebcdic + +global Graphic, Conv + +procedure main(arg) + local opt + + opt := options(arg,"acedo") + Conv := if \opt["d"] then "d" else if \opt["o"] then "o" + init() + every write(colmize( + if \opt["a"] then ASCII() + else if \opt["e"] then EBCDIC() + else if \opt["c"] then ASCIICtrl() + else help() + )) +end + +procedure help() + write("Usage: xtable -<option>") + write("Options:") + write("\ta: ASCII table") + write("\tc: ASCII control char table") + write("\te: EBCDIC table") + write("\td: decimal numbers") + write("\te: octal numbers") +end + +procedure init() + Graphic := cset(Ascii128()[33:-1]) +end + +procedure ASCII() + local c,i,lst,a128 + lst := [] + a128 := Ascii128() + every c := !a128 do { + i := AsciiOrd(c) + if not any(Graphic,c) then { + c := image(c)[2:-1] + if match("\\x",c) then next + } + put(lst,"| " || convert(i) || " " || c) + } + return lst +end + +procedure ASCIICtrl() + local a,c,ctrls,i,lst,a128 + ctrls := "\^ \^!\^"\^#\^$\^%\^&\^'\^(\^)\^*\^+\^,\^-\^.\^/_ + \^0\^1\^2\^3\^4\^5\^6\^7\^8\^9\^:\^;\^<\^=\^>\^?\^@_ + \^A\^B\^C\^D\^E\^F\^G\^H\^I\^J\^K\^L\^M_ + \^N\^O\^P\^Q\^R\^S\^T\^U\^V\^W\^X\^Y\^Z_ + \^[\^\\^]\^^\^_\^`_ + \^a\^b\^c\^d\^e\^f\^g\^h\^i\^j\^k\^l\^m_ + \^n\^o\^p\^q\^r\^s\^t\^u\^v\^w\^x\^y\^z_ + \^{\^|\^}\^~" + lst := [] + a128 := Ascii128() + a := create !a128[33:-1] + every c := !ctrls do { + i := AsciiOrd(c) + put(lst,"| " || convert(i) || " ^" || @a) + } + return lst +end + +procedure EBCDIC() + local EBCDICMap,c,i,lst + EBCDICMap := repl(".",64) || # 00 - 3F + " ...........<(+|&.........!$*);^" || # 40 - 5F + "-/.........,%_>?.........`:#@'=\"" || # 60 - 7F + ".abcdefghi.......jklmnopqr......" || # 80 - 9F + ".~stuvwxyz...[...............].." || # A0 - BF + "{ABCDEFGHI......}JKLMNOPQR......" || # C0 - CF + "\\.STUVWXYZ......0123456789......" # E0 - FF + lst := [] + i := -1 + every c := !EBCDICMap do { + i +:= 1 + if i = 16r4B | "." ~== c then + put(lst,"| " || convert(i) || " " || c) + } + return lst +end + +procedure convert(n) + return case Conv of { + "d": right(n,3,"0") + "o": octstring(n,3) + default: hexstring(n,2) + } +end + +# +# octstring() -- Returns a string that is the octal +# representation of the argument. +# +procedure octstring(i,n) + local s + i := integer(i) | fail + if i = 0 then s := "0" + else { + s := "" + while i ~= 0 do { + s := iand(i,7) || s + i := ishift(i,-3) + } + } + s := right(s,\n,"0") + return s +end + diff --git a/ipl/progs/yahtz.icn b/ipl/progs/yahtz.icn new file mode 100644 index 0000000..4c259b6 --- /dev/null +++ b/ipl/progs/yahtz.icn @@ -0,0 +1,575 @@ +############################################################################ +# +# File: yahtz.icn +# +# Subject: Program to play yahtzee +# +# Author: Chris Tenaglia +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.3 +# +############################################################################ +# +# Modified by Richard Goerwitz with corrections by Phillip Lee Thomas +# +############################################################################ +# +# This hacked version will run under UNIX, and under DOS as well. It +# should run out of the box on DOS as long as you stay in the current +# directory. See the README file. +# +# This is a test version!! In accordance with the author's wishes, +# I'd like to make it clear that I've altered all the screen I/O +# routines, and have removed characters peculiar to VT terminals. +# I've tried to keep intact the author's indentation and brace style. +# Changes, where present, have been indicated by my initials. The +# IPL-style header was added by me. +# +# -Richard Goerwitz. +# +############################################################################ +# +# Links: iolib, random +# +############################################################################ + +link iolib +link random + +global players,slot,team,d,od,dice,round +procedure main(param) + paint() + assign_players() + every round := 1 to 13 do + every play(!team) + summarize() + end + +# +# DISPLAYS THE HEADER AND SEPARATOR LINE AT BEGINNING OF GAME +# +procedure paint() + # Clear first, separately. Screws up on some terminals of you don't. + writes(cls()) + # Check to be sure the terminal is big enough, and won't leave magic + # cookies on the screen. -RLG + if getval("ug"|"sg") > 0 + then stop("abort: Can't do magic cookie terminals!") + if getval("li") < 24 | getval("co") < 80 then + stop("abort: Your terminal is too small!") + write(high(uhalf(" Y A H T Z E E "))) + write(high(lhalf(" Y A H T Z E E "))) + write(at(1,10),graf(repl("=",75))) + end + +# +# DISPLAYS THE FINAL SCORE OF ALL THE PLAYERS +# +procedure summarize() + local player, card, top, bottom, i + + # blink, high, inverse was just too much for my terminal to handle -RLG + write(at(1,11), high(chop("Final Score Summary"))) + every player := key(players) do + { + card := players[player] + top := 0 ; every i := 1 to 6 do top +:= card[i] + if top > 62 then top +:= 35 + bottom := 0 ; every i := 7 to 13 do bottom +:= card[i] + write("Player ",high(left(player,14))," Top = ",right(top,5), + " Bottom = ",right(bottom,5), + " Total = ",right(top+bottom,5)) + } + input("<press return>") + end + +# +# SETUP AND INITIALIZATION OF YAHTZEE ENVIRONMENT +# +procedure assign_players() + local n, player + + n := 1 ; team := [] ; slot := [] ; d := list(6,"") ; od := list(5,0) + randomize() + players := table("n/a") + repeat + { + (player := input(("Name of player #" || n || ": "))) | + stop("Game called off.") + if player == "" then break + n +:= 1 + put(team,player) + players[player] := list(13,"*") + } + if n = 1 then stop("Nobody wants to play!") + + put(slot,"Ones") ; put(slot,"Twos") ; put(slot,"Threes") + put(slot,"Fours") ; put(slot,"Fives") ; put(slot,"Sixes") + put(slot,"3oK") ; put(slot,"4oK") ; put(slot,"FullH") + put(slot,"SmStr") ; put(slot,"LgStr") ; put(slot,"Yahtzee") + put(slot,"Chance") + + # VT-specific characters removed. -RLG + d[1] := "+-----+| || o || |+-----+" + d[2] := "+-----+| || o o || |+-----+" + d[3] := "+-----+|o || o || o|+-----+" + d[4] := "+-----+|o o|| ||o o|+-----+" + d[5] := "+-----+|o o|| o ||o o|+-----+" + d[6] := "+-----+|o o o|| ||o o o|+-----+" + end + +# +# THIS ROUTINE LETS A PLAYER TAKE THEIR TURN +# +procedure play(name) + local shake, select + + writes(at(1,11),"It's ",high(name),"'s turn",chop()) + writes(at(1,getval("li")-1),high(name)) + input(", please press <RETURN> to begin.") + score(name) + dice := [] ; every 1 to 5 do put(dice,?6) + depict() + shake := obtain("Shake which ones : ") + (shake === []) | (every dice[!shake] := ?6) + depict() + shake := obtain("Shake which ones (last chance) : ") + (shake === []) | (every dice[!shake] := ?6) + depict() + repeat + { + select := input(at(1,22) || clip("Tally to which category (1-13) : ")) + numeric(select) | next + (1 <= select <= 13) | next + (players[name][select] == "*") | next + break + } + tally(name,select) + score(name) + input(at(1,22) || clip("Press <RETURN>")) + end + +# +# THIS ROUTINE DRAWS THE DICE +# +procedure depict() + local i, j, x + + every i := 1 to 5 do + { + x := 1 + writes(at(i*10+3,3),inverse(i)) + writes(at(i*10+4,9),inverse(dice[i])) + every j := 4 to 8 do + { # debug + writes(at(i*10,j),graf(d[dice[i]][x:x+7])) + x +:= 7 + } + od[i] := dice[i] + } + end + +# +# THIS ROUTINE LETS THE PLAYER DECIDE WHAT TO APPLY THE SHAKES TO +# +procedure tally(name,area) + local sum, unit, flag, tmp, piece, hold + + case integer(area) of + { + 1 : { # ones + sum := 0 ; every unit := !dice do if unit = 1 then sum +:= 1 + players[name][1] := sum + } + 2 : { # twos + sum := 0 ; every unit := !dice do if unit = 2 then sum +:= 2 + players[name][2] := sum + } + 3 : { # threes + sum := 0 ; every unit := !dice do if unit = 3 then sum +:= 3 + players[name][3] := sum + } + 4 : { # fours + sum := 0 ; every unit := !dice do if unit = 4 then sum +:= 4 + players[name][4] := sum + } + 5 : { # fives + sum := 0 ; every unit := !dice do if unit = 5 then sum +:= 5 + players[name][5] := sum + } + 6 : { # sixes + sum := 0 ; every unit := !dice do if unit = 6 then sum +:= 6 + players[name][6] := sum + } + 7 : { # 3 of a kind + sum := 0 ; flag := 0 + tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1 + every piece := key(tmp) do + if tmp[piece] >= 3 then flag := 1 + if flag = 1 then every sum +:= !dice + players[name][7] := sum + } + 8 : { # four of a kind + sum := 0 ; flag := 0 + tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1 + every piece := key(tmp) do + if tmp[piece] >= 4 then flag := 1 + if flag = 1 then every sum +:= !dice + players[name][8] := sum + } + 9 : { # full house + sum := 0 ; flag := 0 + tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1 + every piece := key(tmp) do + { + if tmp[piece] = 3 then flag +:= 1 + if tmp[piece] = 2 then flag +:= 1 + } + if flag = 2 then sum := 25 + players[name][9] := sum + } + 10 : { # small straight + sum := 0 ; flag := 0 + hold := set() ; every insert(hold,!dice) + tmp := sort(hold) + if tmp[1]+1 = tmp[2] & + tmp[2]+1 = tmp[3] & + tmp[3]+1 = tmp[4] then flag := 1 + if tmp[2]+1 = tmp[3] & + tmp[3]+1 = tmp[4] & + tmp[4]+1 = tmp[5] then flag := 1 + if flag = 1 then sum := 30 + players[name][10] := sum + } + 11 : { # large straight + sum := 0 ; flag := 0 + tmp := sort(dice) + if tmp[1]+1 = tmp[2] & + tmp[2]+1 = tmp[3] & + tmp[3]+1 = tmp[4] & + tmp[4]+1 = tmp[5] then flag := 1 + if flag = 1 then sum := 40 + players[name][11] := sum + } + 12 : { # yahtzee + sum := 0 ; flag := 0 + tmp := table(0) ; every unit := !dice do tmp[unit] +:= 1 + every piece := key(tmp) do + if tmp[piece] = 5 then flag := 1 + if flag = 1 then sum := 50 + players[name][12] := sum + } + 13 : { # chance + sum := 0 ; every sum +:= !dice + players[name][13] := sum + } + } + end + +# +# THIS ROUTINE OBTAINS A VALID SHAKER REQUEST +# +procedure obtain(prompt) + local line, unit, units + + repeat + { + writes(at(1,22),prompt) + (line := read()) | next + if match("q",map(line)) then stop("Game Quit") + if trim(line) == "" then return [] + units := parse(line,', \t') + every unit := !units do + (1 <= unit <= 5) | next + break + } + return units + end + +# +# THIS ROUTINE PAINTS THE SCORECARD FOR A GIVEN PLAYER +# +procedure score(name) + local st1, st2, i, bonus + + # Slight realignment. -RLG + writes(at(1,11),chop(),at(18,11),under(),"Player = ",name," Round = ",under(round)) + writes(at(10,12)," 1 : Ones = ",players[name][1]) + writes(at(10,13)," 2 : Twos = ",players[name][2]) + writes(at(10,14)," 3 : Threes = ",players[name][3]) + writes(at(10,15)," 4 : Fours = ",players[name][4]) + writes(at(10,16)," 5 : Fives = ",players[name][5]) + writes(at(10,17)," 6 : Sixes = ",players[name][6]) + writes(at(40,12)," 7 : 3oK = ",players[name][7]) + writes(at(40,13)," 8 : 4oK = ",players[name][8]) + writes(at(40,14)," 9 : FullH = ",players[name][9]) + writes(at(40,15),"10 : SmStr = ",players[name][10]) + writes(at(40,16),"11 : LgStr = ",players[name][11]) + writes(at(40,17),"12 : Yahtzee = ",players[name][12]) + writes(at(40,18),"13 : Chance = ",players[name][13]) + st1 := 0 ; every i := 1 to 6 do st1 +:= numeric(players[name][i]) + if st1 > 62 then bonus := 35 else bonus := 0 + st2 := 0 ; every i := 7 to 13 do st2 +:= numeric(players[name][i]) + writes(at(10,19),"Bonus = ",clip(bonus)) + writes(at(10,20),"Subtotal = ",st1+bonus) + writes(at(40,20),"Subtotal = ",st2) + writes(at(37,21),"Grand Total = ",st1+st2+bonus) + end + +# +# From here down, all CT's VT-specific I/O codes have been replaced +# with calls to iolib/itlib routines. The replacements were quite +# easy to do because of the great modularity of the original program. +# -RLG +# + +# +# VIDEO ROUTINE CLEARS SCREEN +# +procedure cls(str) + static clear_string + initial { + clear_string := getval("cl") | + (igoto(getval("cm"),1,1) || getval("cd")) | + stop("abort: Your terminal can't clear screen!") + } + /str := "" + return clear_string || str + end + +# +# VIDEO ROUTINE ERASES REST OF SCREEN +# +procedure chop(str) + static clear_rest + initial { + clear_rest := getval("cd") | + stop("abort: Sorry, your terminal must have cd capability.") + } + /str := "" + return clear_rest || str + end + +# +# VIDEO ROUTINE OUTPUTS UPPER HALF OF DOUBLE SIZE MESSAGES +# +procedure uhalf(str) + # Disabled for non-VT{2,3,4}XX terminals. I'd have left them in for + # vt100s, but there are so many vt100 terminal emulation programs out + # there that don't do the big characters that I thought better of it. + # -RLG + static isVT + initial + { + if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0))) + then isVT := 1 + } + if \isVT then + { + /str := "" + if str == "" then return "\e#3" + return "\e#3" || str + } + end + +# +# VIDEO ROUTINE OUTPUTS BOTTOM HALF OF DOUBLE SIZE MESSAGES +# +procedure lhalf(str) + static isVT + initial + { + if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0))) + then isVT := 1 + } + if \isVT then + { + /str := "" + if str == "" then return "\e#4" + return "\e#4" || str + } + end + +# +# VIDEO ROUTINE OUTPUTS STRING AND CLEARS TO EOL +# +procedure clip(str) + static clear_line + initial + { + clear_line := getval("ce") | " " + } + /str := "" + if str == "" then return clear_line + return str ||:= clear_line + end + +# +# VIDEO ROUTINE OUTPUTS HIGHLIGHTED STRINGS +# +procedure high(str) + static bold_code, off_other_modes + initial + { + off_other_modes := "" + every off_other_modes ||:= getval("me"|"ue"|"se") + bold_code := off_other_modes || getval("md"|"us"|"so") + } + /str := "" + return bold_code || str || off_other_modes + end + +# +# VIDEO ROUTINE OUTPUTS INVERSE VIDEO STRINGS +# +procedure inverse(str) + static reverse_code, off_other_modes + initial + { + off_other_modes := "" + every off_other_modes ||:= getval("se"|"ue"|"me") + reverse_code := off_other_modes || getval("so"|"us"|"md") + } + /str := "" + return reverse_code || str || off_other_modes + end + +# +# VIDEO ROUTINE OUTPUTS UNDERLINED STRINGS +# +procedure under(str) + static underline_code, off_other_modes + initial + { + off_other_modes := "" + every off_other_modes ||:= getval("ue"|"me"|"se") + underline_code := off_other_modes || getval("us"|"md"|"so") + } + /str := "" + return underline_code || str || off_other_modes + end + +# +# VIDEO ROUTINE OUTPUTS BLINKING STRINGS +# +procedure blink(str) + static blink_code, off_other_modes + initial + { + off_other_modes := "" + every off_other_modes ||:= getval("me"|"se"|"ue") + blink_code := off_other_modes || getval("mb"|"md"|"so"|"us") + } + /str := "" + return blink_code || str || off_other_modes + end + +# +# VIDEO ROUTINE SETS NORMAL VIDEO MODE +# +procedure norm(str) + static off_modes + initial + { + off_modes := "" + every off_modes ||:= getval("me"|"se"|"ue") + } + /str := "" + return off_modes || str + end + +# +# VIDEO ROUTINE TURNS ON VT GRAPHICS CHARACTERS +# +procedure graf(str) + # Again, disabled for non-VT{234}XX terminals. -RLG + static isVT + initial + { + if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0))) + then isVT := 1 + } + /str := "" + if \isVT then + { + if str == "" then return "\e(0" + str := "\e(0" || str + if (str[-3:0] == "\e(B") + then return str + else return str || "\e(B" + } + else return str + end + +# +# VIDEO ROUTINE TURNS OFF VT GRAPHICS CHARACTERS +# +procedure nograf(str) + static isVT + initial + { + if map(getname()) ? (tab(find("vt")+2), tab(any('234')), integer(tab(0))) + then isVT := 1 + } + /str := "" + if \isVT then + { + if str == "" then return "\e(B" + str := "\e(B" || str + } + return str + end + +# +# VIDEO ROUTINE SETS CURSOR TO GIVEN X,Y COORDINATES +# +procedure at(x,y) + return igoto(getval("cm"), x, y) + end + +######### Here end the I/O routines I needed to alter. -RLG + +# +# PARSES A STRING INTO A LIST WITH RESPECT TO A GIVEN DELIMITER +# +procedure parse(line,delims) + local i, tokens + static chars + chars := &cset -- delims + tokens := [] + line ? while tab(upto(chars)) do put(tokens,tab(many(chars))) + # + # My first time playing, I didn't put spaces between the numbers + # for the dice. When you think about it, though, why bother? + # They can't be any longer than one digit each, so there's no + # ambiguity. This bit of code makes the game a bit more idiot- + # proof. -RLG (one of the idiots) + # + if *!tokens > 1 then line ? + { + tokens := [] + if tab(upto(&digits)) then + { + while put(tokens, move(1)) do + tab(upto(&digits)) | break + put(tokens, integer(tab(0))) + } + } + return tokens + end + +# +# TAKE AN INPUT STRING VIA GIVEN PROMPT +# +procedure input(prompt) + writes(prompt) + return read() + end diff --git a/ipl/progs/yescr.icn b/ipl/progs/yescr.icn new file mode 100644 index 0000000..65e6d8b --- /dev/null +++ b/ipl/progs/yescr.icn @@ -0,0 +1,141 @@ +############################################################################ +# +# File: yescr.icn +# +# Subject: Program to convert UNIX files to DOS format +# +# Author: Richard L. Goerwitz +# +# Date: December 30, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.2 +# +############################################################################ +# +# This program simply inserts MS-DOS carriage-return+linefeed +# sequences in place of UNIX newlines. Effects conversion from the +# native UNIX text file format to its DOS correspondent. +# +# usage: yescr file1 [file2 [etc.]] +# +# Bug: Doesn't check to see whether the input files are in fact +# text files. +# +############################################################################ +# +# Requires: UNIX or MS-DOS +# +# See also: nocr.icn +# +############################################################################ + + +procedure main(a) + + local fname, infile, outfile, line, temp_name + + # Static variables, initial clause not really necessary in main(). + static slash, l, ms, DOSos, nok, ok + initial { + nok := string(~&letters) + ok := repl("X",*nok) + # Find us a place to put temporary files. + if find("UNIX",&features) then { + slash := "/" + l := 10 + ms := "" + } + else if find("MS-DOS", &features) then { + slash := "\\" + l := 8 + ms := "u" + DOSos := 1 + } + # Don't take this out unless you're sure of what you're doing. + else stop("yescr: tested only under UNIX and MS-DOS") + } + + # Check to see if we have any arguments. + *a = 0 & stop("usage: yescr file1 [file2...]") + + # Start popping filenames off of the argument list. + while fname := pop(a) do { + + # Open input file. + infile := open(fname,"r"||ms) | (er_out(fname), next) + # Get temporary file name. + every temp_name := + pathname(fname, slash) || + map(left(basename(fname,slash),l,"X"), nok, ok) || + "." || right(0 to 999,3,"0") + do close(open(temp_name)) | break + # Open temporary file. + outfile := open(temp_name,"w"||ms) | (er_out(temp_name), next) + + if \DOSos then { + # Read in blocks of 80 chars. + while line := reads(infile,80) do { + line ? { + # Replace ASCII LF with CR+LF, effecting a translation + # from UNIX to DOS format. + while writes(outfile, tab(find("\x0A")), "\x0D", move(1)) + writes(outfile, tab(0)) + } + } + } + else { + # I presume I'm running under UNIX (unless I've been hacked). + # Convert lines into DOS format by appending a carriage return, + # and then write()'ing (which automatically adds a newline). + every line := !infile do { + if line[-1] == "\x0D" + then write(outfile, line) + else write(outfile, line || "\x0D") + } + } + + # Close opened input and output files. + close(infile) | stop("yescr: cannot close, ",fname,"; aborting") + close(outfile) | stop("yescr: cannot close, ",temp_name,"; aborting") + + # Remove physical input file. + remove(fname) | stop("yescr: cannot remove ",fname,"; aborting") + + # Give temp name the same name as the input file, completing the + # conversion process. + rename(temp_name,fname) | + stop("yescr: Can't find temp file ",temp_name,"; aborting") + } + +end + + +procedure er_out(s) + write(&errout,"yescr: cannot open ",s," for reading") + return +end + + +procedure basename(s,slash) + s ? { + while tab(find(slash)+1) + return tab(0) + } +end + + +procedure pathname(s,slash) + local s2 + + s2 := "" + s ? { + while s2 ||:= tab(find(slash)+1) + return s2 + } +end diff --git a/ipl/progs/zipsort.icn b/ipl/progs/zipsort.icn new file mode 100644 index 0000000..1faa704 --- /dev/null +++ b/ipl/progs/zipsort.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: zipsort.icn +# +# Subject: Program to sort mailing labels by ZIP code +# +# Author: Ralph E. Griswold +# +# Date: November 17, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# 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 |